Skip to content

R
riscv-gcc-1
Commit 06effe87 by Arnaud Charlet
Options

[multiple changes] 

2004-02-04  Robert Dewar  <dewar@gnat.com>

	* 5gtasinf.adb, 5gtasinf.ads, 5gtaprop.adb, ali.adb,
	ali.ads, gprcmd.adb: Minor reformatting

	* bindgen.adb: Output restrictions string for new style restrictions
	handling

	* impunit.adb: Add s-rident.ads (System.Rident) and
	s-restri (System.Restrictions)

	* lib-writ.adb: Fix bug in writing restrictions string (last few
	entries wrong)

	* s-restri.ads, s-restri.adb: Change name Restrictions to
	Run_Time_Restrictions to avoid conflict with package name.
	Add circuit to read and acquire run time restrictions.

2004-02-04  Jose Ruiz  <ruiz@act-europe.fr>

	* restrict.ads, restrict.adb: Use the new restriction
	No_Task_Attributes_Package instead of the old No_Task_Attributes.

	* sem_prag.adb: No_Task_Attributes is a synonym of
	No_Task_Attributes_Package.

	* snames.ads, snames.adb: New entry for proper handling of
	No_Task_Attributes.

	* s-rident.ads: Adding restriction No_Task_Attributes_Package
	(AI-00249) that supersedes the GNAT specific restriction
	No_Task_Attributes.

2004-02-04  Ed Schonberg  <schonberg@gnat.com>

	* sem_prag.adb:
	(Analyze_Pragma, case Warnings): In an inlined body, as in an instance
	 body, an identifier may be wrapped in an unchecked conversion.

2004-02-04  Vincent Celier  <celier@gnat.com>

	* lib-writ.ads: Comment update for the W lines

	* bld.adb: (Expression): An empty string list is static

	* fname-uf.adb: Minor comment update

	* fname-uf.ads: (Get_File_Name): Document new parameter May_Fail

	* gnatbind.adb: Initialize Cumulative_Restrictions with the
	restrictions on the target.

