Commit 94d3a18d by Arnaud Charlet

[multiple changes]

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* make.adb, par-ch2.adb, sem_util.adb, scans.ads, sem_ch8.adb,
	scn.adb, osint.adb, fname.adb: Minor reformatting.

2017-04-25  Pascal Obry  <obry@adacore.com>

	* s-taprop-mingw.adb: Do not check for CloseHandle in
	Finalize_TCB.

From-SVN: r247153
parent 51148dda
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com> 2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* make.adb, par-ch2.adb, sem_util.adb, scans.ads, sem_ch8.adb,
scn.adb, osint.adb, fname.adb: Minor reformatting.
2017-04-25 Pascal Obry <obry@adacore.com>
* s-taprop-mingw.adb: Do not check for CloseHandle in
Finalize_TCB.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* sem_util.adb (Check_Part_Of_Reference): * sem_util.adb (Check_Part_Of_Reference):
Continue to examine the context if the reference appears within Continue to examine the context if the reference appears within
an expression function. an expression function.
......
...@@ -57,6 +57,10 @@ package body Fname is ...@@ -57,6 +57,10 @@ package body Fname is
Table_Increment => Alloc.SFN_Table_Increment, Table_Increment => Alloc.SFN_Table_Increment,
Table_Name => "Fname_Dummy_Table"); Table_Name => "Fname_Dummy_Table");
function Has_Internal_Extension (Fname : String) return Boolean;
-- True if the extension is ".ads" or ".adb", as is always the case for
-- internal/predefined units.
function Has_Prefix (X, Prefix : String) return Boolean; function Has_Prefix (X, Prefix : String) return Boolean;
-- True if Prefix is at the beginning of X. For example, -- True if Prefix is at the beginning of X. For example,
-- Has_Prefix("a-filename.ads", Prefix => "a-") is True. -- Has_Prefix("a-filename.ads", Prefix => "a-") is True.
...@@ -64,18 +68,15 @@ package body Fname is ...@@ -64,18 +68,15 @@ package body Fname is
function Has_Suffix (X, Suffix : String) return Boolean; function Has_Suffix (X, Suffix : String) return Boolean;
-- True if Suffix is at the end of X -- True if Suffix is at the end of X
function Has_Internal_Extension (Fname : String) return Boolean;
-- True if the extension is ".ads" or ".adb", as is always the case for
-- internal/predefined units.
---------------------------- ----------------------------
-- Has_Internal_Extension -- -- Has_Internal_Extension --
---------------------------- ----------------------------
function Has_Internal_Extension (Fname : String) return Boolean is function Has_Internal_Extension (Fname : String) return Boolean is
begin begin
return Has_Suffix (Fname, Suffix => ".ads") return
or else Has_Suffix (Fname, Suffix => ".adb"); Has_Suffix (Fname, Suffix => ".ads")
or else Has_Suffix (Fname, Suffix => ".adb");
end Has_Internal_Extension; end Has_Internal_Extension;
---------------- ----------------
...@@ -87,7 +88,7 @@ package body Fname is ...@@ -87,7 +88,7 @@ package body Fname is
if X'Length >= Prefix'Length then if X'Length >= Prefix'Length then
declare declare
Slice : String renames Slice : String renames
X (X'First .. X'First + Prefix'Length - 1); X (X'First .. X'First + Prefix'Length - 1);
begin begin
return Slice = Prefix; return Slice = Prefix;
end; end;
...@@ -104,7 +105,7 @@ package body Fname is ...@@ -104,7 +105,7 @@ package body Fname is
if X'Length >= Suffix'Length then if X'Length >= Suffix'Length then
declare declare
Slice : String renames Slice : String renames
X (X'Last - Suffix'Length + 1 .. X'Last); X (X'Last - Suffix'Length + 1 .. X'Last);
begin begin
return Slice = Suffix; return Slice = Suffix;
end; end;
...@@ -118,7 +119,8 @@ package body Fname is ...@@ -118,7 +119,8 @@ package body Fname is
function Is_Internal_File_Name function Is_Internal_File_Name
(Fname : String; (Fname : String;
Renamings_Included : Boolean := True) return Boolean is Renamings_Included : Boolean := True) return Boolean
is
begin begin
-- Check for internal extensions first, so we don't think (e.g.) -- Check for internal extensions first, so we don't think (e.g.)
-- "gnat.adc" is internal. -- "gnat.adc" is internal.
...@@ -127,9 +129,10 @@ package body Fname is ...@@ -127,9 +129,10 @@ package body Fname is
return False; return False;
end if; end if;
return Is_Predefined_File_Name (Fname, Renamings_Included) return
or else Has_Prefix (Fname, Prefix => "g-") Is_Predefined_File_Name (Fname, Renamings_Included)
or else Has_Prefix (Fname, Prefix => "gnat.ad"); or else Has_Prefix (Fname, Prefix => "g-")
or else Has_Prefix (Fname, Prefix => "gnat.ad");
end Is_Internal_File_Name; end Is_Internal_File_Name;
function Is_Internal_File_Name function Is_Internal_File_Name
...@@ -137,8 +140,9 @@ package body Fname is ...@@ -137,8 +140,9 @@ package body Fname is
Renamings_Included : Boolean := True) return Boolean Renamings_Included : Boolean := True) return Boolean
is is
begin begin
return Is_Internal_File_Name return
(Get_Name_String (Fname), Renamings_Included); Is_Internal_File_Name
(Get_Name_String (Fname), Renamings_Included);
end Is_Internal_File_Name; end Is_Internal_File_Name;
----------------------------- -----------------------------
...@@ -147,7 +151,8 @@ package body Fname is ...@@ -147,7 +151,8 @@ package body Fname is
function Is_Predefined_File_Name function Is_Predefined_File_Name
(Fname : String; (Fname : String;
Renamings_Included : Boolean := True) return Boolean is Renamings_Included : Boolean := True) return Boolean
is
begin begin
if not Has_Internal_Extension (Fname) then if not Has_Internal_Extension (Fname) then
return False; return False;
...@@ -166,9 +171,9 @@ package body Fname is ...@@ -166,9 +171,9 @@ package body Fname is
return False; return False;
end if; end if;
if Has_Prefix (Fname, Prefix => "ada.ad") -- Ada if Has_Prefix (Fname, Prefix => "ada.ad") -- Ada
or else Has_Prefix (Fname, Prefix => "interfac.ad") -- Interfaces or else Has_Prefix (Fname, Prefix => "interfac.ad") -- Interfaces
or else Has_Prefix (Fname, Prefix => "system.ad") -- System or else Has_Prefix (Fname, Prefix => "system.ad") -- System
then then
return True; return True;
end if; end if;
...@@ -179,16 +184,38 @@ package body Fname is ...@@ -179,16 +184,38 @@ package body Fname is
-- The following are the predefined renamings -- The following are the predefined renamings
return Has_Prefix (Fname, Prefix => "calendar.ad") -- Calendar return
or else Has_Prefix (Fname, Prefix => "machcode.ad") -- Machine_Code -- Calendar
or else Has_Prefix (Fname, Prefix => "unchconv.ad")
Has_Prefix (Fname, Prefix => "calendar.ad")
-- Machine_Code
or else Has_Prefix (Fname, Prefix => "machcode.ad")
-- Unchecked_Conversion -- Unchecked_Conversion
or else Has_Prefix (Fname, Prefix => "unchdeal.ad")
or else Has_Prefix (Fname, Prefix => "unchconv.ad")
-- Unchecked_Deallocation -- Unchecked_Deallocation
or else Has_Prefix (Fname, Prefix => "directio.ad") -- Direct_IO
or else Has_Prefix (Fname, Prefix => "ioexcept.ad") -- IO_Exceptions or else Has_Prefix (Fname, Prefix => "unchdeal.ad")
or else Has_Prefix (Fname, Prefix => "sequenio.ad") -- Sequential_IO
or else Has_Prefix (Fname, Prefix => "text_io.ad"); -- Text_IO -- Direct_IO
or else Has_Prefix (Fname, Prefix => "directio.ad")
-- IO_Exceptions
or else Has_Prefix (Fname, Prefix => "ioexcept.ad")
-- Sequential_IO
or else Has_Prefix (Fname, Prefix => "sequenio.ad")
-- Text_IO
or else Has_Prefix (Fname, Prefix => "text_io.ad");
end Is_Predefined_File_Name; end Is_Predefined_File_Name;
function Is_Predefined_File_Name function Is_Predefined_File_Name
...@@ -196,8 +223,9 @@ package body Fname is ...@@ -196,8 +223,9 @@ package body Fname is
Renamings_Included : Boolean := True) return Boolean Renamings_Included : Boolean := True) return Boolean
is is
begin begin
return Is_Predefined_File_Name return
(Get_Name_String (Fname), Renamings_Included); Is_Predefined_File_Name
(Get_Name_String (Fname), Renamings_Included);
end Is_Predefined_File_Name; end Is_Predefined_File_Name;
--------------- ---------------
......
...@@ -2945,7 +2945,7 @@ package body Make is ...@@ -2945,7 +2945,7 @@ package body Make is
begin begin
if Is_Predefined_File_Name if Is_Predefined_File_Name
(Fname, Renamings_Included => False) (Fname, Renamings_Included => False)
then then
if Check_Readonly_Files or else Must_Compile then if Check_Readonly_Files or else Must_Compile then
Comp_Args (Comp_Args'First + 2 .. Comp_Last + 1) := Comp_Args (Comp_Args'First + 2 .. Comp_Last + 1) :=
......
...@@ -1187,7 +1187,7 @@ package body Osint is ...@@ -1187,7 +1187,7 @@ package body Osint is
and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg") and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg")
then then
Found := N; Found := N;
Attr.all := Unknown_Attributes; Attr.all := Unknown_Attributes;
if T = Config then if T = Config then
if Full_Name then if Full_Name then
...@@ -1199,7 +1199,7 @@ package body Osint is ...@@ -1199,7 +1199,7 @@ package body Osint is
begin begin
Name_Buffer (1 .. Full_Size) := Full_Path; Name_Buffer (1 .. Full_Size) := Full_Path;
Name_Len := Full_Size; Name_Len := Full_Size;
Found := Name_Find; Found := Name_Find;
end; end;
end if; end if;
......
...@@ -224,26 +224,6 @@ package body Ch2 is ...@@ -224,26 +224,6 @@ package body Ch2 is
-- in fact the bodies ARE present, supplied by these pragmas. -- in fact the bodies ARE present, supplied by these pragmas.
function P_Pragma (Skipping : Boolean := False) return Node_Id is function P_Pragma (Skipping : Boolean := False) return Node_Id is
Interface_Check_Required : Boolean := False;
-- Set True if check of pragma INTERFACE is required
Import_Check_Required : Boolean := False;
-- Set True if check of pragma IMPORT is required
Arg_Count : Nat := 0;
-- Number of argument associations processed
Identifier_Seen : Boolean := False;
-- Set True if an identifier is encountered for a pragma argument. Used
-- to check that there are no more arguments without identifiers.
Prag_Node : Node_Id;
Prag_Name : Name_Id;
Semicolon_Loc : Source_Ptr;
Ident_Node : Node_Id;
Assoc_Node : Node_Id;
Result : Node_Id;
procedure Skip_Pragma_Semicolon; procedure Skip_Pragma_Semicolon;
-- Skip past semicolon at end of pragma -- Skip past semicolon at end of pragma
...@@ -265,6 +245,28 @@ package body Ch2 is ...@@ -265,6 +245,28 @@ package body Ch2 is
end if; end if;
end Skip_Pragma_Semicolon; end Skip_Pragma_Semicolon;
-- Local variables
Interface_Check_Required : Boolean := False;
-- Set True if check of pragma INTERFACE is required
Import_Check_Required : Boolean := False;
-- Set True if check of pragma IMPORT is required
Arg_Count : Nat := 0;
-- Number of argument associations processed
Identifier_Seen : Boolean := False;
-- Set True if an identifier is encountered for a pragma argument. Used
-- to check that there are no more arguments without identifiers.
Assoc_Node : Node_Id;
Ident_Node : Node_Id;
Prag_Name : Name_Id;
Prag_Node : Node_Id;
Result : Node_Id;
Semicolon_Loc : Source_Ptr;
-- Start of processing for P_Pragma -- Start of processing for P_Pragma
begin begin
...@@ -366,8 +368,8 @@ package body Ch2 is ...@@ -366,8 +368,8 @@ package body Ch2 is
-- Cancel indication of being within a pragma or in particular a Depends -- Cancel indication of being within a pragma or in particular a Depends
-- pragma. -- pragma.
Inside_Pragma := False;
Inside_Depends := False; Inside_Depends := False;
Inside_Pragma := False;
-- Now we have two tasks left, we need to scan out the semicolon -- Now we have two tasks left, we need to scan out the semicolon
-- following the pragma, and we have to call Par.Prag to process -- following the pragma, and we have to call Par.Prag to process
...@@ -390,10 +392,12 @@ package body Ch2 is ...@@ -390,10 +392,12 @@ package body Ch2 is
Skip_Pragma_Semicolon; Skip_Pragma_Semicolon;
return Par.Prag (Prag_Node, Semicolon_Loc); return Par.Prag (Prag_Node, Semicolon_Loc);
end if; end if;
exception exception
when Error_Resync => when Error_Resync =>
Resync_Past_Semicolon; Resync_Past_Semicolon;
Inside_Pragma := False; Inside_Depends := False;
Inside_Pragma := False;
return Error; return Error;
end P_Pragma; end P_Pragma;
......
...@@ -958,6 +958,7 @@ package body System.Task_Primitives.Operations is ...@@ -958,6 +958,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_TCB (T : Task_Id) is procedure Finalize_TCB (T : Task_Id) is
Succeeded : BOOL; Succeeded : BOOL;
pragma Unreferenced (Succeeded);
begin begin
if not Single_Lock then if not Single_Lock then
...@@ -976,7 +977,10 @@ package body System.Task_Primitives.Operations is ...@@ -976,7 +977,10 @@ package body System.Task_Primitives.Operations is
-- is needed to release system resources. -- is needed to release system resources.
Succeeded := CloseHandle (T.Common.LL.Thread); Succeeded := CloseHandle (T.Common.LL.Thread);
pragma Assert (Succeeded = Win32.TRUE); -- Note that we do not check for the returned value, this is
-- because the above call will fail for a foreign thread. But
-- we still need to call it to properly close Ada tasks created
-- with CreateThread() in Create_Task above.
end if; end if;
ATCB_Allocation.Free_ATCB (T); ATCB_Allocation.Free_ATCB (T);
......
...@@ -484,10 +484,6 @@ package Scans is ...@@ -484,10 +484,6 @@ package Scans is
-- Is it really right for this to be a Name rather than a String, what -- Is it really right for this to be a Name rather than a String, what
-- about the case of Wide_Wide_Characters??? -- about the case of Wide_Wide_Characters???
Inside_Pragma : Boolean := False;
-- True within a pragma. Used to avoid complaining about reserved words
-- within pragmas (see Scan_Reserved_Identifier).
Inside_Depends : Boolean := False; Inside_Depends : Boolean := False;
-- True while parsing the argument of a Depends pragma or aspect (used to -- True while parsing the argument of a Depends pragma or aspect (used to
-- allow/require non-standard style rules for =>+ with -gnatyt). -- allow/require non-standard style rules for =>+ with -gnatyt).
...@@ -497,6 +493,10 @@ package Scans is ...@@ -497,6 +493,10 @@ package Scans is
-- expression (incremented on entry, decremented on exit). It is used to -- expression (incremented on entry, decremented on exit). It is used to
-- disconnect format checks that normally apply to keywords THEN, ELSE etc. -- disconnect format checks that normally apply to keywords THEN, ELSE etc.
Inside_Pragma : Boolean := False;
-- True within a pragma. Used to avoid complaining about reserved words
-- within pragmas (see Scan_Reserved_Identifier).
-------------------------------------------------------- --------------------------------------------------------
-- Procedures for Saving and Restoring the Scan State -- -- Procedures for Saving and Restoring the Scan State --
-------------------------------------------------------- --------------------------------------------------------
......
...@@ -378,8 +378,9 @@ package body Scn is ...@@ -378,8 +378,9 @@ package body Scn is
------------------------------ ------------------------------
procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is
Token_Chars : String := Token_Type'Image (Token); Token_Chars : String := Token_Type'Image (Token);
Len : Natural := 0; Len : Natural := 0;
begin begin
-- AI12-0125 : '@' denotes the target_name, i.e. serves as an -- AI12-0125 : '@' denotes the target_name, i.e. serves as an
-- abbreviation for the LHS of an assignment. -- abbreviation for the LHS of an assignment.
......
...@@ -3632,9 +3632,9 @@ package body Sem_Ch8 is ...@@ -3632,9 +3632,9 @@ package body Sem_Ch8 is
if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
and then Get_Name_String and then Get_Name_String
(Unit_File_Name (Current_Sem_Unit)) (1 .. 3) /= "a-n" (Unit_File_Name (Current_Sem_Unit)) (1 .. 3) /= "a-n"
and then and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration N_Package_Declaration
then then
Error_Msg_N ("use clause not allowed in predefined spec", N); Error_Msg_N ("use clause not allowed in predefined spec", N);
end if; end if;
......
...@@ -20517,8 +20517,9 @@ package body Sem_Util is ...@@ -20517,8 +20517,9 @@ package body Sem_Util is
function Should_Ignore_Pragma (Prag_Name : Name_Id) return Boolean is function Should_Ignore_Pragma (Prag_Name : Name_Id) return Boolean is
begin begin
return not Is_Internal_File_Name (File_Name (Current_Source_File)) return
and then Get_Name_Table_Boolean3 (Prag_Name); not Is_Internal_File_Name (File_Name (Current_Source_File))
and then Get_Name_Table_Boolean3 (Prag_Name);
end Should_Ignore_Pragma; end Should_Ignore_Pragma;
-------------------- --------------------
......
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