Index: a-dispat.ads =================================================================== --- a-dispat.ads (revision 0) +++ a-dispat.ads (revision 0) @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006, Free Software Foundation, Inc. -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Dispatching is + pragma Pure (Dispatching); + + Dispatching_Policy_Error : exception; +end Ada.Dispatching; Index: a-diroro.ads =================================================================== --- a-diroro.ads (revision 0) +++ a-diroro.ads (revision 0) @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . R O U N D _ R O B I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006, Free Software Foundation, Inc. -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with Ada.Real_Time; + +package Ada.Dispatching.Round_Robin is + + Default_Quantum : constant Ada.Real_Time.Time_Span := + Ada.Real_Time.Milliseconds (10); + + procedure Set_Quantum + (Pri : System.Priority; + Quantum : Ada.Real_Time.Time_Span); + + procedure Set_Quantum + (Low, High : System.Priority; + Quantum : Ada.Real_Time.Time_Span); + + function Actual_Quantum + (Pri : System.Priority) return Ada.Real_Time.Time_Span; + + function Is_Round_Robin (Pri : System.Priority) return Boolean; + +end Ada.Dispatching.Round_Robin; Index: a-diroro.adb =================================================================== --- a-diroro.adb (revision 0) +++ a-diroro.adb (revision 0) @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . R O U N D _ R O B I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Dispatching.Round_Robin is + + ----------------- + -- Set_Quantum -- + ----------------- + + procedure Set_Quantum + (Pri : System.Priority; + Quantum : Ada.Real_Time.Time_Span) + is + pragma Unreferenced (Quantum); + begin + if not Is_Round_Robin (Pri) then + raise Dispatching_Policy_Error; + end if; + end Set_Quantum; + + ----------------- + -- Set_Quantum -- + ----------------- + + procedure Set_Quantum + (Low, High : System.Priority; + Quantum : Ada.Real_Time.Time_Span) + is + pragma Unreferenced (Quantum); + begin + for Index in Low .. High loop + if not Is_Round_Robin (Index) then + raise Dispatching_Policy_Error; + end if; + end loop; + end Set_Quantum; + + -------------------- + -- Actual_Quantum -- + -------------------- + + function Actual_Quantum + (Pri : System.Priority) return Ada.Real_Time.Time_Span + is + begin + if Is_Round_Robin (Pri) then + return Default_Quantum; + else + raise Dispatching_Policy_Error; + end if; + end Actual_Quantum; + + -------------------- + -- Is_Round_Robin -- + -------------------- + + function Is_Round_Robin (Pri : System.Priority) return Boolean is + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + begin + return Get_Policy (Pri) = 'R'; + end Is_Round_Robin; + +end Ada.Dispatching.Round_Robin; Index: ali.adb =================================================================== --- ali.adb (revision 118179) +++ ali.adb (working copy) @@ -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; Index: ali.ads =================================================================== --- ali.ads (revision 118179) +++ ali.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -67,6 +67,9 @@ package ALI is type Interrupt_State_Id is range 6_000_000 .. 6_999_999; -- Id values used for Interrupt_State table entries + type Priority_Specific_Dispatching_Id is range 7_000_000 .. 7_999_999; + -- Id values used for Priority_Specific_Dispatching table entries + -------------------- -- ALI File Table -- -------------------- @@ -196,6 +199,14 @@ package ALI is -- the lower bound of the subtype). -- Not set if 'I' appears in Ignore_Lines + First_Specific_Dispatching : Priority_Specific_Dispatching_Id; + Last_Specific_Dispatching : Priority_Specific_Dispatching_Id'Base; + -- These point to the first and last entries in the priority specific + -- dispatching table for this unit. If there are no entries, then + -- Last_Specific_Dispatching = First_Specific_Dispatching - 1. That + -- is why the 'Base reference is there, it can be one less than the + -- lower bound of the subtype. Not set if 'S' appears in Ignore_Lines. + end record; No_Main_Priority : constant Int := -1; @@ -338,6 +349,14 @@ package ALI is Body_Needed_For_SAL : Boolean; -- Indicates that the source for the body of the unit (subprogram, -- package, or generic unit) must be included in a standalone library. + + Elaborate_Body_Desirable : Boolean; + -- Indicates that the front end elaboration circuitry decided that it + -- would be a good idea if this package had Elaborate_Body. The binder + -- will attempt, but does not promise, to place the elaboration call + -- for the body right after the call for the spec, or at least as close + -- together as possible. + end record; package Units is new Table.Table ( @@ -376,6 +395,40 @@ package ALI is Table_Increment => 200, Table_Name => "Interrupt_States"); + ----------------------------------------- + -- Priority Specific Dispatching Table -- + ----------------------------------------- + + -- An entry is made in this table for each S (priority specific + -- dispatching) line encountered in the input ALI file. The + -- First/Last_Specific_Dispatching_Id fields of the ALI file + -- entry show the range of entries defined within a particular + -- ALI file. + + type Specific_Dispatching_Record is record + Dispatching_Policy : Character; + -- First character (upper case) of the corresponding policy name + + First_Priority : Nat; + -- Lower bound of the priority range to which the specified dispatching + -- policy applies. + + Last_Priority : Nat; + -- Upper bound of the priority range to which the specified dispatching + -- policy applies. + + PSD_Pragma_Line : Nat; + -- Line number of Priority_Specific_Dispatching pragma + end record; + + package Specific_Dispatching is new Table.Table ( + Table_Component_Type => Specific_Dispatching_Record, + Table_Index_Type => Priority_Specific_Dispatching_Id'Base, + Table_Low_Bound => Priority_Specific_Dispatching_Id'First, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Priority_Specific_Dispatching"); + -------------- -- Switches -- -------------- @@ -418,7 +471,7 @@ package ALI is -- Set to blank by Initialize_ALI. Set to the appropriate queuing policy -- character if an ali file contains a P line setting the queuing policy. - Cumulative_Restrictions : Restrictions_Info; + Cumulative_Restrictions : Restrictions_Info := No_Restrictions; -- This variable records the cumulative contributions of R lines in all -- ali files, showing whether a restriction pragma exists anywhere, and -- accumulating the aggregate knowledge of violations. Index: bcheck.adb =================================================================== --- bcheck.adb (revision 118179) +++ bcheck.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 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- -- @@ -46,6 +46,7 @@ package body Bcheck is -- The following checking subprograms make up the parts of the -- configuration consistency check. + procedure Check_Consistent_Dispatching_Policy; procedure Check_Consistent_Dynamic_Elaboration_Checking; procedure Check_Consistent_Floating_Point_Format; procedure Check_Consistent_Interrupt_States; @@ -63,9 +64,9 @@ package body Bcheck is -- Used to compare two unit names for No_Dependence checks. U1 is in -- standard unit name format, and U2 is in literal form with periods. - ------------------------------------ - -- Check_Consistent_Configuration -- - ------------------------------------ + ------------------------------------- + -- Check_Configuration_Consistency -- + ------------------------------------- procedure Check_Configuration_Consistency is begin @@ -90,8 +91,352 @@ package body Bcheck is Check_Consistent_Restrictions; Check_Consistent_Interrupt_States; + Check_Consistent_Dispatching_Policy; end Check_Configuration_Consistency; + ----------------------- + -- Check_Consistency -- + ----------------------- + + procedure Check_Consistency is + Src : Source_Id; + -- Source file Id for this Sdep entry + + ALI_Path_Id : Name_Id; + + begin + -- First, we go through the source table to see if there are any cases + -- in which we should go after source files and compute checksums of + -- the source files. We need to do this for any file for which we have + -- mismatching time stamps and (so far) matching checksums. + + for S in Source.First .. Source.Last loop + + -- If all time stamps for a file match, then there is nothing to + -- do, since we will not be checking checksums in that case anyway + + if Source.Table (S).All_Timestamps_Match then + null; + + -- If we did not find the source file, then we can't compute its + -- checksum anyway. Note that when we have a time stamp mismatch, + -- we try to find the source file unconditionally (i.e. if + -- Check_Source_Files is False). + + elsif not Source.Table (S).Source_Found then + null; + + -- If we already have non-matching or missing checksums, then no + -- need to try going after source file, since we won't trust the + -- checksums in any case. + + elsif not Source.Table (S).All_Checksums_Match then + null; + + -- Now we have the case where we have time stamp mismatches, and + -- the source file is around, but so far all checksums match. This + -- is the case where we need to compute the checksum from the source + -- file, since otherwise we would ignore the time stamp mismatches, + -- and that is wrong if the checksum of the source does not agree + -- with the checksums in the ALI files. + + elsif Check_Source_Files then + if not Checksums_Match + (Source.Table (S).Checksum, + Get_File_Checksum (Source.Table (S).Sfile)) + then + Source.Table (S).All_Checksums_Match := False; + end if; + end if; + end loop; + + -- Loop through ALI files + + ALIs_Loop : for A in ALIs.First .. ALIs.Last loop + + -- Loop through Sdep entries in one ALI file + + Sdep_Loop : for D in + ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep + loop + if Sdep.Table (D).Dummy_Entry then + goto Continue; + end if; + + Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile)); + + -- If the time stamps match, or all checksums match, then we + -- are OK, otherwise we have a definite error. + + if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp + and then not Source.Table (Src).All_Checksums_Match + then + Error_Msg_Name_1 := ALIs.Table (A).Sfile; + Error_Msg_Name_2 := Sdep.Table (D).Sfile; + + -- Two styles of message, depending on whether or not + -- the updated file is the one that must be recompiled + + if Error_Msg_Name_1 = Error_Msg_Name_2 then + if Tolerate_Consistency_Errors then + Error_Msg + ("?% has been modified and should be recompiled"); + else + Error_Msg + ("% has been modified and must be recompiled"); + end if; + + else + ALI_Path_Id := + Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library); + if Osint.Is_Readonly_Library (ALI_Path_Id) then + if Tolerate_Consistency_Errors then + Error_Msg ("?% should be recompiled"); + Error_Msg_Name_1 := ALI_Path_Id; + Error_Msg ("?(% is obsolete and read-only)"); + + else + Error_Msg ("% must be compiled"); + Error_Msg_Name_1 := ALI_Path_Id; + Error_Msg ("(% is obsolete and read-only)"); + end if; + + elsif Tolerate_Consistency_Errors then + Error_Msg + ("?% should be recompiled (% has been modified)"); + + else + Error_Msg ("% must be recompiled (% has been modified)"); + end if; + end if; + + if (not Tolerate_Consistency_Errors) and Verbose_Mode then + declare + Msg : constant String := "% time stamp "; + Buf : String (1 .. Msg'Length + Time_Stamp_Length); + + begin + Buf (1 .. Msg'Length) := Msg; + Buf (Msg'Length + 1 .. Buf'Length) := + String (Source.Table (Src).Stamp); + Error_Msg_Name_1 := Sdep.Table (D).Sfile; + Error_Msg (Buf); + end; + + declare + Msg : constant String := " conflicts with % timestamp "; + Buf : String (1 .. Msg'Length + Time_Stamp_Length); + + begin + Buf (1 .. Msg'Length) := Msg; + Buf (Msg'Length + 1 .. Buf'Length) := + String (Sdep.Table (D).Stamp); + Error_Msg_Name_1 := Sdep.Table (D).Sfile; + Error_Msg (Buf); + end; + end if; + + -- Exit from the loop through Sdep entries once we find one + -- that does not match. + + exit Sdep_Loop; + end if; + + <> + null; + end loop Sdep_Loop; + end loop ALIs_Loop; + end Check_Consistency; + + ----------------------------------------- + -- Check_Consistent_Dispatching_Policy -- + ----------------------------------------- + + -- The rule is that all files for which the dispatching policy is + -- significant must meet the following rules: + + -- 1. All files for which a task dispatching policy is significant must + -- be compiled with the same setting. + + -- 2. If a partition contains one or more Priority_Specific_Dispatching + -- pragmas it cannot contain a Task_Dispatching_Policy pragma. + + -- 3. No overlap is allowed in the priority ranges specified in + -- Priority_Specific_Dispatching pragmas within the same partition. + + -- 4. If a partition contains one or more Priority_Specific_Dispatching + -- pragmas then the Ceiling_Locking policy is the only one allowed for + -- the partition. + + procedure Check_Consistent_Dispatching_Policy is + Max_Prio : Nat := 0; + -- Maximum priority value for which a Priority_Specific_Dispatching + -- pragma has been specified. + + TDP_Pragma_Afile : ALI_Id := No_ALI_Id; + -- ALI file where a Task_Dispatching_Policy pragma appears + + begin + -- Consistency checks in units specifying a Task_Dispatching_Policy + + if Task_Dispatching_Policy_Specified /= ' ' then + Find_Policy : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Task_Dispatching_Policy /= ' ' then + + -- Store the place where the first task dispatching pragma + -- appears. We may need this value for issuing consistency + -- errors if Priority_Specific_Dispatching pragmas are used. + + TDP_Pragma_Afile := A1; + + Check_Policy : declare + Policy : constant Character := + ALIs.Table (A1).Task_Dispatching_Policy; + + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Task_Dispatching_Policy /= ' ' + and then + ALIs.Table (A2).Task_Dispatching_Policy /= Policy + then + Error_Msg_Name_1 := ALIs.Table (A1).Sfile; + Error_Msg_Name_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("% and % compiled with different task" & + " dispatching policies"); + exit Find_Policy; + end if; + end loop; + end Check_Policy; + + exit Find_Policy; + end if; + end loop Find_Policy; + end if; + + -- If no Priority_Specific_Dispatching entries, nothing else to do + + if Specific_Dispatching.Last >= Specific_Dispatching.First then + + -- Find out the maximum priority value for which one of the + -- Priority_Specific_Dispatching pragmas applies. + + Max_Prio := 0; + for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop + if Specific_Dispatching.Table (J).Last_Priority > Max_Prio then + Max_Prio := Specific_Dispatching.Table (J).Last_Priority; + end if; + end loop; + + -- Now establish tables to be used for consistency checking + + declare + -- The following record type is used to record locations of the + -- Priority_Specific_Dispatching pragmas applying to the Priority. + + type Specific_Dispatching_Entry is record + Dispatching_Policy : Character := ' '; + -- First character (upper case) of corresponding policy name + + Afile : ALI_Id := No_ALI_Id; + -- ALI file that generated Priority Specific Dispatching + -- entry for consistency message. + + Loc : Nat := 0; + -- Line numbers from Priority_Specific_Dispatching pragma + end record; + + PSD_Table : array (0 .. Max_Prio) of Specific_Dispatching_Entry := + (others => Specific_Dispatching_Entry' + (Dispatching_Policy => ' ', + Afile => No_ALI_Id, + Loc => 0)); + -- Array containing an entry per priority containing the location + -- where there is a Priority_Specific_Dispatching pragma that + -- applies to the priority. + + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Specific_Dispatching .. + ALIs.Table (F).Last_Specific_Dispatching + loop + declare + DTK : Specific_Dispatching_Record + renames Specific_Dispatching.Table (K); + begin + -- Check whether pragma Task_Dispatching_Policy and + -- pragma Priority_Specific_Dispatching are used in the + -- same partition. + + if Task_Dispatching_Policy_Specified /= ' ' then + Error_Msg_Name_1 := ALIs.Table (F).Sfile; + Error_Msg_Name_2 := + ALIs.Table (TDP_Pragma_Afile).Sfile; + + Error_Msg_Nat_1 := DTK.PSD_Pragma_Line; + + Consistency_Error_Msg + ("Priority_Specific_Dispatching at %:#" & + " incompatible with Task_Dispatching_Policy at %"); + end if; + + -- Ceiling_Locking must also be specified for a partition + -- with at least one Priority_Specific_Dispatching + -- pragma. + + if Locking_Policy_Specified /= ' ' + and then Locking_Policy_Specified /= 'C' + then + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Locking_Policy /= ' ' + and then ALIs.Table (A).Locking_Policy /= 'C' + then + Error_Msg_Name_1 := ALIs.Table (F).Sfile; + Error_Msg_Name_2 := ALIs.Table (A).Sfile; + + Error_Msg_Nat_1 := DTK.PSD_Pragma_Line; + + Consistency_Error_Msg + ("Priority_Specific_Dispatching at %:#" & + " incompatible with Locking_Policy at %"); + end if; + end loop; + end if; + + -- Check overlapping priority ranges + + Find_Overlapping : for Prio in + DTK.First_Priority .. DTK.Last_Priority + loop + if PSD_Table (Prio).Afile = No_ALI_Id then + PSD_Table (Prio) := + (Dispatching_Policy => DTK.Dispatching_Policy, + Afile => F, Loc => DTK.PSD_Pragma_Line); + + elsif PSD_Table (Prio).Dispatching_Policy /= + DTK.Dispatching_Policy + + then + Error_Msg_Name_1 := + ALIs.Table (PSD_Table (Prio).Afile).Sfile; + Error_Msg_Name_2 := ALIs.Table (F).Sfile; + Error_Msg_Nat_1 := PSD_Table (Prio).Loc; + Error_Msg_Nat_2 := DTK.PSD_Pragma_Line; + + Consistency_Error_Msg + ("overlapping priority ranges at %:# and %:#"); + + exit Find_Overlapping; + end if; + end loop Find_Overlapping; + end; + end loop; + end loop; + end; + end if; + end Check_Consistent_Dispatching_Policy; + --------------------------------------------------- -- Check_Consistent_Dynamic_Elaboration_Checking -- --------------------------------------------------- @@ -579,29 +924,6 @@ package body Bcheck is end loop; end Check_Consistent_Restrictions; - --------------- - -- Same_Unit -- - --------------- - - function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean is - begin - -- Note, the string U1 has a terminating %s or %b, U2 does not - - if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then - Get_Name_String (U1); - - declare - U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2); - begin - Get_Name_String (U2); - return U1_Str = Name_Buffer (1 .. Name_Len); - end; - - else - return False; - end if; - end Same_Unit; - --------------------------------------------------- -- Check_Consistent_Zero_Cost_Exception_Handling -- --------------------------------------------------- @@ -614,7 +936,6 @@ package body Bcheck is Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop if ALIs.Table (A1).Zero_Cost_Exceptions /= ALIs.Table (ALIs.First).Zero_Cost_Exceptions - then Error_Msg_Name_1 := ALIs.Table (A1).Sfile; Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile; @@ -625,160 +946,6 @@ package body Bcheck is end loop Check_Mechanism; end Check_Consistent_Zero_Cost_Exception_Handling; - ----------------------- - -- Check_Consistency -- - ----------------------- - - procedure Check_Consistency is - Src : Source_Id; - -- Source file Id for this Sdep entry - - ALI_Path_Id : Name_Id; - - begin - -- First, we go through the source table to see if there are any cases - -- in which we should go after source files and compute checksums of - -- the source files. We need to do this for any file for which we have - -- mismatching time stamps and (so far) matching checksums. - - for S in Source.First .. Source.Last loop - - -- If all time stamps for a file match, then there is nothing to - -- do, since we will not be checking checksums in that case anyway - - if Source.Table (S).All_Timestamps_Match then - null; - - -- If we did not find the source file, then we can't compute its - -- checksum anyway. Note that when we have a time stamp mismatch, - -- we try to find the source file unconditionally (i.e. if - -- Check_Source_Files is False). - - elsif not Source.Table (S).Source_Found then - null; - - -- If we already have non-matching or missing checksums, then no - -- need to try going after source file, since we won't trust the - -- checksums in any case. - - elsif not Source.Table (S).All_Checksums_Match then - null; - - -- Now we have the case where we have time stamp mismatches, and - -- the source file is around, but so far all checksums match. This - -- is the case where we need to compute the checksum from the source - -- file, since otherwise we would ignore the time stamp mismatches, - -- and that is wrong if the checksum of the source does not agree - -- with the checksums in the ALI files. - - elsif Check_Source_Files then - if not Checksums_Match - (Source.Table (S).Checksum, - Get_File_Checksum (Source.Table (S).Sfile)) - then - Source.Table (S).All_Checksums_Match := False; - end if; - end if; - end loop; - - -- Loop through ALI files - - ALIs_Loop : for A in ALIs.First .. ALIs.Last loop - - -- Loop through Sdep entries in one ALI file - - Sdep_Loop : for D in - ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep - loop - if Sdep.Table (D).Dummy_Entry then - goto Continue; - end if; - - Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile)); - - -- If the time stamps match, or all checksums match, then we - -- are OK, otherwise we have a definite error. - - if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp - and then not Source.Table (Src).All_Checksums_Match - then - Error_Msg_Name_1 := ALIs.Table (A).Sfile; - Error_Msg_Name_2 := Sdep.Table (D).Sfile; - - -- Two styles of message, depending on whether or not - -- the updated file is the one that must be recompiled - - if Error_Msg_Name_1 = Error_Msg_Name_2 then - if Tolerate_Consistency_Errors then - Error_Msg - ("?% has been modified and should be recompiled"); - else - Error_Msg - ("% has been modified and must be recompiled"); - end if; - - else - ALI_Path_Id := - Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library); - if Osint.Is_Readonly_Library (ALI_Path_Id) then - if Tolerate_Consistency_Errors then - Error_Msg ("?% should be recompiled"); - Error_Msg_Name_1 := ALI_Path_Id; - Error_Msg ("?(% is obsolete and read-only)"); - - else - Error_Msg ("% must be compiled"); - Error_Msg_Name_1 := ALI_Path_Id; - Error_Msg ("(% is obsolete and read-only)"); - end if; - - elsif Tolerate_Consistency_Errors then - Error_Msg - ("?% should be recompiled (% has been modified)"); - - else - Error_Msg ("% must be recompiled (% has been modified)"); - end if; - end if; - - if (not Tolerate_Consistency_Errors) and Verbose_Mode then - declare - Msg : constant String := "% time stamp "; - Buf : String (1 .. Msg'Length + Time_Stamp_Length); - - begin - Buf (1 .. Msg'Length) := Msg; - Buf (Msg'Length + 1 .. Buf'Length) := - String (Source.Table (Src).Stamp); - Error_Msg_Name_1 := Sdep.Table (D).Sfile; - Error_Msg (Buf); - end; - - declare - Msg : constant String := " conflicts with % timestamp "; - Buf : String (1 .. Msg'Length + Time_Stamp_Length); - - begin - Buf (1 .. Msg'Length) := Msg; - Buf (Msg'Length + 1 .. Buf'Length) := - String (Sdep.Table (D).Stamp); - Error_Msg_Name_1 := Sdep.Table (D).Sfile; - Error_Msg (Buf); - end; - end if; - - -- Exit from the loop through Sdep entries once we find one - -- that does not match. - - exit Sdep_Loop; - end if; - - <> - null; - end loop Sdep_Loop; - end loop ALIs_Loop; - end Check_Consistency; - ------------------------------- -- Check_Duplicated_Subunits -- ------------------------------- @@ -880,4 +1047,27 @@ package body Bcheck is end if; end Consistency_Error_Msg; + --------------- + -- Same_Unit -- + --------------- + + function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean is + begin + -- Note, the string U1 has a terminating %s or %b, U2 does not + + if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then + Get_Name_String (U1); + + declare + U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2); + begin + Get_Name_String (U2); + return U1_Str = Name_Buffer (1 .. Name_Len); + end; + + else + return False; + end if; + end Same_Unit; + end Bcheck; Index: bindgen.adb =================================================================== --- bindgen.adb (revision 118179) +++ bindgen.adb (working copy) @@ -24,24 +24,24 @@ -- -- ------------------------------------------------------------------------------ -with ALI; use ALI; -with Binde; use Binde; -with Casing; use Casing; -with Fname; use Fname; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Gnatvsn; use Gnatvsn; +with ALI; use ALI; +with Binde; use Binde; +with Casing; use Casing; +with Fname; use Fname; +with Gnatvsn; use Gnatvsn; with Hostparm; -with Namet; use Namet; -with Opt; use Opt; -with Osint; use Osint; -with Osint.B; use Osint.B; -with Output; use Output; -with Rident; use Rident; -with Table; use Table; -with Targparm; use Targparm; -with Types; use Types; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Osint.B; use Osint.B; +with Output; use Output; +with Rident; use Rident; +with Table; use Table; +with Targparm; use Targparm; +with Types; use Types; -with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; package body Bindgen is @@ -79,28 +79,43 @@ package body Bindgen is Table_Increment => 200, Table_Name => "IS_Pragma_Settings"); + -- This table assembles the Priority_Specific_Dispatching pragma + -- information from all the units in the partition. Note that Bcheck has + -- already checked that the information is consistent across partitions. + -- The entries in this table are the upper case first character of the + -- policy name, e.g. 'F' for FIFO_Within_Priorities. + + package PSD_Pragma_Settings is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "PSD_Pragma_Settings"); + ---------------------- -- Run-Time Globals -- ---------------------- - -- This section documents the global variables that are passed to the - -- run time from the generated binder file. The call that is made is - -- to the routine Set_Globals, which has the following spec: - - -- procedure Set_Globals - -- (Main_Priority : Integer; - -- Time_Slice_Value : Integer; - -- WC_Encoding : Character; - -- Locking_Policy : Character; - -- Queuing_Policy : Character; - -- Task_Dispatching_Policy : Character; - -- Restrictions : System.Address; - -- Interrupt_States : System.Address; - -- Num_Interrupt_States : Integer; - -- Unreserve_All_Interrupts : Integer; - -- Exception_Tracebacks : Integer; - -- Zero_Cost_Exceptions : Integer; - -- Detect_Blocking : Integer); + -- This section documents the global variables that set from the + -- generated binder file. + + -- Main_Priority : Integer; + -- Time_Slice_Value : Integer; + -- WC_Encoding : Character; + -- Locking_Policy : Character; + -- Queuing_Policy : Character; + -- Task_Dispatching_Policy : Character; + -- Priority_Specific_Dispatching : System.Address; + -- Num_Specific_Dispatching : Integer; + -- Restrictions : System.Address; + -- Interrupt_States : System.Address; + -- Num_Interrupt_States : Integer; + -- Unreserve_All_Interrupts : Integer; + -- Exception_Tracebacks : Integer; + -- Zero_Cost_Exceptions : Integer; + -- Detect_Blocking : Integer; + -- Default_Stack_Size : Integer; -- Main_Priority is the priority value set by pragma Priority in the -- main program. If no such pragma is present, the value is -1. @@ -131,6 +146,20 @@ package body Bindgen is -- was specified, the value is the upper case first character of -- the policy name, e.g. 'F' for FIFO_Within_Priorities. + -- Priority_Specific_Dispatching is the address of a string used to + -- store the task dispatching policy specified for the different priorities + -- in the partition. The length of this string is determined by the last + -- priority for which such a pragma applies (the string will be a null + -- string if no specific dispatching policies were used). If pragma were + -- present, the entries apply to the priorities in sequence from the first + -- priority. The value stored is the upper case first character of the + -- policy name, or 'F' (for FIFO_Within_Priorities) as the default value + -- for those priority ranges not specified. + + -- Num_Specific_Dispatching is the length of the + -- Priority_Specific_Dispatching string. It will be set to zero if no + -- Priority_Specific_Dispatching pragmas are present. + -- Restrictions is the address of a null-terminated string specifying the -- restrictions information for the partition. The format is identical to -- that of the parameter string found on R lines in ali files (see Lib.Writ @@ -167,6 +196,9 @@ package body Bindgen is -- present, while a value of 1 signals its presence in the -- partition. + -- Default_Stack_Size is the default stack size used when creating an + -- Ada task with no explicit Storize_Size clause. + ----------------------- -- Local Subprograms -- ----------------------- @@ -218,15 +250,11 @@ package body Bindgen is procedure Gen_Output_File_C (Filename : String); -- Generate output file (C code case) - procedure Gen_Restrictions_String_1; - -- Generate first restrictions string, which consists of the parameters - -- the first R line, as described in lib-writ.ads, with the restrictions - -- being those for the entire partition (from Cumulative_Restrictions). - - procedure Gen_Restrictions_String_2; - -- Generate first restrictions string, which consists of the parameters - -- the second R line, as described in lib-writ.ads, with the restrictions - -- being those for the entire partition (from Cumulative_Restrictions). + procedure Gen_Restrictions_Ada; + -- Generate initialization of restrictions variable (Ada code case) + + procedure Gen_Restrictions_C; + -- Generate initialization of restrictions variable (C code case) procedure Gen_Versions_Ada; -- Output series of definitions for unit versions (Ada code case) @@ -256,10 +284,6 @@ package body Bindgen is procedure Move_Linker_Option (From : Natural; To : Natural); -- Move routine for sorting linker options - procedure Public_Version_Warning; - -- Emit a warning concerning the use of the Public version under - -- certain circumstances. See details in body. - procedure Resolve_Binder_Options; -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS -- since it tests for a package named "dec" which might cause a conflict @@ -274,6 +298,10 @@ package body Bindgen is -- starting at the Last + 1 position, and updating Last past the value. -- A minus sign is output for a negative value. + procedure Set_Boolean (B : Boolean); + -- Set given boolean value in Statement_Buffer at the Last + 1 position + -- and update Last past the value. + procedure Set_IS_Pragma_Table; -- Initializes contents of IS_Pragma_Settings table from ALI table @@ -285,6 +313,9 @@ package body Bindgen is procedure Set_Name_Buffer; -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer + procedure Set_PSD_Pragma_Table; + -- Initializes contents of PSD_Pragma_Settings table from ALI table + procedure Set_String (S : String); -- Sets characters of given string in Statement_Buffer, starting at the -- Last + 1 position, and updating last past the string value. @@ -299,10 +330,6 @@ package body Bindgen is -- up all output unit numbers nicely as required by the value, and -- by the total number of units. - procedure Tab_To (N : Natural); - -- If Last is greater than or equal to N, no effect, otherwise store - -- blanks in Statement_Buffer bumping Last, until Last = N. - procedure Write_Info_Ada_C (Ada : String; C : String; Common : String); -- For C code case, write C & Common, for Ada case write Ada & Common -- to current binder output file using Write_Binder_Info. @@ -432,7 +459,7 @@ package body Bindgen is -- If the standard library is suppressed, then the only global variable -- that might be needed (by the Ravenscar profile) is the priority of - -- the environment. Also no exception tables are needed. + -- the environment. if Suppress_Standard_Library_On_Target then if Main_Priority /= No_Main_Priority then @@ -454,78 +481,59 @@ package body Bindgen is WBI (" null;"); end if; - -- Normal case (standard library not suppressed). Global values are - -- assigned using the runtime routine Set_Globals (we have to use - -- the routine call, rather than define the globals in the binder - -- file to deal with cross-library calls in some systems. + -- Normal case (standard library not suppressed). Set all global values + -- used by the run time. else - -- Generate restrictions string - - Set_String (" Restrictions : constant String :="); - Write_Statement_Buffer; - - Set_String (" """); - Gen_Restrictions_String_1; - Set_String (""" &"); - Write_Statement_Buffer; - - Set_String (" """); - Gen_Restrictions_String_2; - Set_String (""" & ASCII.Nul;"); - Write_Statement_Buffer; - WBI (""); - - -- Generate Interrupt_State pragma string - - Set_String (" Interrupt_States : constant String :="); - Write_Statement_Buffer; - - declare - Col : Natural; - - begin - Set_String (" """); - Col := 9; + WBI (" Main_Priority : Integer;"); + WBI (" pragma Import (C, Main_Priority, " & + """__gl_main_priority"");"); + WBI (" Time_Slice_Value : Integer;"); + WBI (" pragma Import (C, Time_Slice_Value, " & + """__gl_time_slice_val"");"); + WBI (" WC_Encoding : Character;"); + WBI (" pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");"); + WBI (" Locking_Policy : Character;"); + WBI (" pragma Import (C, Locking_Policy, " & + """__gl_locking_policy"");"); + WBI (" Queuing_Policy : Character;"); + WBI (" pragma Import (C, Queuing_Policy, " & + """__gl_queuing_policy"");"); + WBI (" Task_Dispatching_Policy : Character;"); + WBI (" pragma Import (C, Task_Dispatching_Policy, " & + """__gl_task_dispatching_policy"");"); + WBI (" Priority_Specific_Dispatching : System.Address;"); + WBI (" pragma Import (C, Priority_Specific_Dispatching, " & + """__gl_priority_specific_dispatching"");"); + WBI (" Num_Specific_Dispatching : Integer;"); + WBI (" pragma Import (C, Num_Specific_Dispatching, " & + """__gl_num_specific_dispatching"");"); + + WBI (" Interrupt_States : System.Address;"); + WBI (" pragma Import (C, Interrupt_States, " & + """__gl_interrupt_states"");"); + WBI (" Num_Interrupt_States : Integer;"); + WBI (" pragma Import (C, Num_Interrupt_States, " & + """__gl_num_interrupt_states"");"); + WBI (" Unreserve_All_Interrupts : Integer;"); + WBI (" pragma Import (C, Unreserve_All_Interrupts, " & + """__gl_unreserve_all_interrupts"");"); - for J in 0 .. IS_Pragma_Settings.Last loop - if Col > 72 then - Set_String (""" &"); - Write_Statement_Buffer; - Set_String (" """); - Col := 9; - - else - Col := Col + 1; - end if; - - Set_Char (IS_Pragma_Settings.Table (J)); - end loop; - end; - - Set_String (""";"); - Write_Statement_Buffer; - WBI (""); - - -- Generate spec for Set_Globals procedure + if Exception_Tracebacks then + WBI (" Exception_Tracebacks : Integer;"); + WBI (" pragma Import (C, Exception_Tracebacks, " & + """__gl_exception_tracebacks"");"); + end if; - WBI (" procedure Set_Globals"); - WBI (" (Main_Priority : Integer;"); - WBI (" Time_Slice_Value : Integer;"); - WBI (" WC_Encoding : Character;"); - WBI (" Locking_Policy : Character;"); - WBI (" Queuing_Policy : Character;"); - WBI (" Task_Dispatching_Policy : Character;"); - - WBI (" Restrictions : System.Address;"); - WBI (" Interrupt_States : System.Address;"); - WBI (" Num_Interrupt_States : Integer;"); - WBI (" Unreserve_All_Interrupts : Integer;"); - WBI (" Exception_Tracebacks : Integer;"); - WBI (" Zero_Cost_Exceptions : Integer;"); - WBI (" Detect_Blocking : Integer;"); - WBI (" Default_Stack_Size : Integer);"); - WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");"); + WBI (" Zero_Cost_Exceptions : Integer;"); + WBI (" pragma Import (C, Zero_Cost_Exceptions, " & + """__gl_zero_cost_exceptions"");"); + WBI (" Detect_Blocking : Integer;"); + WBI (" pragma Import (C, Detect_Blocking, " & + """__gl_detect_blocking"");"); + WBI (" Default_Stack_Size : Integer;"); + WBI (" pragma Import (C, Default_Stack_Size, " & + """__gl_default_stack_size"");"); -- Import entry point for elaboration time signal handler -- installation, and indication of if it's been called previously. @@ -540,16 +548,12 @@ package body Bindgen is """__gnat_handler_installed"");"); WBI (" begin"); - -- Generate the call to Set_Globals - - WBI (" Set_Globals"); - - Set_String (" (Main_Priority => "); + Set_String (" Main_Priority := "); Set_Int (Main_Priority); - Set_Char (','); + Set_Char (';'); Write_Statement_Buffer; - Set_String (" Time_Slice_Value => "); + Set_String (" Time_Slice_Value := "); if Task_Dispatching_Policy_Specified = 'F' and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 @@ -559,40 +563,47 @@ package body Bindgen is Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); end if; - Set_Char (','); + Set_Char (';'); Write_Statement_Buffer; - Set_String (" WC_Encoding => '"); + Set_String (" WC_Encoding := '"); Set_Char (ALIs.Table (ALIs.First).WC_Encoding); - Set_String ("',"); + Set_String ("';"); Write_Statement_Buffer; - Set_String (" Locking_Policy => '"); + Set_String (" Locking_Policy := '"); Set_Char (Locking_Policy_Specified); - Set_String ("',"); + Set_String ("';"); Write_Statement_Buffer; - Set_String (" Queuing_Policy => '"); + Set_String (" Queuing_Policy := '"); Set_Char (Queuing_Policy_Specified); - Set_String ("',"); + Set_String ("';"); Write_Statement_Buffer; - Set_String (" Task_Dispatching_Policy => '"); + Set_String (" Task_Dispatching_Policy := '"); Set_Char (Task_Dispatching_Policy_Specified); - Set_String ("',"); + Set_String ("';"); Write_Statement_Buffer; - WBI (" Restrictions => Restrictions'Address,"); + Gen_Restrictions_Ada; + + WBI (" Priority_Specific_Dispatching :="); + WBI (" Local_Priority_Specific_Dispatching'Address;"); + + Set_String (" Num_Specific_Dispatching := "); + Set_Int (PSD_Pragma_Settings.Last + 1); + Set_Char (';'); + Write_Statement_Buffer; - WBI (" Interrupt_States => " & - "Interrupt_States'Address,"); + WBI (" Interrupt_States := Local_Interrupt_States'Address;"); - Set_String (" Num_Interrupt_States => "); + Set_String (" Num_Interrupt_States := "); Set_Int (IS_Pragma_Settings.Last + 1); - Set_Char (','); + Set_Char (';'); Write_Statement_Buffer; - Set_String (" Unreserve_All_Interrupts => "); + Set_String (" Unreserve_All_Interrupts := "); if Unreserve_All_Interrupts_Specified then Set_String ("1"); @@ -600,21 +611,14 @@ package body Bindgen is Set_String ("0"); end if; - Set_Char (','); + Set_Char (';'); Write_Statement_Buffer; - Set_String (" Exception_Tracebacks => "); - if Exception_Tracebacks then - Set_String ("1"); - else - Set_String ("0"); + WBI (" Exception_Tracebacks := 1;"); end if; - Set_String (","); - Write_Statement_Buffer; - - Set_String (" Zero_Cost_Exceptions => "); + Set_String (" Zero_Cost_Exceptions := "); if Zero_Cost_Exceptions_Specified then Set_String ("1"); @@ -622,10 +626,10 @@ package body Bindgen is Set_String ("0"); end if; - Set_String (","); + Set_String (";"); Write_Statement_Buffer; - Set_String (" Detect_Blocking => "); + Set_String (" Detect_Blocking := "); if Detect_Blocking then Set_Int (1); @@ -633,13 +637,12 @@ package body Bindgen is Set_Int (0); end if; - Set_String (","); + Set_String (";"); Write_Statement_Buffer; - Set_String (" Default_Stack_Size => "); + Set_String (" Default_Stack_Size := "); Set_Int (Default_Stack_Size); - - Set_String (");"); + Set_String (";"); Write_Statement_Buffer; -- Generate call to Install_Handler @@ -734,7 +737,8 @@ package body Bindgen is -- for the Ravenscar profile. if Main_Priority /= No_Main_Priority then - Set_String (" extern int __gl_main_priority = "); + WBI (" extern int __gl_main_priority;"); + Set_String (" __gl_main_priority = "); Set_Int (Main_Priority); Set_Char (';'); Write_Statement_Buffer; @@ -743,20 +747,24 @@ package body Bindgen is -- Normal case (standard library not suppressed) else - -- Generate definition for restrictions string + -- Generate definition for interrupt states string + + Set_String (" static const char *local_interrupt_states = """); + + for J in 0 .. IS_Pragma_Settings.Last loop + Set_Char (IS_Pragma_Settings.Table (J)); + end loop; - Set_String (" const char *restrictions = """); - Gen_Restrictions_String_1; - Gen_Restrictions_String_2; Set_String (""";"); Write_Statement_Buffer; - -- Generate definition for interrupt states string + -- Generate definition for priority specific dispatching string - Set_String (" const char *interrupt_states = """); + Set_String + (" static const char *local_priority_specific_dispatching = """); - for J in 0 .. IS_Pragma_Settings.Last loop - Set_Char (IS_Pragma_Settings.Table (J)); + for J in 0 .. PSD_Pragma_Settings.Last loop + Set_Char (PSD_Pragma_Settings.Table (J)); end loop; Set_String (""";"); @@ -773,24 +781,17 @@ package body Bindgen is -- Code for normal case (standard library not suppressed) - -- Generate call to set the runtime global variables defined in - -- init.c. We define the varables in init.c, rather than in - -- the binder generated file itself to avoid undefined externals - -- when the runtime is linked as a shareable image library. - -- We call the routine from inside adainit() because this works for -- both programs with and without binder generated "main" functions. - WBI (" __gnat_set_globals ("); - - Set_String (" "); + WBI (" extern int __gl_main_priority;"); + Set_String (" __gl_main_priority = "); Set_Int (Main_Priority); - Set_Char (','); - Tab_To (24); - Set_String ("/* Main_Priority */"); + Set_Char (';'); Write_Statement_Buffer; - Set_String (" "); + WBI (" extern int __gl_time_slice_val;"); + Set_String (" __gl_time_slice_val = "); if Task_Dispatching_Policy = 'F' and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 @@ -800,82 +801,75 @@ package body Bindgen is Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); end if; - Set_Char (','); - Tab_To (24); - Set_String ("/* Time_Slice_Value */"); + Set_Char (';'); Write_Statement_Buffer; - Set_String (" '"); + WBI (" extern char __gl_wc_encoding;"); + Set_String (" __gl_wc_encoding = '"); Set_Char (ALIs.Table (ALIs.First).WC_Encoding); - Set_String ("',"); - Tab_To (24); - Set_String ("/* WC_Encoding */"); + Set_String ("';"); Write_Statement_Buffer; - Set_String (" '"); + WBI (" extern char __gl_locking_policy;"); + Set_String (" __gl_locking_policy = '"); Set_Char (Locking_Policy_Specified); - Set_String ("',"); - Tab_To (24); - Set_String ("/* Locking_Policy */"); + Set_String ("';"); Write_Statement_Buffer; - Set_String (" '"); + WBI (" extern char __gl_queuing_policy;"); + Set_String (" __gl_queuing_policy = '"); Set_Char (Queuing_Policy_Specified); - Set_String ("',"); - Tab_To (24); - Set_String ("/* Queuing_Policy */"); + Set_String ("';"); Write_Statement_Buffer; - Set_String (" '"); + WBI (" extern char __gl_task_dispatching_policy;"); + Set_String (" __gl_task_dispatching_policy = '"); Set_Char (Task_Dispatching_Policy_Specified); - Set_String ("',"); - Tab_To (24); - Set_String ("/* Tasking_Dispatching_Policy */"); + Set_String ("';"); Write_Statement_Buffer; - Set_String (" "); - Set_String ("restrictions"); - Set_String (","); - Tab_To (24); - Set_String ("/* Restrictions */"); - Write_Statement_Buffer; + -- Generate definition for restrictions string - Set_String (" "); - Set_String ("interrupt_states"); - Set_String (","); - Tab_To (24); - Set_String ("/* Interrupt_States */"); - Write_Statement_Buffer; + Gen_Restrictions_C; + + WBI (" extern const void *__gl_interrupt_states;"); + WBI (" __gl_interrupt_states = local_interrupt_states;"); - Set_String (" "); + WBI (" extern int __gl_num_interrupt_states;"); + Set_String (" __gl_num_interrupt_states = "); Set_Int (IS_Pragma_Settings.Last + 1); - Set_String (","); - Tab_To (24); - Set_String ("/* Num_Interrupt_States */"); + Set_String (";"); Write_Statement_Buffer; - Set_String (" "); - Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); - Set_String (","); - Tab_To (24); - Set_String ("/* Unreserve_All_Interrupts */"); + WBI (" extern const void *__gl_priority_specific_dispatching;"); + WBI (" __gl_priority_specific_dispatching =" & + " local_priority_specific_dispatching;"); + + WBI (" extern int __gl_num_specific_dispatching;"); + Set_String (" __gl_num_specific_dispatching = "); + Set_Int (PSD_Pragma_Settings.Last + 1); + Set_String (";"); Write_Statement_Buffer; - Set_String (" "); - Set_Int (Boolean'Pos (Exception_Tracebacks)); - Set_String (","); - Tab_To (24); - Set_String ("/* Exception_Tracebacks */"); + WBI (" extern int __gl_unreserve_all_interrupts;"); + Set_String (" __gl_unreserve_all_interrupts = "); + Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); + Set_String (";"); Write_Statement_Buffer; - Set_String (" "); + if Exception_Tracebacks then + WBI (" extern int __gl_exception_tracebacks;"); + WBI (" __gl_exception_tracebacks = 1;"); + end if; + + WBI (" extern int __gl_zero_cost_exceptions;"); + Set_String (" __gl_zero_cost_exceptions = "); Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified)); - Set_String (","); - Tab_To (24); - Set_String ("/* Zero_Cost_Exceptions */"); + Set_String (";"); Write_Statement_Buffer; - Set_String (" "); + WBI (" extern int __gl_detect_blocking;"); + Set_String (" __gl_detect_blocking = "); if Detect_Blocking then Set_Int (1); @@ -883,16 +877,13 @@ package body Bindgen is Set_Int (0); end if; - Set_String (","); - Tab_To (24); - Set_String ("/* Detect_Blocking */"); + Set_String (";"); Write_Statement_Buffer; - Set_String (" "); + WBI (" extern int __gl_default_stack_size;"); + Set_String (" __gl_default_stack_size = "); Set_Int (Default_Stack_Size); - Set_String (");"); - Tab_To (24); - Set_String ("/* Default_Stack_Size */"); + Set_String (";"); Write_Statement_Buffer; WBI (""); @@ -1836,7 +1827,12 @@ package body Bindgen is -- files. The reason for this decision is that libraries referenced -- by internal routines may reference these standard library entries. - if not Opt.No_Stdlib then + -- Note that we do not insert anything when pragma No_Run_Time has been + -- specified or when the standard libraries are not to be used, + -- otherwise on some platforms, such as VMS, we may get duplicate + -- symbols when linking. + + if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then Name_Len := 0; if Opt.Shared_Libgnat then @@ -1903,14 +1899,15 @@ package body Bindgen is --------------------- procedure Gen_Output_File (Filename : String) is - Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public; - Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP; - begin -- Acquire settings for Interrupt_State pragmas Set_IS_Pragma_Table; + -- Acquire settings for Priority_Specific_Dispatching pragma + + Set_PSD_Pragma_Table; + -- Override Ada_Bind_File and Bind_Main_Program for Java since -- JGNAT only supports Ada code, and the main program is already -- generated by the compiler. @@ -1936,12 +1933,6 @@ package body Bindgen is end if; end loop; - -- Get the time stamp of the former bind for public version warning - - if Is_Public_Version or Is_GAP_Version then - Record_Time_From_Last_Bind; - end if; - -- Generate output file in appropriate language if Ada_Bind_File then @@ -1950,12 +1941,6 @@ package body Bindgen is Gen_Output_File_C (Filename); end if; - -- Periodically issue a warning when the public version is used on - -- big projects - - if Is_Public_Version then - Public_Version_Warning; - end if; end Gen_Output_File; ------------------------- @@ -2006,7 +1991,6 @@ package body Bindgen is Resolve_Binder_Options; if not Suppress_Standard_Library_On_Target then - -- Usually, adafinal is called using a pragma Import C. Since -- Import C doesn't have the same semantics for JGNAT, we use -- standard Ada. @@ -2192,6 +2176,14 @@ package body Bindgen is ", Body_File_Name => """ & Name_Buffer (1 .. Name_Len + 3)); + -- Generate with of System.Restrictions to initialize + -- Run_Time_Restrictions. + + if not Suppress_Standard_Library_On_Target then + WBI (""); + WBI ("with System.Restrictions;"); + end if; + WBI (""); WBI ("package body " & Ada_Main & " is"); WBI (" pragma Warnings (Off);"); @@ -2213,6 +2205,33 @@ package body Bindgen is end if; end if; + if not Suppress_Standard_Library_On_Target then + + -- Generate Priority_Specific_Dispatching pragma string + + Set_String + (" Local_Priority_Specific_Dispatching : constant String := """); + + for J in 0 .. PSD_Pragma_Settings.Last loop + Set_Char (PSD_Pragma_Settings.Table (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + + -- Generate Interrupt_State pragma string + + Set_String (" Local_Interrupt_States : constant String := """); + + for J in 0 .. IS_Pragma_Settings.Last loop + Set_Char (IS_Pragma_Settings.Table (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + WBI (""); + end if; + Gen_Adainit_Ada; Gen_Adafinal_Ada; @@ -2257,11 +2276,6 @@ package body Bindgen is Resolve_Binder_Options; - WBI ("extern void __gnat_set_globals"); - WBI (" (int, int, char, char, char, char,"); - WBI (" const char *, const char *,"); - WBI (" int, int, int, int, int, int);"); - if Use_Pragma_Linker_Constructor then WBI ("extern void " & Ada_Final_Name.all & " (void) __attribute__((destructor));"); @@ -2438,51 +2452,211 @@ package body Bindgen is Close_Binder_Output; end Gen_Output_File_C; - ------------------------------- - -- Gen_Restrictions_String_1 -- - ------------------------------- + -------------------------- + -- Gen_Restrictions_Ada -- + -------------------------- - procedure Gen_Restrictions_String_1 is + procedure Gen_Restrictions_Ada is + Count : Integer; begin - for R in All_Boolean_Restrictions loop - if Cumulative_Restrictions.Set (R) then - Set_Char ('r'); - elsif Cumulative_Restrictions.Violated (R) then - Set_Char ('v'); - else - Set_Char ('n'); + if Suppress_Standard_Library_On_Target then + return; + end if; + + WBI (" System.Restrictions.Run_Time_Restrictions :="); + WBI (" (Set =>"); + Set_String (" ("); + + Count := 0; + + for J in Cumulative_Restrictions.Set'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Set'Last) + loop + Set_Boolean (Cumulative_Restrictions.Set (J)); + Set_String (", "); + Count := Count + 1; + + if Count = 8 then + Write_Statement_Buffer; + Set_String (" "); + Count := 0; end if; end loop; - end Gen_Restrictions_String_1; - ------------------------------- - -- Gen_Restrictions_String_2 -- - ------------------------------- + Set_Boolean + (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last)); + Set_String ("),"); + Write_Statement_Buffer; + Set_String (" Value => ("); + + for J in Cumulative_Restrictions.Value'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Value'Last) + loop + Set_Int (Int (Cumulative_Restrictions.Value (J))); + Set_String (", "); + end loop; + + Set_Int (Int (Cumulative_Restrictions.Value + (Cumulative_Restrictions.Value'Last))); + Set_String ("),"); + Write_Statement_Buffer; + WBI (" Violated =>"); + Set_String (" ("); + Count := 0; + + for J in Cumulative_Restrictions.Violated'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last) + loop + Set_Boolean (Cumulative_Restrictions.Violated (J)); + Set_String (", "); + Count := Count + 1; - procedure Gen_Restrictions_String_2 is - begin - for RP in All_Parameter_Restrictions loop - if Cumulative_Restrictions.Set (RP) then - Set_Char ('r'); - Set_Int (Int (Cumulative_Restrictions.Value (RP))); - else - Set_Char ('n'); + if Count = 8 then + Write_Statement_Buffer; + Set_String (" "); + Count := 0; end if; + end loop; - if not Cumulative_Restrictions.Violated (RP) - or else RP not in Checked_Parameter_Restrictions - then - Set_Char ('n'); - else - Set_Char ('v'); - Set_Int (Int (Cumulative_Restrictions.Count (RP))); + Set_Boolean (Cumulative_Restrictions.Violated + (Cumulative_Restrictions.Violated'Last)); + Set_String ("),"); + Write_Statement_Buffer; + Set_String (" Count => ("); - if Cumulative_Restrictions.Unknown (RP) then - Set_Char ('+'); - end if; - end if; + for J in Cumulative_Restrictions.Count'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Count'Last) + loop + Set_Int (Int (Cumulative_Restrictions.Count (J))); + Set_String (", "); + end loop; + + Set_Int (Int (Cumulative_Restrictions.Count + (Cumulative_Restrictions.Count'Last))); + Set_String ("),"); + Write_Statement_Buffer; + Set_String (" Unknown => ("); + + for J in Cumulative_Restrictions.Unknown'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last) + loop + Set_Boolean (Cumulative_Restrictions.Unknown (J)); + Set_String (", "); + end loop; + + Set_Boolean + (Cumulative_Restrictions.Unknown + (Cumulative_Restrictions.Unknown'Last)); + Set_String ("));"); + Write_Statement_Buffer; + end Gen_Restrictions_Ada; + + ------------------------ + -- Gen_Restrictions_C -- + ------------------------ + + procedure Gen_Restrictions_C is + begin + if Suppress_Standard_Library_On_Target then + return; + end if; + + WBI (" typedef struct {"); + Set_String (" char set ["); + Set_Int (Cumulative_Restrictions.Set'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" int value ["); + Set_Int (Cumulative_Restrictions.Value'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" char violated ["); + Set_Int (Cumulative_Restrictions.Violated'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" int count ["); + Set_Int (Cumulative_Restrictions.Count'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" char unknown ["); + Set_Int (Cumulative_Restrictions.Unknown'Length); + Set_String ("];"); + Write_Statement_Buffer; + WBI (" } restrictions;"); + WBI (" extern restrictions " & + "system__restrictions__run_time_restrictions;"); + WBI (" restrictions r = {"); + Set_String (" {"); + + for J in Cumulative_Restrictions.Set'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Set'Last) + loop + Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J))); + Set_String (", "); + end loop; + + Set_Int (Boolean'Pos + (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last))); + Set_String ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Value'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Value'Last) + loop + Set_Int (Int (Cumulative_Restrictions.Value (J))); + Set_String (", "); + end loop; + + Set_Int (Int (Cumulative_Restrictions.Value + (Cumulative_Restrictions.Value'Last))); + Set_String ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Violated'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last) + loop + Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J))); + Set_String (", "); end loop; - end Gen_Restrictions_String_2; + + Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated + (Cumulative_Restrictions.Violated'Last))); + Set_String ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Count'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Count'Last) + loop + Set_Int (Int (Cumulative_Restrictions.Count (J))); + Set_String (", "); + end loop; + + Set_Int (Int (Cumulative_Restrictions.Count + (Cumulative_Restrictions.Count'Last))); + Set_String ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Unknown'First .. + Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last) + loop + Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J))); + Set_String (", "); + end loop; + + Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown + (Cumulative_Restrictions.Unknown'Last))); + Set_String ("}};"); + Write_Statement_Buffer; + WBI (" system__restrictions__run_time_restrictions = r;"); + end Gen_Restrictions_C; ---------------------- -- Gen_Versions_Ada -- @@ -2773,78 +2947,6 @@ package body Bindgen is end Move_Linker_Option; ---------------------------- - -- Public_Version_Warning -- - ---------------------------- - - procedure Public_Version_Warning is - Time : constant Int := Time_From_Last_Bind; - - -- Constants to help defining periods - - Hour : constant := 60; - Day : constant := 24 * Hour; - - Never : constant := Integer'Last; - -- Special value indicating no warnings should be given - - -- Constants defining when the warning is issued. Programs with more - -- than Large Units will issue a warning every Period_Large amount of - -- time. Smaller programs will generate a warning every Period_Small - -- amount of time. - - Large : constant := 20; - -- Threshold for considering a program small or large - - Period_Large : constant := Day; - -- Periodic warning time for large programs - - Period_Small : constant := Never; - -- Periodic warning time for small programs - - Nb_Unit : Int; - - begin - -- Compute the number of units that are not GNAT internal files - - Nb_Unit := 0; - for A in ALIs.First .. ALIs.Last loop - if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then - Nb_Unit := Nb_Unit + 1; - end if; - end loop; - - -- Do not emit the message if the last message was emitted in the - -- specified period taking into account the number of units. - - pragma Warnings (Off); - -- Turn off warning of constant condition, which may happen here - -- depending on the choice of constants in the above declarations. - - if Nb_Unit < Large and then Time <= Period_Small then - return; - elsif Time <= Period_Large then - return; - end if; - - pragma Warnings (On); - - Write_Eol; - Write_Str ("IMPORTANT NOTICE:"); - Write_Eol; - Write_Str (" This version of GNAT is unsupported" - & " and comes with absolutely no warranty."); - Write_Eol; - Write_Str (" If you intend to evaluate or use GNAT for building " - & "commercial applications,"); - Write_Eol; - Write_Str (" please consult http://www.gnat.com/ for information"); - Write_Eol; - Write_Str (" on the GNAT Professional product line."); - Write_Eol; - Write_Eol; - end Public_Version_Warning; - - ---------------------------- -- Resolve_Binder_Options -- ---------------------------- @@ -2867,6 +2969,23 @@ package body Bindgen is end loop; end Resolve_Binder_Options; + ----------------- + -- Set_Boolean -- + ----------------- + + procedure Set_Boolean (B : Boolean) is + True_Str : constant String := "True"; + False_Str : constant String := "False"; + begin + if B then + Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str; + Last := Last + True_Str'Length; + else + Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str; + Last := Last + False_Str'Length; + end if; + end Set_Boolean; + -------------- -- Set_Char -- -------------- @@ -2960,6 +3079,33 @@ package body Bindgen is end loop; end Set_Name_Buffer; + ------------------------- + -- Set_PSD_Pragma_Table -- + ------------------------- + + procedure Set_PSD_Pragma_Table is + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Specific_Dispatching .. + ALIs.Table (F).Last_Specific_Dispatching + loop + declare + DTK : Specific_Dispatching_Record + renames Specific_Dispatching.Table (K); + + begin + while PSD_Pragma_Settings.Last < DTK.Last_Priority loop + PSD_Pragma_Settings.Append ('F'); + end loop; + + for Prio in DTK.First_Priority .. DTK.Last_Priority loop + PSD_Pragma_Settings.Table (Prio) := DTK.Dispatching_Policy; + end loop; + end; + end loop; + end loop; + end Set_PSD_Pragma_Table; + ---------------- -- Set_String -- ---------------- @@ -3005,17 +3151,6 @@ package body Bindgen is Set_Int (Unum); end Set_Unit_Number; - ------------ - -- Tab_To -- - ------------ - - procedure Tab_To (N : Natural) is - begin - while Last < N loop - Set_Char (' '); - end loop; - end Tab_To; - ---------------------- -- Write_Info_Ada_C -- ---------------------- Index: init.c =================================================================== --- init.c (revision 118179) +++ init.c (working copy) @@ -66,43 +66,41 @@ extern void __gnat_raise_program_error (const char *, int); -/* Addresses of exception data blocks for predefined exceptions. */ +/* Addresses of exception data blocks for predefined exceptions. Tasking_Error + is not used in this unit, and the abort signal is only used on IRIX. */ extern struct Exception_Data constraint_error; extern struct Exception_Data numeric_error; extern struct Exception_Data program_error; extern struct Exception_Data storage_error; -extern struct Exception_Data tasking_error; -extern struct Exception_Data _abort_signal; - -#define Lock_Task system__soft_links__lock_task -extern void (*Lock_Task) (void); - -#define Unlock_Task system__soft_links__unlock_task -extern void (*Unlock_Task) (void); - -#define Check_Abort_Status \ - system__soft_links__check_abort_status -extern int (*Check_Abort_Status) (void); +/* For the Cert run time we use the regular raise exception routine because + Raise_From_Signal_Handler is not available. */ +#ifdef CERT +#define Raise_From_Signal_Handler \ + __gnat_raise_exception +extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); +#else #define Raise_From_Signal_Handler \ ada__exceptions__raise_from_signal_handler extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); +#endif -/* Copies of global values computed by the binder */ -int __gl_main_priority = -1; -int __gl_time_slice_val = -1; -char __gl_wc_encoding = 'n'; -char __gl_locking_policy = ' '; -char __gl_queuing_policy = ' '; -char __gl_task_dispatching_policy = ' '; -char *__gl_restrictions = 0; -char *__gl_interrupt_states = 0; -int __gl_num_interrupt_states = 0; -int __gl_unreserve_all_interrupts = 0; -int __gl_exception_tracebacks = 0; -int __gl_zero_cost_exceptions = 0; -int __gl_detect_blocking = 0; -int __gl_default_stack_size = -1; +/* Global values computed by the binder */ +int __gl_main_priority = -1; +int __gl_time_slice_val = -1; +char __gl_wc_encoding = 'n'; +char __gl_locking_policy = ' '; +char __gl_queuing_policy = ' '; +char __gl_task_dispatching_policy = ' '; +char *__gl_priority_specific_dispatching = 0; +int __gl_num_specific_dispatching = 0; +char *__gl_interrupt_states = 0; +int __gl_num_interrupt_states = 0; +int __gl_unreserve_all_interrupts = 0; +int __gl_exception_tracebacks = 0; +int __gl_zero_cost_exceptions = 0; +int __gl_detect_blocking = 0; +int __gl_default_stack_size = -1; /* Indication of whether synchronous signal handler has already been installed by a previous call to adainit */ @@ -144,119 +142,46 @@ __gnat_get_interrupt_state (int intrup) return __gl_interrupt_states [intrup]; } -/**********************/ -/* __gnat_set_globals */ -/**********************/ +/***********************************/ +/* __gnat_get_specific_dispatching */ +/***********************************/ -/* This routine is called from the binder generated main program. It copies - the values for global quantities computed by the binder into the following - global locations. The reason that we go through this copy, rather than just - define the global locations in the binder generated file, is that they are - referenced from the runtime, which may be in a shared library, and the - binder file is not in the shared library. Global references across library - boundaries like this are not handled correctly in all systems. */ - -/* For detailed description of the parameters to this routine, see the - section titled Run-Time Globals in package Bindgen (bindgen.adb) */ - -void -__gnat_set_globals (int main_priority, - int time_slice_val, - char wc_encoding, - char locking_policy, - char queuing_policy, - char task_dispatching_policy, - char *restrictions, - char *interrupt_states, - int num_interrupt_states, - int unreserve_all_interrupts, - int exception_tracebacks, - int zero_cost_exceptions, - int detect_blocking, - int default_stack_size) -{ - static int already_called = 0; - - /* If this procedure has been already called once, check that the - arguments in this call are consistent with the ones in the previous - calls. Otherwise, raise a Program_Error exception. - - We do not check for consistency of the wide character encoding - method. This default affects only Wide_Text_IO where no explicit - coding method is given, and there is no particular reason to let - this default be affected by the source representation of a library - in any case. - - We do not check either for the consistency of exception tracebacks, - because exception tracebacks are not normally set in Stand-Alone - libraries. If a library or the main program set the exception - tracebacks, then they are never reset afterwards (see below). - - The value of main_priority is meaningful only when we are invoked - from the main program elaboration routine of an Ada application. - Checking the consistency of this parameter should therefore not be - done. Since it is assured that the main program elaboration will - always invoke this procedure before any library elaboration - routine, only the value of main_priority during the first call - should be taken into account and all the subsequent ones should be - ignored. Note that the case where the main program is not written - in Ada is also properly handled, since the default value will then - be used for this parameter. +char __gnat_get_specific_dispatching (int); - For identical reasons, the consistency of time_slice_val should not - be checked. */ +/* This routine is called from the run time as needed to determine 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, e.g. 'F' for + FIFO_Within_Priorities. A space ' ' is returned if no + Priority_Specific_Dispatching pragma is used in the partition. */ - if (already_called) - { - if (__gl_locking_policy != locking_policy - || __gl_queuing_policy != queuing_policy - || __gl_task_dispatching_policy != task_dispatching_policy - || __gl_unreserve_all_interrupts != unreserve_all_interrupts - || __gl_zero_cost_exceptions != zero_cost_exceptions - || __gl_default_stack_size != default_stack_size) - __gnat_raise_program_error (__FILE__, __LINE__); - - /* If either a library or the main program set the exception traceback - flag, it is never reset later */ +char +__gnat_get_specific_dispatching (int priority) +{ + if (__gl_num_specific_dispatching == 0) + return ' '; + else if (priority >= __gl_num_specific_dispatching) + return 'F'; + else + return __gl_priority_specific_dispatching [priority]; +} - if (exception_tracebacks != 0) - __gl_exception_tracebacks = exception_tracebacks; +#ifndef IN_RTS - return; - } - already_called = 1; +/**********************/ +/* __gnat_set_globals */ +/**********************/ - __gl_main_priority = main_priority; - __gl_time_slice_val = time_slice_val; - __gl_wc_encoding = wc_encoding; - __gl_locking_policy = locking_policy; - __gl_queuing_policy = queuing_policy; - __gl_restrictions = restrictions; - __gl_interrupt_states = interrupt_states; - __gl_num_interrupt_states = num_interrupt_states; - __gl_task_dispatching_policy = task_dispatching_policy; - __gl_unreserve_all_interrupts = unreserve_all_interrupts; - __gl_exception_tracebacks = exception_tracebacks; - __gl_detect_blocking = detect_blocking; - - /* ??? __gl_zero_cost_exceptions is new in 3.15 and is referenced from - a-except.adb, which is also part of the compiler sources. Since the - compiler is built with an older release of GNAT, the call generated by - the old binder to this function does not provide any value for the - corresponding argument, so the global has to be initialized in some - reasonable other way. This could be removed as soon as the next major - release is out. */ +/* This routine is kept for boostrapping purposes, since the binder generated + file now sets the __gl_* variables directly. */ - /* ??? ditto for __gl_default_stack_size, new in 5.04 */ +void +__gnat_set_globals () +{ +} -#ifdef IN_RTS - __gl_zero_cost_exceptions = zero_cost_exceptions; - __gl_default_stack_size = default_stack_size; -#else - __gl_zero_cost_exceptions = 0; - /* We never build the compiler to run in ZCX mode currently anyway. */ #endif -} /* Notes on the Zero Cost Exceptions scheme and its impact on the signal handlers implemented below : @@ -647,6 +572,38 @@ __gnat_install_handler (void) #define NULL ((void *) 0) #endif +#if defined (MaRTE) + +/* MaRTE OS provides its own version of sigaction, sigfillset, and + sigemptyset (overriding these symbol names). We want to make sure that + the versions provided by the underlying C library are used here (these + versions are renamed by MaRTE to linux_sigaction, fake_linux_sigfillset, + and fake_linux_sigemptyset, respectively). The MaRTE library will not + always be present (it will not be linked if no tasking constructs are + used), so we use the weak symbol mechanism to point always to the symbols + defined within the C library. */ + +#pragma weak linux_sigaction +int linux_sigaction (int signum, const struct sigaction *act, + struct sigaction *oldact) { + return sigaction (signum, act, oldact); +} +#define sigaction(signum, act, oldact) linux_sigaction (signum, act, oldact) + +#pragma weak fake_linux_sigfillset +void fake_linux_sigfillset (sigset_t *set) { + sigfillset (set); +} +#define sigfillset(set) fake_linux_sigfillset (set) + +#pragma weak fake_linux_sigemptyset +void fake_linux_sigemptyset (sigset_t *set) { + sigemptyset (set); +} +#define sigemptyset(set) fake_linux_sigemptyset (set) + +#endif + static void __gnat_error_handler (int, siginfo_t *siginfo, void *ucontext); /* __gnat_adjust_context_for_raise - see comments along with the default @@ -856,6 +813,12 @@ __gnat_install_handler (void) #define SIGNAL_STACK_SIZE 4096 #define SIGNAL_STACK_ALIGNMENT 64 +#define Check_Abort_Status \ + system__soft_links__check_abort_status +extern int (*Check_Abort_Status) (void); + +extern struct Exception_Data _abort_signal; + static void __gnat_error_handler (int, int, sigcontext_t *); /* We are not setting the SA_SIGINFO bit in the sigaction flags when @@ -1186,35 +1149,35 @@ extern Exception_Code Base_Code_In (Exce /* DEC Ada exceptions are not defined in a header file, so they must be declared as external addresses */ -extern int ADA$_PROGRAM_ERROR __attribute__ ((weak)); -extern int ADA$_LOCK_ERROR __attribute__ ((weak)); -extern int ADA$_EXISTENCE_ERROR __attribute__ ((weak)); -extern int ADA$_KEY_ERROR __attribute__ ((weak)); -extern int ADA$_KEYSIZERR __attribute__ ((weak)); -extern int ADA$_STAOVF __attribute__ ((weak)); -extern int ADA$_CONSTRAINT_ERRO __attribute__ ((weak)); -extern int ADA$_IOSYSFAILED __attribute__ ((weak)); -extern int ADA$_LAYOUT_ERROR __attribute__ ((weak)); -extern int ADA$_STORAGE_ERROR __attribute__ ((weak)); -extern int ADA$_DATA_ERROR __attribute__ ((weak)); -extern int ADA$_DEVICE_ERROR __attribute__ ((weak)); -extern int ADA$_END_ERROR __attribute__ ((weak)); -extern int ADA$_MODE_ERROR __attribute__ ((weak)); -extern int ADA$_NAME_ERROR __attribute__ ((weak)); -extern int ADA$_STATUS_ERROR __attribute__ ((weak)); -extern int ADA$_NOT_OPEN __attribute__ ((weak)); -extern int ADA$_ALREADY_OPEN __attribute__ ((weak)); -extern int ADA$_USE_ERROR __attribute__ ((weak)); -extern int ADA$_UNSUPPORTED __attribute__ ((weak)); -extern int ADA$_FAC_MODE_MISMAT __attribute__ ((weak)); -extern int ADA$_ORG_MISMATCH __attribute__ ((weak)); -extern int ADA$_RFM_MISMATCH __attribute__ ((weak)); -extern int ADA$_RAT_MISMATCH __attribute__ ((weak)); -extern int ADA$_MRS_MISMATCH __attribute__ ((weak)); -extern int ADA$_MRN_MISMATCH __attribute__ ((weak)); -extern int ADA$_KEY_MISMATCH __attribute__ ((weak)); -extern int ADA$_MAXLINEXC __attribute__ ((weak)); -extern int ADA$_LINEXCMRS __attribute__ ((weak)); +extern int ADA$_PROGRAM_ERROR; +extern int ADA$_LOCK_ERROR; +extern int ADA$_EXISTENCE_ERROR; +extern int ADA$_KEY_ERROR; +extern int ADA$_KEYSIZERR; +extern int ADA$_STAOVF; +extern int ADA$_CONSTRAINT_ERRO; +extern int ADA$_IOSYSFAILED; +extern int ADA$_LAYOUT_ERROR; +extern int ADA$_STORAGE_ERROR; +extern int ADA$_DATA_ERROR; +extern int ADA$_DEVICE_ERROR; +extern int ADA$_END_ERROR; +extern int ADA$_MODE_ERROR; +extern int ADA$_NAME_ERROR; +extern int ADA$_STATUS_ERROR; +extern int ADA$_NOT_OPEN; +extern int ADA$_ALREADY_OPEN; +extern int ADA$_USE_ERROR; +extern int ADA$_UNSUPPORTED; +extern int ADA$_FAC_MODE_MISMAT; +extern int ADA$_ORG_MISMATCH; +extern int ADA$_RFM_MISMATCH; +extern int ADA$_RAT_MISMATCH; +extern int ADA$_MRS_MISMATCH; +extern int ADA$_MRN_MISMATCH; +extern int ADA$_KEY_MISMATCH; +extern int ADA$_MAXLINEXC; +extern int ADA$_LINEXCMRS; /* DEC Ada specific conditions */ static const struct cond_except dec_ada_cond_except_table [] = { @@ -1495,7 +1458,7 @@ __gnat_handle_vms_condition (int *sigarg break; } - __gnat_adjust_context_for_raise (0, (void *)sigargs); + __gnat_adjust_context_for_raise (0, (void *)mechargs); Raise_From_Signal_Handler (exception, msg); } @@ -1514,13 +1477,6 @@ __gnat_install_handler (void) SYS$SETEXV (1, __gnat_error_handler, 3, &prvhnd); #endif -#if defined (IN_RTS) && defined (__IA64) - if (getenv ("DBG$TDBG")) - printf ("DBG$TDBG defined, __gnat_error_handler not installed!\n"); - else - SYS$SETEXV (1, __gnat_error_handler, 3, &prvhnd); -#endif - /* On alpha-vms, we avoid the global vector annoyance thanks to frame based handlers to turn conditions into exceptions since GCC 3.4. The global vector is still required for earlier GCC versions. We're resorting to @@ -1555,7 +1511,9 @@ __gnat_adjust_context_for_raise (int sig /* Add one to the address of the instruction signaling the condition, located in the sigargs array. */ - CHF$SIGNAL_ARRAY * sigargs = (CHF$SIGNAL_ARRAY *) ucontext; + CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext; + CHF$SIGNAL_ARRAY * sigargs + = (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr; int vcount = sigargs->chf$is_sig_args; int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2]; @@ -1565,6 +1523,38 @@ __gnat_adjust_context_for_raise (int sig #endif +/* __gnat_adjust_context_for_raise for ia64. */ + +#if defined (IN_RTS) && defined (__IA64) + +#include +#include + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +typedef unsigned long long u64; + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) +{ + /* Add one to the address of the instruction signaling the condition, + located in the 64bits sigargs array. */ + + CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext; + + CHF64$SIGNAL_ARRAY *chfsig64 + = (CHF64$SIGNAL_ARRAY *) mechargs->chf$ph_mch_sig64_addr; + + u64 * post_sigarray + = (u64 *)chfsig64 + 1 + chfsig64->chf64$l_sig_args; + + u64 * ih_pc_loc = post_sigarray - 2; + + (*ih_pc_loc) ++; +} + +#endif + /*******************/ /* FreeBSD Section */ /*******************/ @@ -1572,13 +1562,27 @@ __gnat_adjust_context_for_raise (int sig #elif defined (__FreeBSD__) #include +#include #include -static void __gnat_error_handler (int, int, struct sigcontext *); +static void __gnat_error_handler (int, siginfo_t *, ucontext_t *); +void __gnat_adjust_context_for_raise (int, void*); + +/* __gnat_adjust_context_for_raise - see comments along with the default + version later in this file. */ + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) +{ + mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; + mcontext->mc_eip++; +} static void -__gnat_error_handler (int sig, int code __attribute__ ((unused)), - struct sigcontext *sc __attribute__ ((unused))) +__gnat_error_handler (int sig, siginfo_t *info __attribute__ ((unused)), + ucontext_t *ucontext) { struct Exception_Data *exception; const char *msg; @@ -1610,6 +1614,7 @@ __gnat_error_handler (int sig, int code msg = "unhandled signal"; } + __gnat_adjust_context_for_raise (sig, ucontext); Raise_From_Signal_Handler (exception, msg); } @@ -1623,7 +1628,7 @@ __gnat_install_handler () signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; - act.sa_flags = SA_NODEFER | SA_RESTART; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; (void) sigemptyset (&act.sa_mask); (void) sigaction (SIGILL, &act, NULL); Index: lib-writ.adb =================================================================== --- lib-writ.adb (revision 118179) +++ lib-writ.adb (working copy) @@ -354,6 +354,16 @@ package body Lib.Writ is Write_Info_Tab (49); Write_Info_Str (Version_Get (Unit_Num)); + -- Add BD parameter if Elaborate_Body pragma desirable + + if Ekind (Uent) = E_Package + and then Elaborate_Body_Desirable (Uent) + then + Write_Info_Str (" BD"); + end if; + + -- Add BN parameter if body needed for SAL + if (Is_Subprogram (Uent) or else Ekind (Uent) = E_Package or else Is_Generic_Unit (Uent)) @@ -1050,6 +1060,23 @@ package body Lib.Writ is Write_Info_EOL; end loop; + -- Output priority specific dispatching lines + + for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop + Write_Info_Initiate ('S'); + Write_Info_Char (' '); + Write_Info_Char (Specific_Dispatching.Table (J).Dispatching_Policy); + Write_Info_Char (' '); + Write_Info_Nat (Specific_Dispatching.Table (J).First_Priority); + Write_Info_Char (' '); + Write_Info_Nat (Specific_Dispatching.Table (J).Last_Priority); + Write_Info_Char (' '); + Write_Info_Nat + (Nat (Get_Logical_Line_Number + (Specific_Dispatching.Table (J).Pragma_Loc))); + Write_Info_EOL; + end loop; + -- Loop through file table to output information for all units for which -- we have generated code, as marked by the Generate_Code flag. Index: lib-writ.ads =================================================================== --- lib-writ.ads (revision 118179) +++ lib-writ.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -368,6 +368,26 @@ package Lib.Writ is -- line number of the corresponding Interrupt_State pragma. -- This is used in consistency messages. + -- ------------------------------------- + -- -- S Priority Specific Dispatching -- + -- ------------------------------------- + + -- S policy_identifier first_priority last_priority line-number + + -- This line records information from a Priority_Specific_Dispatching + -- pragma. There is one line for each separate pragma, and if no such + -- pragmas are used, then no S lines are present. + + -- The policy_identifier is the first character (upper case) of the + -- corresponding policy name (e.g. 'F' for FIFO_Within_Priorities). + + -- The first_priority and last_priority fields define the range of + -- priorities to which the specified dispatching policy apply. + + -- The line number is an unsigned decimal integer giving the + -- line number of the corresponding Priority_Specific_Dispatching + -- pragma. This is used in consistency messages. + ---------------------------- -- Compilation Unit Lines -- ---------------------------- @@ -403,6 +423,14 @@ package Lib.Writ is -- The <> are a series of two letter codes indicating -- information about the unit: -- + -- BD Unit does not have pragma Elaborate_Body, but the elaboration + -- circuit has determined that it would be a good idea if this + -- pragma were present, since the body of the package contains + -- elaboration code that modifies one or more variables in the + -- visible part of the package. The binder will try, but does + -- not promise, to keep the elaboration of the body close to + -- the elaboration of the spec. + -- -- DE Dynamic Elaboration. This unit was compiled with the -- dynamic elaboration model, as set by either the -gnatE -- switch or pragma Elaboration_Checks (Dynamic). @@ -643,6 +671,36 @@ package Lib.Writ is Table_Increment => 200, Table_Name => "Name_Interrupt_States"); + -- The table structure defined here stores one entry for each + -- Priority_Specific_Dispatching pragma encountered either in the main + -- source or in an ancillary with'ed source. Since + -- have to be consistent across all units in a partition, we may + -- as well detect inconsistencies at compile time when we can. + + type Specific_Dispatching_Entry is record + Dispatching_Policy : Character; + -- First character (upper case) of the corresponding policy name + + First_Priority : Nat; + -- Lower bound of the priority range to which the specified dispatching + -- policy applies. + + Last_Priority : Nat; + -- Upper bound of the priority range to which the specified dispatching + -- policy applies. + + Pragma_Loc : Source_Ptr; + -- Location of pragma setting this value in place + end record; + + package Specific_Dispatching is new Table.Table ( + Table_Component_Type => Specific_Dispatching_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Name_Priority_Specific_Dispatching"); + ----------------- -- Subprograms -- ----------------- Index: par-prag.adb =================================================================== --- par-prag.adb (revision 118179) +++ par-prag.adb (working copy) @@ -39,6 +39,8 @@ with Stylesw; use Stylesw; with Uintp; use Uintp; with Uname; use Uname; +with System.WCh_Con; use System.WCh_Con; + separate (Par) function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is @@ -903,7 +905,7 @@ begin A := Expression (Arg1); if Nkind (A) = N_String_Literal then - S := Strval (A); + S := Strval (A); declare Slen : constant Natural := Natural (String_Length (S)); @@ -969,8 +971,10 @@ begin -- Warnings (GNAT) -- --------------------- - -- pragma Warnings (On | Off, [LOCAL_NAME]) + -- pragma Warnings (On | Off); + -- pragma Warnings (On | Off, LOCAL_NAME); -- pragma Warnings (static_string_EXPRESSION); + -- pragma Warnings (On | Off, static_string_EXPRESSION); -- The one argument ON/OFF case is processed by the parser, since it may -- control parser warnings as well as semantic warnings, and in any case @@ -994,6 +998,49 @@ begin end; end if; + ----------------------------- + -- Wide_Character_Encoding -- + ----------------------------- + + -- pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); + + -- This is processed by the parser, since the scanner is affected + + when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare + A : Node_Id; + + begin + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + A := Expression (Arg1); + + if Nkind (A) = N_Identifier then + Get_Name_String (Chars (A)); + Wide_Character_Encoding_Method := + Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len)); + + elsif Nkind (A) = N_Character_Literal then + declare + R : constant Char_Code := + Char_Code (UI_To_Int (Char_Literal_Value (A))); + begin + if In_Character_Range (R) then + Wide_Character_Encoding_Method := + Get_WC_Encoding_Method (Get_Character (R)); + else + raise Constraint_Error; + end if; + end; + + else + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + Error_Msg_N ("invalid argument for pragma%", Arg1); + end Wide_Character_Encoding; + ----------------------- -- All Other Pragmas -- ----------------------- @@ -1001,142 +1048,144 @@ begin -- For all other pragmas, checking and processing is handled -- entirely in Sem_Prag, and no further checking is done by Par. - when Pragma_Abort_Defer | - Pragma_Assertion_Policy | - Pragma_AST_Entry | - Pragma_All_Calls_Remote | - Pragma_Annotate | - Pragma_Assert | - Pragma_Asynchronous | - Pragma_Atomic | - Pragma_Atomic_Components | - Pragma_Attach_Handler | - Pragma_Compile_Time_Warning | - Pragma_Convention_Identifier | - Pragma_CPP_Class | - Pragma_CPP_Constructor | - Pragma_CPP_Virtual | - Pragma_CPP_Vtable | - Pragma_C_Pass_By_Copy | - Pragma_Comment | - Pragma_Common_Object | - Pragma_Complete_Representation | - Pragma_Complex_Representation | - Pragma_Component_Alignment | - Pragma_Controlled | - Pragma_Convention | - Pragma_Debug_Policy | - Pragma_Detect_Blocking | - Pragma_Discard_Names | - Pragma_Eliminate | - Pragma_Elaborate | - Pragma_Elaborate_All | - Pragma_Elaborate_Body | - Pragma_Elaboration_Checks | - Pragma_Explicit_Overriding | - Pragma_Export | - Pragma_Export_Exception | - Pragma_Export_Function | - Pragma_Export_Object | - Pragma_Export_Procedure | - Pragma_Export_Value | - Pragma_Export_Valued_Procedure | - Pragma_Extend_System | - Pragma_External | - Pragma_External_Name_Casing | - Pragma_Finalize_Storage_Only | - Pragma_Float_Representation | - Pragma_Ident | - Pragma_Import | - Pragma_Import_Exception | - Pragma_Import_Function | - Pragma_Import_Object | - Pragma_Import_Procedure | - Pragma_Import_Valued_Procedure | - Pragma_Initialize_Scalars | - Pragma_Inline | - Pragma_Inline_Always | - Pragma_Inline_Generic | - Pragma_Inspection_Point | - Pragma_Interface | - Pragma_Interface_Name | - Pragma_Interrupt_Handler | - Pragma_Interrupt_State | - Pragma_Interrupt_Priority | - Pragma_Java_Constructor | - Pragma_Java_Interface | - Pragma_Keep_Names | - Pragma_License | - Pragma_Link_With | - Pragma_Linker_Alias | - Pragma_Linker_Constructor | - Pragma_Linker_Destructor | - Pragma_Linker_Options | - Pragma_Linker_Section | - Pragma_Locking_Policy | - Pragma_Long_Float | - Pragma_Machine_Attribute | - Pragma_Main | - Pragma_Main_Storage | - Pragma_Memory_Size | - Pragma_No_Return | - Pragma_Obsolescent | - Pragma_No_Run_Time | - Pragma_No_Strict_Aliasing | - Pragma_Normalize_Scalars | - Pragma_Optimize | - Pragma_Optional_Overriding | - Pragma_Pack | - Pragma_Passive | - Pragma_Polling | - Pragma_Persistent_BSS | - Pragma_Preelaborate | - Pragma_Preelaborate_05 | - Pragma_Priority | - Pragma_Profile | - Pragma_Profile_Warnings | - Pragma_Propagate_Exceptions | - Pragma_Psect_Object | - Pragma_Pure | - Pragma_Pure_05 | - Pragma_Pure_Function | - Pragma_Queuing_Policy | - Pragma_Remote_Call_Interface | - Pragma_Remote_Types | - Pragma_Restricted_Run_Time | - Pragma_Ravenscar | - Pragma_Reviewable | - Pragma_Share_Generic | - Pragma_Shared | - Pragma_Shared_Passive | - Pragma_Storage_Size | - Pragma_Storage_Unit | - Pragma_Stream_Convert | - Pragma_Subtitle | - Pragma_Suppress | - Pragma_Suppress_All | - Pragma_Suppress_Debug_Info | - Pragma_Suppress_Exception_Locations | - Pragma_Suppress_Initialization | - Pragma_System_Name | - Pragma_Task_Dispatching_Policy | - Pragma_Task_Info | - Pragma_Task_Name | - Pragma_Task_Storage | - Pragma_Thread_Body | - Pragma_Time_Slice | - Pragma_Title | - Pragma_Unchecked_Union | - Pragma_Unimplemented_Unit | - Pragma_Universal_Data | - Pragma_Unreferenced | - Pragma_Unreserve_All_Interrupts | - Pragma_Unsuppress | - Pragma_Use_VADS_Size | - Pragma_Volatile | - Pragma_Volatile_Components | - Pragma_Weak_External | - Pragma_Validity_Checks => + when Pragma_Abort_Defer | + Pragma_Assertion_Policy | + Pragma_AST_Entry | + Pragma_All_Calls_Remote | + Pragma_Annotate | + Pragma_Assert | + Pragma_Asynchronous | + Pragma_Atomic | + Pragma_Atomic_Components | + Pragma_Attach_Handler | + Pragma_Compile_Time_Warning | + Pragma_Convention_Identifier | + Pragma_CPP_Class | + Pragma_CPP_Constructor | + Pragma_CPP_Virtual | + Pragma_CPP_Vtable | + Pragma_C_Pass_By_Copy | + Pragma_Comment | + Pragma_Common_Object | + Pragma_Complete_Representation | + Pragma_Complex_Representation | + Pragma_Component_Alignment | + Pragma_Controlled | + Pragma_Convention | + Pragma_Debug_Policy | + Pragma_Detect_Blocking | + Pragma_Discard_Names | + Pragma_Eliminate | + Pragma_Elaborate | + Pragma_Elaborate_All | + Pragma_Elaborate_Body | + Pragma_Elaboration_Checks | + Pragma_Explicit_Overriding | + Pragma_Export | + Pragma_Export_Exception | + Pragma_Export_Function | + Pragma_Export_Object | + Pragma_Export_Procedure | + Pragma_Export_Value | + Pragma_Export_Valued_Procedure | + Pragma_Extend_System | + Pragma_External | + Pragma_External_Name_Casing | + Pragma_Finalize_Storage_Only | + Pragma_Float_Representation | + Pragma_Ident | + Pragma_Import | + Pragma_Import_Exception | + Pragma_Import_Function | + Pragma_Import_Object | + Pragma_Import_Procedure | + Pragma_Import_Valued_Procedure | + Pragma_Initialize_Scalars | + Pragma_Inline | + Pragma_Inline_Always | + Pragma_Inline_Generic | + Pragma_Inspection_Point | + Pragma_Interface | + Pragma_Interface_Name | + Pragma_Interrupt_Handler | + Pragma_Interrupt_State | + Pragma_Interrupt_Priority | + Pragma_Java_Constructor | + Pragma_Java_Interface | + Pragma_Keep_Names | + Pragma_License | + Pragma_Link_With | + Pragma_Linker_Alias | + Pragma_Linker_Constructor | + Pragma_Linker_Destructor | + Pragma_Linker_Options | + Pragma_Linker_Section | + Pragma_Locking_Policy | + Pragma_Long_Float | + Pragma_Machine_Attribute | + Pragma_Main | + Pragma_Main_Storage | + Pragma_Memory_Size | + Pragma_No_Return | + Pragma_Obsolescent | + Pragma_No_Run_Time | + Pragma_No_Strict_Aliasing | + Pragma_Normalize_Scalars | + Pragma_Optimize | + Pragma_Optional_Overriding | + Pragma_Pack | + Pragma_Passive | + Pragma_Preelaborable_Initialization | + Pragma_Polling | + Pragma_Persistent_BSS | + Pragma_Preelaborate | + Pragma_Preelaborate_05 | + Pragma_Priority | + Pragma_Priority_Specific_Dispatching | + Pragma_Profile | + Pragma_Profile_Warnings | + Pragma_Propagate_Exceptions | + Pragma_Psect_Object | + Pragma_Pure | + Pragma_Pure_05 | + Pragma_Pure_Function | + Pragma_Queuing_Policy | + Pragma_Remote_Call_Interface | + Pragma_Remote_Types | + Pragma_Restricted_Run_Time | + Pragma_Ravenscar | + Pragma_Reviewable | + Pragma_Share_Generic | + Pragma_Shared | + Pragma_Shared_Passive | + Pragma_Storage_Size | + Pragma_Storage_Unit | + Pragma_Stream_Convert | + Pragma_Subtitle | + Pragma_Suppress | + Pragma_Suppress_All | + Pragma_Suppress_Debug_Info | + Pragma_Suppress_Exception_Locations | + Pragma_Suppress_Initialization | + Pragma_System_Name | + Pragma_Task_Dispatching_Policy | + Pragma_Task_Info | + Pragma_Task_Name | + Pragma_Task_Storage | + Pragma_Thread_Body | + Pragma_Time_Slice | + Pragma_Title | + Pragma_Unchecked_Union | + Pragma_Unimplemented_Unit | + Pragma_Universal_Data | + Pragma_Unreferenced | + Pragma_Unreserve_All_Interrupts | + Pragma_Unsuppress | + Pragma_Use_VADS_Size | + Pragma_Volatile | + Pragma_Volatile_Components | + Pragma_Weak_External | + Pragma_Validity_Checks => null; --------------------