From-SVN: r77233
parent c2379679
Showing with 295 additions and 110 deletions
gcc/ada/5gtaprop.adb
......@@ -141,7 +141,6 @@ package body System.Task_Primitives.Operations is
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
begin
null;
end Stack_Guard;
......@@ -251,7 +250,6 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
......@@ -259,7 +257,6 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
......@@ -271,10 +268,8 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_lock (L);
Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
pragma Assert (Result /= FUNC_ERR);
end Write_Lock;
......@@ -283,7 +278,6 @@ package body System.Task_Primitives.Operations is
(L : access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
......@@ -293,7 +287,6 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
......@@ -316,7 +309,6 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
......@@ -324,7 +316,6 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
......@@ -334,7 +325,6 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
......@@ -543,7 +533,6 @@ package body System.Task_Primitives.Operations is
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
Result : Interfaces.C.int;
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
......@@ -813,10 +802,8 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
Result : Interfaces.C.int;
begin
Result := pthread_set_ada_tcb (pthread_self, System.Null_Address);
pragma Assert (Result = 0);
end Exit_Task;
......@@ -826,7 +813,6 @@ package body System.Task_Primitives.Operations is
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
begin
Result :=
pthread_kill (T.Common.LL.Thread,
......@@ -854,7 +840,6 @@ package body System.Task_Primitives.Operations is
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
pragma Unreferenced (Self_ID);
begin
return True;
end Check_No_Locks;
......@@ -961,9 +946,10 @@ package body System.Task_Primitives.Operations is
if Result = FUNC_ERR then
raise Storage_Error; -- Insufficient resources.
end if;
end Initialize_Athread_Library;
-- Package initialization
begin
Initialize_Athread_Library;
end System.Task_Primitives.Operations;
gcc/ada/5gtasinf.adb
......@@ -78,7 +78,6 @@ package body System.Task_Info is
function "+" (R : Resource_T) return Resource_Vector_T is
Result : Resource_Vector_T := NO_RESOURCES;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
......@@ -86,7 +85,6 @@ package body System.Task_Info is
function "+" (R1, R2 : Resource_T) return Resource_Vector_T is
Result : Resource_Vector_T := NO_RESOURCES;
begin
Result (Resource_T'Pos (R1)) := True;
Result (Resource_T'Pos (R2)) := True;
......@@ -95,11 +93,9 @@ package body System.Task_Info is
function "+"
(R : Resource_T;
S : Resource_Vector_T)
return Resource_Vector_T
S : Resource_Vector_T) return Resource_Vector_T
is
Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
......@@ -107,11 +103,9 @@ package body System.Task_Info is
function "+"
(S : Resource_Vector_T;
R : Resource_T)
return Resource_Vector_T
R : Resource_T) return Resource_Vector_T
is
Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := True;
return Result;
......@@ -119,7 +113,6 @@ package body System.Task_Info is
function "+" (S1, S2 : Resource_Vector_T) return Resource_Vector_T is
Result : Resource_Vector_T;
begin
Result := S1 or S2;
return Result;
......@@ -127,11 +120,9 @@ package body System.Task_Info is
function "-"
(S : Resource_Vector_T;
R : Resource_T)
return Resource_Vector_T
R : Resource_T) return Resource_Vector_T
is
Result : Resource_Vector_T := S;
begin
Result (Resource_T'Pos (R)) := False;
return Result;
......@@ -177,17 +168,19 @@ package body System.Task_Info is
end if;
if Attr.NDPRI /= NDP_NONE then
-- ??? why is that comment out, should it be removed ?
-- ??? why is this commented out, should it be removed ?
-- if Geteuid /= 0 then
-- raise Permission_Error;
-- end if;
Status := sproc_attr_setprio
(Sproc_Attr'Unrestricted_Access,
int (Attr.NDPRI));
Status :=
sproc_attr_setprio
(Sproc_Attr'Unrestricted_Access, int (Attr.NDPRI));
end if;
Status := sproc_create
Status :=
sproc_create
(Sproc'Unrestricted_Access,
Sproc_Attr'Unrestricted_Access,
null,
......@@ -199,7 +192,6 @@ package body System.Task_Info is
end if;
Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
end if;
if Status /= 0 then
......@@ -217,12 +209,10 @@ package body System.Task_Info is
(Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
return sproc_t
NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t
is
Attr : constant Sproc_Attributes :=
(Sproc_Resources, CPU, Resident, NDPRI);
begin
return New_Sproc (Attr);
end New_Sproc;
......@@ -233,8 +223,7 @@ package body System.Task_Info is
function Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0)
return Thread_Attributes
Thread_Timeslice : Duration := 0.0) return Thread_Attributes
is
begin
return (False, Thread_Resources, Thread_Timeslice);
......@@ -269,7 +258,6 @@ package body System.Task_Info is
is
Sproc : constant sproc_t := New_Sproc
(Sproc_Resources, CPU, Resident, NDPRI);
begin
return (True, Thread_Resources, Thread_Timeslice, Sproc);
end Bound_Thread_Attributes;
......@@ -280,8 +268,7 @@ package body System.Task_Info is
function New_Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0)
return Task_Info_Type
Thread_Timeslice : Duration := 0.0) return Task_Info_Type
is
begin
return new Thread_Attributes'
......@@ -295,8 +282,7 @@ package body System.Task_Info is
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
Sproc : sproc_t)
return Task_Info_Type
Sproc : sproc_t) return Task_Info_Type
is
begin
return new Thread_Attributes'
......@@ -318,7 +304,6 @@ package body System.Task_Info is
is
Sproc : constant sproc_t := New_Sproc
(Sproc_Resources, CPU, Resident, NDPRI);
begin
return new Thread_Attributes'
(True, Thread_Resources, Thread_Timeslice, Sproc);
......
gcc/ada/5gtasinf.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
......@@ -63,14 +63,14 @@ package System.Task_Info is
-- Each thread has a number of attributes that dictate it's scheduling.
-- These attributes are:
--
-- Bound_To_Sproc: whether the thread is bound to a specific sproc
-- for its entire lifetime.
--
-- Timeslice: Amount of time that a thread is allowed to execute
-- before the system yeilds control to another thread
-- of equal priority.
--
-- Resource_Vector: A bitmask used to control the binding of threads
-- to sprocs.
--
......@@ -113,33 +113,27 @@ package System.Task_Info is
package Resource_Vector_Functions is
function "+"
(R : Resource_T)
return Resource_Vector_T;
(R : Resource_T) return Resource_Vector_T;
function "+"
(R1 : Resource_T;
R2 : Resource_T)
return Resource_Vector_T;
R2 : Resource_T) return Resource_Vector_T;
function "+"
(R : Resource_T;
S : Resource_Vector_T)
return Resource_Vector_T;
S : Resource_Vector_T) return Resource_Vector_T;
function "+"
(S : Resource_Vector_T;
R : Resource_T)
return Resource_Vector_T;
R : Resource_T) return Resource_Vector_T;
function "+"
(S1 : Resource_Vector_T;
S2 : Resource_Vector_T)
return Resource_Vector_T;
S2 : Resource_Vector_T) return Resource_Vector_T;
function "-"
(S : Resource_Vector_T;
R : Resource_T)
return Resource_Vector_T;
R : Resource_T) return Resource_Vector_T;
end Resource_Vector_Functions;
----------------------
......@@ -208,8 +202,7 @@ package System.Task_Info is
(Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE)
return sproc_t;
NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t;
-- Allocates a sproc_t control structure and creates the
-- corresponding sproc.
......@@ -239,14 +232,12 @@ package System.Task_Info is
function Unbound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0)
return Thread_Attributes;
Thread_Timeslice : Duration := 0.0) return Thread_Attributes;
function Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
Sproc : sproc_t)
return Thread_Attributes;
Sproc : sproc_t) return Thread_Attributes;
function Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
......@@ -267,8 +258,7 @@ package System.Task_Info is
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
Thread_Timeslice : Duration := 0.0;
Sproc : sproc_t)
return Task_Info_Type;
Sproc : sproc_t) return Task_Info_Type;
function New_Bound_Thread_Attributes
(Thread_Resources : Resource_Vector_T := NO_RESOURCES;
......
gcc/ada/ChangeLog
2004-02-04 Robert Dewar <dewar@gnat.com>
* 5gtasinf.adb, 5gtasinf.ads, 5gtaprop.adb, ali.adb,
ali.ads, gprcmd.adb: Minor reformatting
* bindgen.adb: Output restrictions string for new style restrictions
handling
* impunit.adb: Add s-rident.ads (System.Rident) and
s-restri (System.Restrictions)
* lib-writ.adb: Fix bug in writing restrictions string (last few
entries wrong)
* s-restri.ads, s-restri.adb: Change name Restrictions to
Run_Time_Restrictions to avoid conflict with package name.
Add circuit to read and acquire run time restrictions.
2004-02-04 Jose Ruiz <ruiz@act-europe.fr>
* restrict.ads, restrict.adb: Use the new restriction
No_Task_Attributes_Package instead of the old No_Task_Attributes.
* sem_prag.adb: No_Task_Attributes is a synonym of
No_Task_Attributes_Package.
* snames.ads, snames.adb: New entry for proper handling of
No_Task_Attributes.
* s-rident.ads: Adding restriction No_Task_Attributes_Package
(AI-00249) that supersedes the GNAT specific restriction
No_Task_Attributes.
2004-02-04 Ed Schonberg <schonberg@gnat.com>
* sem_prag.adb:
(Analyze_Pragma, case Warnings): In an inlined body, as in an instance
body, an identifier may be wrapped in an unchecked conversion.
2004-02-04 Vincent Celier <celier@gnat.com>
* lib-writ.ads: Comment update for the W lines
* bld.adb: (Expression): An empty string list is static
* fname-uf.adb: Minor comment update
* fname-uf.ads: (Get_File_Name): Document new parameter May_Fail
* gnatbind.adb: Initialize Cumulative_Restrictions with the
restrictions on the target.
2004-02-03 Kazu Hirata <kazu@cs.umass.edu>
* ada/trans.c (gigi): Use gen_rtx_SYMBOL_REF instead of
......
gcc/ada/ali.adb
......@@ -105,8 +105,7 @@ package body ALI is
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
Ignore_Lines : String := "X")
return ALI_Id
Ignore_Lines : String := "X") return ALI_Id
is
P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
......@@ -328,8 +327,10 @@ package body ALI is
-- Get_Name --
--------------
function Get_Name (Lower : Boolean := False;
Ignore_Spaces : Boolean := False) return Name_Id is
function Get_Name
(Lower : Boolean := False;
Ignore_Spaces : Boolean := False) return Name_Id
is
begin
Name_Len := 0;
Skip_Space;
......
gcc/ada/ali.ads
......@@ -814,8 +814,7 @@ package ALI is
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
Ignore_Lines : String := "X")
return ALI_Id;
Ignore_Lines : String := "X") return ALI_Id;
-- Given the text, T, of an ALI file, F, scan and store the information
-- from the file, and return the Id of the resulting entry in the ALI
-- table. Switch settings may be modified as described above in the
......
gcc/ada/bindgen.adb
......@@ -141,6 +141,16 @@ package body Bindgen is
procedure Gen_Output_File_C (Filename : String);
-- Generate output file (C code case)
procedure Gen_Restrictions_String_1;
-- Generate first restrictions string, which consists of the parameters
-- the first R line, as described in lib-writ.ads, with the restrictions
-- being those for the entire partition (from Cumulative_Restrictions).
procedure Gen_Restrictions_String_2;
-- Generate first restrictions string, which consists of the parameters
-- the second R line, as described in lib-writ.ads, with the restrictions
-- being those for the entire partition (from Cumulative_Restrictions).
procedure Gen_Versions_Ada;
-- Output series of definitions for unit versions (Ada code case)
......@@ -358,13 +368,15 @@ package body Bindgen is
Set_String (" Restrictions : constant String :=");
Write_Statement_Buffer;
Set_String (" """);
for J in All_Restrictions loop
null;
end loop;
Set_String (" """);
Gen_Restrictions_String_1;
Set_String (""" &");
Write_Statement_Buffer;
Set_String (""";");
Set_String (" """);
Gen_Restrictions_String_2;
Set_String (""" & ASCII.Nul;");
Write_Statement_Buffer;
WBI ("");
......@@ -606,11 +618,8 @@ package body Bindgen is
-- Generate definition for restrictions string
Set_String (" const char *restrictions = """);
for J in All_Restrictions loop
null;
end loop;
Gen_Restrictions_String_1;
Gen_Restrictions_String_2;
Set_String (""";");
Write_Statement_Buffer;
......@@ -2453,6 +2462,52 @@ package body Bindgen is
Close_Binder_Output;
end Gen_Output_File_C;
-------------------------------
-- Gen_Restrictions_String_1 --
-------------------------------
procedure Gen_Restrictions_String_1 is
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');
end if;
end loop;
end Gen_Restrictions_String_1;
-------------------------------
-- Gen_Restrictions_String_2 --
-------------------------------
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');
end if;
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)));
if Cumulative_Restrictions.Unknown (RP) then
Set_Char ('+');
end if;
end if;
end loop;
end Gen_Restrictions_String_2;
----------------------
-- Gen_Versions_Ada --
----------------------
......
gcc/ada/bld.adb
......@@ -525,11 +525,16 @@ package body Bld is
First_Expression_In_List (Current_Term);
begin
if String_Node /= Empty_Node then
if String_Node = Empty_Node then
-- If String_Node is nil, it is an empty list,
-- there is nothing to do
-- set Expression_Kind if it is still Undecided
if Expression_Kind = Undecided then
Expression_Kind := Static_String;
end if;
else
Expression
(Project => Project,
First_Term => Tree.First_Term (String_Node),
......
gcc/ada/fname-uf.adb
......@@ -387,12 +387,12 @@ package body Fname.UF is
-- If we are in the second search of the table, we accept
-- the file name without checking, because we know that
-- the file does not exist.
-- the file does not exist, except when May_Fail is True,
-- in which case we return No_File.
if No_File_Check then
if May_Fail then
return No_File;
else
return Fnam;
end if;
......
gcc/ada/fname-uf.ads
......@@ -52,6 +52,10 @@ package Fname.UF is
-- false for all other kinds of units. The caller is responsible for
-- ensuring that the unit name meets the requirements given in package
-- Uname and described above.
-- When May_Fail is True, if the file cannot be found, this function
-- returns No_File. When it is False, if the file cannot be found,
-- a file name compatible with one pattern Source_File_Name pragma is
-- returned.
procedure Initialize;
-- Initialize internal tables. This is called automatically when the
......
gcc/ada/gnatbind.adb
......@@ -447,6 +447,12 @@ begin
Targparm.Get_Target_Parameters;
-- Initialize Cumulative_Restrictions with the restrictions on the target
-- scanned from the system.ads file. Then as we read ALI files, we will
-- accumulate additional restrictions specified in other files.
Cumulative_Restrictions := Targparm.Restrictions_On_Target;
-- On OpenVMS, when -L is used, all external names used in pragmas Export
-- are in upper case. The reason is that on OpenVMS, the macro-assembler
-- MACASM-32, used to build Stand-Alone Libraries, only understands
......
gcc/ada/gprcmd.adb
......@@ -113,6 +113,7 @@ procedure Gprcmd is
Put_Line
(Standard_Error,
"bad call to gprcmd with" & Argument_Count'Img & " arguments.");
for J in 0 .. Argument_Count loop
Put (Standard_Error, Argument (J) & " ");
end loop;
......@@ -473,9 +474,9 @@ begin
end if;
end;
else
-- Uknown command
-- Unknown command
else
Check_Args (False);
end if;
end;
......
gcc/ada/impunit.adb
......@@ -297,6 +297,8 @@ package body Impunit is
"s-assert", -- System.Assertions
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-restri", -- System.Restrictions
"s-rident", -- System.Rident
"s-tasinf", -- System.Task_Info
"s-wchcnv", -- System.Wch_Cnv
"s-wchcon"); -- System.Wch_Con
......
gcc/ada/lib-writ.adb
......@@ -691,7 +691,7 @@ package body Lib.Writ is
end loop;
end Write_With_Lines;
-- Start of processing for Writ_ALI
-- Start of processing for Write_ALI
begin
-- We never write an ALI file if the original operating mode was
......@@ -919,7 +919,6 @@ package body Lib.Writ is
then
if not Has_No_Elaboration_Code (Cunit (Unit)) then
Main_Restrictions.Violated (No_Elaboration_Code) := True;
Main_Restrictions.Count (No_Elaboration_Code) := -1;
end if;
end if;
end loop;
......
gcc/ada/lib-writ.ads
......@@ -406,11 +406,13 @@ package Lib.Writ is
-- One of these lines is present for each unit that is mentioned in
-- an explicit with clause by the current unit. The first parameter
-- is the unit name in internal format. The second parameter is the
-- file name of the file that must be compiled to compile this unit
-- (which is usually the file for the body, except for packages
-- which have no body). The third parameter is the file name of the
-- library information file that contains the results of compiling
-- this unit. The optional modifiers are used as follows:
-- file name of the file that must be compiled to compile this unit.
-- It is usually the file for the body, except for packages
-- which have no body; for units that need a body, if the source file
-- for the body cannot be found, the file name of the spec is used
-- instead. The third parameter is the file name of the library
-- information file that contains the results of compiling this unit.
-- The optional modifiers are used as follows:
--
-- E pragma Elaborate applies to this unit
--
......
gcc/ada/restrict.adb
......@@ -372,7 +372,7 @@ package body Restrict is
and then Restrictions.Set (No_Protected_Type_Allocators)
and then Restrictions.Set (No_Local_Protected_Objects)
and then Restrictions.Set (No_Requeue_Statements)
and then Restrictions.Set (No_Task_Attributes)
and then Restrictions.Set (No_Task_Attributes_Package)
and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
and then Restrictions.Set (Max_Task_Entries)
and then Restrictions.Set (Max_Protected_Entries)
......@@ -472,7 +472,7 @@ package body Restrict is
Set_Restriction (No_Protected_Type_Allocators, N);
Set_Restriction (No_Local_Protected_Objects, N);
Set_Restriction (No_Requeue_Statements, N);
Set_Restriction (No_Task_Attributes, N);
Set_Restriction (No_Task_Attributes_Package, N);
-- Set parameter restrictions
......
gcc/ada/restrict.ads
......@@ -92,7 +92,7 @@ package Restrict is
(No_IO, "a-textio"),
(No_IO, "text_io "),
(No_IO, "a-witeio"),
(No_Task_Attributes, "a-tasatt"),
(No_Task_Attributes_Package, "a-tasatt"),
(No_Streams, "a-stream"),
(No_Unchecked_Conversion, "a-unccon"),
(No_Unchecked_Conversion, "unchconv"),
......@@ -123,7 +123,7 @@ package Restrict is
No_Select_Statements => True,
No_Standard_Storage_Pools => True,
No_Streams => True,
No_Task_Attributes => True,
No_Task_Attributes_Package => True,
No_Task_Termination => True,
No_Wide_Characters => True,
Static_Priorities => True,
......
gcc/ada/s-restri.adb
......@@ -40,9 +40,9 @@ package body System.Restrictions is
function Abort_Allowed return Boolean is
begin
return Restrictions.Violated (No_Abort_Statements)
return Run_Time_Restrictions.Violated (No_Abort_Statements)
or else
Restrictions.Violated (Max_Asynchronous_Select_Nesting);
Run_Time_Restrictions.Violated (Max_Asynchronous_Select_Nesting);
end Abort_Allowed;
---------------------
......@@ -51,12 +51,98 @@ package body System.Restrictions is
function Tasking_Allowed return Boolean is
begin
return Restrictions.Violated (Max_Tasks)
return Run_Time_Restrictions.Violated (Max_Tasks)
or else
Restrictions.Violated (No_Tasking);
Run_Time_Restrictions.Violated (No_Tasking);
end Tasking_Allowed;
-- Package elaboration code (acquire restrictions)
begin
null;
Acquire_Restrictions : declare
subtype Big_String is String (Positive);
type Big_String_Ptr is access all Big_String;
RString : Big_String_Ptr;
pragma Import (C, RString, "__gl_restrictions");
P : Natural := 1;
-- Pointer to scan string
C : Character;
-- Next character from string
function Get_Char return Character;
-- Get next character from string
function Get_Natural return Natural;
-- Scan out natural value known to be in range, updating P past it
--------------
-- Get_Char --
--------------
function Get_Char return Character is
begin
P := P + 1;
return RString (P - 1);
end Get_Char;
-----------------
-- Get_Natural --
-----------------
function Get_Natural return Natural is
N : Natural := 0;
begin
while RString (P) in '0' .. '9' loop
N := N * 10 + (Character'Pos (Get_Char) - Character'Pos ('0'));
end loop;
return N;
end Get_Natural;
-- Start of processing for Acquire_Restrictions
begin
-- Acquire data corresponding to first R line
for R in All_Boolean_Restrictions loop
C := Get_Char;
if C = 'v' then
Run_Time_Restrictions.Violated (R) := True;
elsif C = 'r' then
Run_Time_Restrictions.Set (R) := True;
end if;
end loop;
-- Acquire data corresponding to second R line
for RP in All_Parameter_Restrictions loop
-- Acquire restrictions pragma information
if Get_Char = 'r' then
Run_Time_Restrictions.Set (RP) := True;
Run_Time_Restrictions.Value (RP) := Get_Natural;
end if;
-- Acquire restrictions violations information
if Get_Char = 'v' then
Run_Time_Restrictions.Violated (RP) := True;
Run_Time_Restrictions.Count (RP) := Get_Natural;
if RString (P) = '+' then
Run_Time_Restrictions.Unknown (RP) := True;
P := P + 1;
end if;
end if;
end loop;
end Acquire_Restrictions;
end System.Restrictions;
gcc/ada/s-restri.ads
......@@ -39,7 +39,7 @@ package System.Restrictions is
pragma Discard_Names;
package Rident is new System.Rident;
Restrictions : Rident.Restrictions_Info;
Run_Time_Restrictions : Rident.Restrictions_Info;
------------------
-- Subprograms --
......
gcc/ada/s-rident.ads
......@@ -97,7 +97,7 @@ package System.Rident is
No_Standard_Storage_Pools, -- GNAT
No_Streams, -- GNAT
No_Task_Allocators, -- (RM D.7(7))
No_Task_Attributes, -- GNAT
No_Task_Attributes_Package, -- GNAT
No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
No_Task_Termination, -- GNAT (Ravenscar)
No_Tasking, -- GNAT
......@@ -156,6 +156,7 @@ package System.Rident is
-- No_Requeue synonym for No_Requeue_Statements
-- No_Tasking synonym for Max_Tasks => 0
-- No_Task_Attributes synonym for No_Task_Attributes_Package
subtype All_Restrictions is Restriction_Id range
Boolean_Entry_Barriers .. Max_Storage_At_Blocking;
......
gcc/ada/sem_prag.adb
......@@ -3280,6 +3280,15 @@ package body Sem_Prag is
Set_Restriction (No_Requeue_Statements, N);
Set_Warning (No_Requeue_Statements);
-- No_Task_Attributes is a synonym for
-- No_Task_Attributes_Package
elsif Chars (Expr) = Name_No_Task_Attributes then
Check_Restriction
(No_Implementation_Restrictions, Arg);
Set_Restriction (No_Task_Attributes_Package, N);
Set_Warning (No_Task_Attributes_Package);
-- Normal processing for all other cases
else
......@@ -9648,7 +9657,8 @@ package body Sem_Prag is
-- the formal may be wrapped in a conversion if the actual
-- is a conversion. Retrieve the real entity name.
if In_Instance_Body
if (In_Instance_Body
or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
......
gcc/ada/snames.adb
......@@ -335,6 +335,7 @@ package body Snames is
"parameter_types#" &
"reference#" &
"no_requeue#" &
"no_task_attributes#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
......
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