Skip to content

R
riscv-gcc-1
Commit 3cb8344b by Robert Dewar Committed by Arnaud Charlet
Options

a-dispat.ads, [...]: New files. 

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

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

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

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

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

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

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

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

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

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

From-SVN: r118243
parent 9b832db5
Showing with 1691 additions and 963 deletions
gcc/ada/a-diroro.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-diroro.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-dispat.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/ali.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -54,6 +54,7 @@ package body ALI is
'E' => True, -- external
'D' => True, -- dependency
'X' => True, -- xref
'S' => True, -- specific dispatching
others => False);
--------------------
......@@ -140,13 +141,6 @@ package body ALI is
-- be ignored by Scan_ALI and skipped, and False if the lines
-- are to be read and processed.
Restrictions_Initial : Rident.Restrictions_Info;
pragma Warnings (Off, Restrictions_Initial);
-- This variable, which should really be a constant (but that's not
-- allowed by the language) is used only for initialization, and the
-- reason we are declaring it is to get the default initialization
-- set for the object.
Bad_ALI_Format : exception;
-- Exception raised by Fatal_Error if Err is True
......@@ -197,7 +191,7 @@ package body ALI is
-- white space (when Ignore_Spaces is False) or a typeref bracket or
-- an equal sign except for the special case of an operator name
-- starting with a double quite which is terminated by another double
-- quote.
-- quote. This function handles wide characters properly.
function Get_Nat return Nat;
-- Skip blanks, then scan out an unsigned integer value in Nat range
......@@ -267,21 +261,6 @@ package body ALI is
end if;
end Check_At_End_Of_Field;
------------
-- Checkc --
------------
procedure Checkc (C : Character) is
begin
if Nextc = C then
P := P + 1;
elsif Ignore_Errors then
P := P + 1;
else
Fatal_Error;
end if;
end Checkc;
------------------------
-- Check_Unknown_Line --
------------------------
......@@ -308,6 +287,21 @@ package body ALI is
end loop;
end Check_Unknown_Line;
------------
-- Checkc --
------------
procedure Checkc (C : Character) is
begin
if Nextc = C then
P := P + 1;
elsif Ignore_Errors then
P := P + 1;
else
Fatal_Error;
end if;
end Checkc;
-----------------
-- Fatal_Error --
-----------------
......@@ -445,12 +439,21 @@ package body ALI is
exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
else
exit when (At_End_Of_Field and not Ignore_Spaces)
or else Nextc = '(' or else Nextc = ')'
-- Terminate on parens or angle brackets or equal sign
exit when Nextc = '(' or else Nextc = ')'
or else Nextc = '{' or else Nextc = '}'
or else Nextc = '<' or else Nextc = '>'
or else Nextc = '[' or else Nextc = ']'
or else Nextc = '=';
-- Terminate if left bracket not part of wide char sequence
-- Note that we only recognize brackets notation so far ???
exit when Nextc = '[' and then T (P + 1) /= '"';
-- Terminate if right bracket not part of wide char sequence
exit when Nextc = ']' and then T (P - 1) /= '"';
end if;
end loop;
......@@ -524,29 +527,6 @@ package body ALI is
return T;
end Get_Stamp;
----------
-- Getc --
----------
function Getc return Character is
begin
if P = T'Last then
return EOF;
else
P := P + 1;
return T (P - 1);
end if;
end Getc;
-----------
-- Nextc --
-----------
function Nextc return Character is
begin
return T (P);
end Nextc;
-----------------
-- Get_Typeref --
-----------------
......@@ -635,6 +615,29 @@ package body ALI is
end if;
end Get_Typeref;
----------
-- Getc --
----------
function Getc return Character is
begin
if P = T'Last then
return EOF;
else
P := P + 1;
return T (P - 1);
end if;
end Getc;
-----------
-- Nextc --
-----------
function Nextc return Character is
begin
return T (P);
end Nextc;
--------------
-- Skip_Eol --
--------------
......@@ -740,10 +743,12 @@ package body ALI is
Compile_Errors => False,
First_Interrupt_State => Interrupt_States.Last + 1,
First_Sdep => No_Sdep_Id,
First_Specific_Dispatching => Specific_Dispatching.Last + 1,
First_Unit => No_Unit_Id,
Float_Format => 'I',
Last_Interrupt_State => Interrupt_States.Last,
Last_Sdep => No_Sdep_Id,
Last_Specific_Dispatching => Specific_Dispatching.Last,
Last_Unit => No_Unit_Id,
Locking_Policy => ' ',
Main_Priority => -1,
......@@ -752,7 +757,7 @@ package body ALI is
Normalize_Scalars => False,
Ofile_Full_Name => Full_Object_File_Name,
Queuing_Policy => ' ',
Restrictions => Restrictions_Initial,
Restrictions => No_Restrictions,
SAL_Interface => False,
Sfile => No_Name,
Task_Dispatching_Policy => ' ',
......@@ -1194,7 +1199,7 @@ package body ALI is
if Ignore_Errors then
Cumulative_Restrictions := Save_R;
ALIs.Table (Id).Restrictions := Restrictions_Initial;
ALIs.Table (Id).Restrictions := No_Restrictions;
Skip_Eol;
-- In normal mode, this is a fatal error
......@@ -1254,6 +1259,47 @@ package body ALI is
C := Getc;
end loop;
-- Acquire 'S' lines if present
Check_Unknown_Line;
while C = 'S' loop
if Ignore ('S') then
Skip_Line;
else
declare
Policy : Character;
First_Prio : Nat;
Last_Prio : Nat;
Line_No : Nat;
begin
Checkc (' ');
Skip_Space;
Policy := Getc;
Skip_Space;
First_Prio := Get_Nat;
Last_Prio := Get_Nat;
Line_No := Get_Nat;
Specific_Dispatching.Append (
(Dispatching_Policy => Policy,
First_Priority => First_Prio,
Last_Priority => Last_Prio,
PSD_Pragma_Line => Line_No));
ALIs.Table (Id).Last_Specific_Dispatching :=
Specific_Dispatching.Last;
Skip_Eol;
end;
end if;
C := Getc;
end loop;
-- Loop to acquire unit entries
U_Loop : loop
......@@ -1270,42 +1316,47 @@ package body ALI is
ALIs.Table (Id).First_Unit := Units.Last;
end if;
Units.Table (Units.Last).Uname := Get_Name;
Units.Table (Units.Last).Predefined := Is_Predefined_Unit;
Units.Table (Units.Last).Internal := Is_Internal_Unit;
Units.Table (Units.Last).My_ALI := Id;
Units.Table (Units.Last).Sfile := Get_Name (Lower => True);
Units.Table (Units.Last).Pure := False;
Units.Table (Units.Last).Preelab := False;
Units.Table (Units.Last).No_Elab := False;
Units.Table (Units.Last).Shared_Passive := False;
Units.Table (Units.Last).RCI := False;
Units.Table (Units.Last).Remote_Types := False;
Units.Table (Units.Last).Has_RACW := False;
Units.Table (Units.Last).Init_Scalars := False;
Units.Table (Units.Last).Is_Generic := False;
Units.Table (Units.Last).Icasing := Mixed_Case;
Units.Table (Units.Last).Kcasing := All_Lower_Case;
Units.Table (Units.Last).Dynamic_Elab := False;
Units.Table (Units.Last).Elaborate_Body := False;
Units.Table (Units.Last).Set_Elab_Entity := False;
Units.Table (Units.Last).Version := "00000000";
Units.Table (Units.Last).First_With := Withs.Last + 1;
Units.Table (Units.Last).First_Arg := First_Arg;
Units.Table (Units.Last).Elab_Position := 0;
Units.Table (Units.Last).SAL_Interface := ALIs.Table (Id).
SAL_Interface;
Units.Table (Units.Last).Body_Needed_For_SAL := False;
if Debug_Flag_U then
Write_Str (" ----> reading unit ");
Write_Int (Int (Units.Last));
Write_Str (" ");
Write_Unit_Name (Units.Table (Units.Last).Uname);
Write_Str (" from file ");
Write_Name (Units.Table (Units.Last).Sfile);
Write_Eol;
end if;
declare
UL : Unit_Record renames Units.Table (Units.Last);
begin
UL.Uname := Get_Name;
UL.Predefined := Is_Predefined_Unit;
UL.Internal := Is_Internal_Unit;
UL.My_ALI := Id;
UL.Sfile := Get_Name (Lower => True);
UL.Pure := False;
UL.Preelab := False;
UL.No_Elab := False;
UL.Shared_Passive := False;
UL.RCI := False;
UL.Remote_Types := False;
UL.Has_RACW := False;
UL.Init_Scalars := False;
UL.Is_Generic := False;
UL.Icasing := Mixed_Case;
UL.Kcasing := All_Lower_Case;
UL.Dynamic_Elab := False;
UL.Elaborate_Body := False;
UL.Set_Elab_Entity := False;
UL.Version := "00000000";
UL.First_With := Withs.Last + 1;
UL.First_Arg := First_Arg;
UL.Elab_Position := 0;
UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
UL.Body_Needed_For_SAL := False;
UL.Elaborate_Body_Desirable := False;
if Debug_Flag_U then
Write_Str (" ----> reading unit ");
Write_Int (Int (Units.Last));
Write_Str (" ");
Write_Unit_Name (UL.Uname);
Write_Str (" from file ");
Write_Name (UL.Sfile);
Write_Eol;
end if;
end;
-- Check for duplicated unit in different files
......@@ -1378,14 +1429,19 @@ package body ALI is
Units.Table (Units.Last).Version (J) := C;
end loop;
-- BN parameter (Body needed)
-- BD/BN parameters
elsif C = 'B' then
C := Getc;
if C = 'N' then
if C = 'D' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Elaborate_Body_Desirable := True;
elsif C = 'N' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Body_Needed_For_SAL := True;
else
Fatal_Error_Ignore;
end if;
......
gcc/ada/ali.ads
......@@ -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.
......
gcc/ada/bcheck.adb
......@@ -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;
<<Continue>>
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;
<<Continue>>
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;
gcc/ada/bindgen.adb
......@@ -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 GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
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.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_Ada;
-- Generate initialization of restrictions variable (Ada code case)
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_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
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"");");
Set_String (" Interrupt_States : constant String :=");
Write_Statement_Buffer;
declare
Col : Natural;
begin
Set_String (" """);
Col := 9;
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 ("");
if Exception_Tracebacks then
WBI (" Exception_Tracebacks : Integer;");
WBI (" pragma Import (C, Exception_Tracebacks, " &
"""__gl_exception_tracebacks"");");
end if;
-- Generate spec for Set_Globals procedure
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;");
WBI (" Interrupt_States => " &
"Interrupt_States'Address,");
Set_String (" Num_Specific_Dispatching := ");
Set_Int (PSD_Pragma_Settings.Last + 1);
Set_Char (';');
Write_Statement_Buffer;
Set_String (" Num_Interrupt_States => ");
WBI (" Interrupt_States := Local_Interrupt_States'Address;");
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 => (");
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');
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;
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 --
----------------------
......
gcc/ada/init.c
......@@ -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,120 +142,47 @@ __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. */
char __gnat_get_specific_dispatching (int);
/* For detailed description of the parameters to this routine, see the
section titled Run-Time Globals in package Bindgen (bindgen.adb) */
/* 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. */
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)
char
__gnat_get_specific_dispatching (int priority)
{
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.
For identical reasons, the consistency of time_slice_val should not
be checked. */
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 (__gl_num_specific_dispatching == 0)
return ' ';
else if (priority >= __gl_num_specific_dispatching)
return 'F';
else
return __gl_priority_specific_dispatching [priority];
}
/* If either a library or the main program set the exception traceback
flag, it is never reset later */
#ifndef IN_RTS
if (exception_tracebacks != 0)
__gl_exception_tracebacks = exception_tracebacks;
/**********************/
/* __gnat_set_globals */
/**********************/
return;
}
already_called = 1;
__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. */
/* ??? ditto for __gl_default_stack_size, new in 5.04 */
/* This routine is kept for boostrapping purposes, since the binder generated
file now sets the __gl_* variables directly. */
#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
void
__gnat_set_globals ()
{
}
#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 (Exception_Code);
/* 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 *sigargs, void *mechargs)
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 signo ATTRIBUTE_UNUSED, void *ucontext)
/* 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 signo ATTRIBUTE_UNUSED, void *ucontext)
#endif
/* __gnat_adjust_context_for_raise for ia64. */
#if defined (IN_RTS) && defined (__IA64)
#include <vms/chfctxdef.h>
#include <vms/chfdef.h>
#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 signo ATTRIBUTE_UNUSED, void *ucontext)
#elif defined (__FreeBSD__)
#include <signal.h>
#include <sys/ucontext.h>
#include <unistd.h>
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 __attribute__ ((unused)),
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);
......
gcc/ada/lib-writ.adb
......@@ -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.
......
gcc/ada/lib-writ.ads
......@@ -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 <<attributes>> 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 --
-----------------
......
gcc/ada/par-prag.adb
......@@ -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;
--------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment