Commit e64e5f74 by Arnaud Charlet

[multiple changes]

2009-11-30  Sergey Rybin  <rybin@adacore.com>

	* gnat_ugn.texi: Update gnatcheck doc.

2009-11-30  Robert Dewar  <dewar@adacore.com>

	make.adb, prj-makr.adb, g-sothco.ads: Minor reformattting
	* s-taprop-dummy.adb: Minor code reorganization (raise with msgs start
	with lower case).
	* i-vxwoio.adb, g-dirope.adb, g-sercom-linux.adb,
	g-enblsp-vms-alpha.adb, g-regist.adb, s-imgcha.adb, s-tarest.adb,
	s-taprop-mingw.adb, g-exctra.adb, g-expect.adb, g-comlin.adb,
	g-debpoo.adb, g-expect-vms.adb, g-pehage.adb, g-trasym-vms-alpha.adb,
	g-enblsp-vms-ia64.adb, s-fatgen.adb, s-fileio.adb: Minor code
	reorganization (use conditional expressions).

From-SVN: r154773
parent ff149a35
2009-11-30 Sergey Rybin <rybin@adacore.com>
* gnat_ugn.texi: Update gnatcheck doc.
2009-11-30 Robert Dewar <dewar@adacore.com>
make.adb, prj-makr.adb, g-sothco.ads: Minor reformattting
* s-taprop-dummy.adb: Minor code reorganization (raise with msgs start
with lower case).
* i-vxwoio.adb, g-dirope.adb, g-sercom-linux.adb,
g-enblsp-vms-alpha.adb, g-regist.adb, s-imgcha.adb, s-tarest.adb,
s-taprop-mingw.adb, g-exctra.adb, g-expect.adb, g-comlin.adb,
g-debpoo.adb, g-expect-vms.adb, g-pehage.adb, g-trasym-vms-alpha.adb,
g-enblsp-vms-ia64.adb, s-fatgen.adb, s-fileio.adb: Minor code
reorganization (use conditional expressions).
2009-11-30 Vincent Celier <celier@adacore.com> 2009-11-30 Vincent Celier <celier@adacore.com>
* prj-makr.adb (Source_Files): New hash table to keep track of source * prj-makr.adb (Source_Files): New hash table to keep track of source
......
...@@ -574,11 +574,8 @@ package body GNAT.Command_Line is ...@@ -574,11 +574,8 @@ package body GNAT.Command_Line is
-- Depending on the value of Concatenate, the full switch is -- Depending on the value of Concatenate, the full switch is
-- a single character or the rest of the argument. -- a single character or the rest of the argument.
if Concatenate then End_Index :=
End_Index := Parser.Current_Index; (if Concatenate then Parser.Current_Index else Arg'Last);
else
End_Index := Arg'Last;
end if;
if Switches (Switches'First) = '*' then if Switches (Switches'First) = '*' then
...@@ -2279,20 +2276,16 @@ package body GNAT.Command_Line is ...@@ -2279,20 +2276,16 @@ package body GNAT.Command_Line is
Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range); Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range);
for E in Cmd.Sections'Range loop for E in Cmd.Sections'Range loop
if Cmd.Sections (E) = null then Cmd.Coalesce_Sections (E) :=
Cmd.Coalesce_Sections (E) := null; (if Cmd.Sections (E) = null then null
else else new String'(Cmd.Sections (E).all));
Cmd.Coalesce_Sections (E) := new String'(Cmd.Sections (E).all);
end if;
end loop; end loop;
Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range); Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range);
for E in Cmd.Params'Range loop for E in Cmd.Params'Range loop
if Cmd.Params (E) = null then Cmd.Coalesce_Params (E) :=
Cmd.Coalesce_Params (E) := null; (if Cmd.Params (E) = null then null
else else new String'(Cmd.Params (E).all));
Cmd.Coalesce_Params (E) := new String'(Cmd.Params (E).all);
end if;
end loop; end loop;
-- Not a clone, since we will not modify the parameters anyway -- Not a clone, since we will not modify the parameters anyway
......
...@@ -985,11 +985,7 @@ package body GNAT.Debug_Pools is ...@@ -985,11 +985,7 @@ package body GNAT.Debug_Pools is
is is
begin begin
if H.Block_Size /= 0 then if H.Block_Size /= 0 then
if In_Use then To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark);
To_Byte (A).all := In_Use_Mark;
else
To_Byte (A).all := Free_Mark;
end if;
end if; end if;
end Mark; end Mark;
...@@ -1416,11 +1412,8 @@ package body GNAT.Debug_Pools is ...@@ -1416,11 +1412,8 @@ package body GNAT.Debug_Pools is
Backtrace_Htable_Cumulate.Set (Elem); Backtrace_Htable_Cumulate.Set (Elem);
if Cumulate then if Cumulate then
if Data.Kind = Alloc then K := (if Data.Kind = Alloc then Indirect_Alloc
K := Indirect_Alloc; else Indirect_Dealloc);
else
K := Indirect_Dealloc;
end if;
-- Propagate the direct call to all its parents -- Propagate the direct call to all its parents
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2008, AdaCore -- -- Copyright (C) 1998-2009, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -97,12 +97,7 @@ package body GNAT.Directory_Operations is ...@@ -97,12 +97,7 @@ package body GNAT.Directory_Operations is
begin begin
-- Cut_Start point to the first basename character -- Cut_Start point to the first basename character
if Cut_Start = 0 then Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
Cut_Start := Path'First;
else
Cut_Start := Cut_Start + 1;
end if;
-- Cut_End point to the last basename character -- Cut_End point to the last basename character
...@@ -580,11 +575,8 @@ package body GNAT.Directory_Operations is ...@@ -580,11 +575,8 @@ package body GNAT.Directory_Operations is
begin begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Dir'Length > Path_Len then Last :=
Last := Dir'First + Path_Len - 1; (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);
else
Last := Dir'Last;
end if;
Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
...@@ -683,11 +675,9 @@ package body GNAT.Directory_Operations is ...@@ -683,11 +675,9 @@ package body GNAT.Directory_Operations is
return; return;
end if; end if;
if Str'Length > Filename_Len then Last :=
Last := Str'First + Filename_Len - 1; (if Str'Length > Filename_Len then Str'First + Filename_Len - 1
else else Str'Last);
Last := Str'Last;
end if;
declare declare
subtype Path_String is String (1 .. Filename_Len); subtype Path_String is String (1 .. Filename_Len);
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2005-2008, AdaCore -- -- Copyright (C) 2005-2009, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -77,11 +77,9 @@ begin ...@@ -77,11 +77,9 @@ begin
-- Fork a new process (it is not possible to do this in a subprogram) -- Fork a new process (it is not possible to do this in a subprogram)
if Alloc_Vfork_Blocks >= 0 then Descriptor.Pid :=
Descriptor.Pid := Get_Current_Invo_Context (Get_Vfork_Jmpbuf); (if Alloc_Vfork_Blocks >= 0
else then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1);
Descriptor.Pid := -1;
end if;
-- Are we now in the child -- Are we now in the child
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2005-2008, AdaCore -- -- Copyright (C) 2005-2009, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -75,11 +75,8 @@ begin ...@@ -75,11 +75,8 @@ begin
-- Fork a new process (it is not possible to do this in a subprogram) -- Fork a new process (it is not possible to do this in a subprogram)
if Alloc_Vfork_Blocks >= 0 then Descriptor.Pid :=
Descriptor.Pid := Setjmp1 (Get_Vfork_Jmpbuf); (if Alloc_Vfork_Blocks >= 0 then Setjmp1 (Get_Vfork_Jmpbuf) else -1);
else
Descriptor.Pid := -1;
end if;
-- Are we now in the child -- Are we now in the child
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2000-2005, AdaCore -- -- Copyright (C) 2000-2009, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -88,17 +88,11 @@ package body GNAT.Exception_Traces is ...@@ -88,17 +88,11 @@ package body GNAT.Exception_Traces is
procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is
begin begin
Current_Decorator := Decorator; Current_Decorator := Decorator;
Traceback_Decorator_Wrapper :=
if Current_Decorator /= null then (if Current_Decorator /= null
Traceback_Decorator_Wrapper := Decorator_Wrapper'Access; then Decorator_Wrapper'Access else null);
else
Traceback_Decorator_Wrapper := null;
end if;
end Set_Trace_Decorator; end Set_Trace_Decorator;
-- Trace_On/Trace_Off control the kind of automatic output to occur
-- by way of the global Exception_Trace variable.
--------------- ---------------
-- Trace_Off -- -- Trace_Off --
--------------- ---------------
......
...@@ -1030,11 +1030,7 @@ package body GNAT.Expect is ...@@ -1030,11 +1030,7 @@ package body GNAT.Expect is
Reinitialize_Buffer (Descriptor); Reinitialize_Buffer (Descriptor);
end if; end if;
if Add_LF then Last := (if Add_LF then Full_Str'Last else Full_Str'Last - 1);
Last := Full_Str'Last;
else
Last := Full_Str'Last - 1;
end if;
Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
......
...@@ -1003,11 +1003,10 @@ package body GNAT.Expect is ...@@ -1003,11 +1003,10 @@ package body GNAT.Expect is
-- Prepare low-level argument list from the normalized arguments -- Prepare low-level argument list from the normalized arguments
for K in Arg_List'Range loop for K in Arg_List'Range loop
if Arg_List (K) /= null then C_Arg_List (K) :=
C_Arg_List (K) := Arg_List (K).all'Address; (if Arg_List (K) /= null
else then Arg_List (K).all'Address
C_Arg_List (K) := System.Null_Address; else System.Null_Address);
end if;
end loop; end loop;
-- This does not return on Unix systems -- This does not return on Unix systems
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2002-2008, AdaCore -- -- Copyright (C) 2002-2009, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1970,11 +1970,7 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -1970,11 +1970,7 @@ package body GNAT.Perfect_Hash_Generators is
Q := Seed / 127773; Q := Seed / 127773;
X := 16807 * R - 2836 * Q; X := 16807 * R - 2836 * Q;
if X < 0 then Seed := (if X < 0 then X + 2147483647 else X);
Seed := X + 2147483647;
else
Seed := X;
end if;
end Random; end Random;
------------- -------------
...@@ -2233,11 +2229,8 @@ package body GNAT.Perfect_Hash_Generators is ...@@ -2233,11 +2229,8 @@ package body GNAT.Perfect_Hash_Generators is
-- The first position should not exceed the minimum key length. -- The first position should not exceed the minimum key length.
-- Otherwise, we may end up with an empty word once reduced. -- Otherwise, we may end up with an empty word once reduced.
if Last_Sel_Pos = 0 then Max_Sel_Pos :=
Max_Sel_Pos := Min_Key_Len; (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
else
Max_Sel_Pos := Max_Key_Len;
end if;
-- Find which position increases more the number of differences -- Find which position increases more the number of differences
......
...@@ -417,11 +417,7 @@ package body GNAT.Registry is ...@@ -417,11 +417,7 @@ package body GNAT.Registry is
Result : LONG; Result : LONG;
begin begin
if Expand then Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ);
Value_Type := REG_EXPAND_SZ;
else
Value_Type := REG_SZ;
end if;
Result := Result :=
RegSetValueEx RegSetValueEx
......
...@@ -211,7 +211,10 @@ package body GNAT.Serial_Communications is ...@@ -211,7 +211,10 @@ package body GNAT.Serial_Communications is
pragma Import (C, tcflush, "tcflush"); pragma Import (C, tcflush, "tcflush");
Current : termios; Current : termios;
Res : int;
Res : int;
pragma Warnings (Off, Res);
-- Warnings off, since we don't always test the result
begin begin
if Port.H = null then if Port.H = null then
...@@ -246,11 +249,7 @@ package body GNAT.Serial_Communications is ...@@ -246,11 +249,7 @@ package body GNAT.Serial_Communications is
-- Block -- Block
if Block then Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
Res := fcntl (int (Port.H.all), F_SETFL, 0);
else
Res := fcntl (int (Port.H.all), F_SETFL, FNDELAY);
end if;
if Res = -1 then if Res = -1 then
Raise_Error ("set: fcntl failed"); Raise_Error ("set: fcntl failed");
......
...@@ -212,8 +212,8 @@ package GNAT.Sockets.Thin_Common is ...@@ -212,8 +212,8 @@ package GNAT.Sockets.Thin_Common is
C.Strings.Null_Ptr); C.Strings.Null_Ptr);
-- Arrays of C (char *) -- Arrays of C (char *)
type Servent is new System.Storage_Elements.Storage_Array type Servent is new
(1 .. SOSC.SIZEOF_struct_servent); System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_servent);
for Servent'Alignment use 8; for Servent'Alignment use 8;
-- Service entry. This is an opaque type used only via the following -- Service entry. This is an opaque type used only via the following
-- accessor functions, because 'struct servent' has different layouts on -- accessor functions, because 'struct servent' has different layouts on
...@@ -223,11 +223,14 @@ package GNAT.Sockets.Thin_Common is ...@@ -223,11 +223,14 @@ package GNAT.Sockets.Thin_Common is
pragma Convention (C, Servent_Access); pragma Convention (C, Servent_Access);
-- Access to service entry -- Access to service entry
function Servent_S_Name (E : Servent_Access) return C.Strings.chars_ptr; function Servent_S_Name
function Servent_S_Aliases (E : Servent_Access) (E : Servent_Access) return C.Strings.chars_ptr;
return Chars_Ptr_Pointers.Pointer; function Servent_S_Aliases
function Servent_S_Port (E : Servent_Access) return C.int; (E : Servent_Access) return Chars_Ptr_Pointers.Pointer;
function Servent_S_Proto (E : Servent_Access) return C.Strings.chars_ptr; function Servent_S_Port
(E : Servent_Access) return C.int;
function Servent_S_Proto
(E : Servent_Access) return C.Strings.chars_ptr;
------------------ ------------------
-- Host entries -- -- Host entries --
......
...@@ -217,11 +217,9 @@ package body GNAT.Traceback.Symbolic is ...@@ -217,11 +217,9 @@ package body GNAT.Traceback.Symbolic is
System.Soft_Links.Lock_Task.all; System.Soft_Links.Lock_Task.all;
for J in Traceback'Range loop for J in Traceback'Range loop
if J = Traceback'Last then Return_Address :=
Return_Address := Address_Zero; (if J = Traceback'Last then Address_Zero
else else PC_For (Traceback (J + 1)));
Return_Address := PC_For (Traceback (J + 1));
end if;
Symbolize Symbolize
(Status, (Status,
......
...@@ -22519,7 +22519,9 @@ This rule has no parameters. ...@@ -22519,7 +22519,9 @@ This rule has no parameters.
@cindex @code{Positional_Generic_Parameters} rule (for @command{gnatcheck}) @cindex @code{Positional_Generic_Parameters} rule (for @command{gnatcheck})
@noindent @noindent
Flag each instantiation using positional parameter notation. Flag each positional actual generic parameter except for the case when
the generic unit being iinstantiated has exactly one generic formal
parameter.
This rule has no parameters. This rule has no parameters.
...@@ -22529,15 +22531,15 @@ This rule has no parameters. ...@@ -22529,15 +22531,15 @@ This rule has no parameters.
@cindex @code{Positional_Parameters} rule (for @command{gnatcheck}) @cindex @code{Positional_Parameters} rule (for @command{gnatcheck})
@noindent @noindent
Flag each subprogram or entry call using positional parameter notation, Flag each positional parameter notation in a subprogram or entry call,
except for the following: except for the following:
@itemize @bullet @itemize @bullet
@item @item
Invocations of prefix or infix operators are not flagged Parameters of calls to of prefix or infix operators are not flagged
@item @item
If the called subprogram or entry has only one formal parameter, If the called subprogram or entry has only one formal parameter,
the call is not flagged; the parameter of the call is not flagged;
@item @item
If a subprogram call uses the @emph{Object.Operation} notation, then If a subprogram call uses the @emph{Object.Operation} notation, then
@itemize @minus @itemize @minus
...@@ -63,16 +63,10 @@ package body Interfaces.VxWorks.IO is ...@@ -63,16 +63,10 @@ package body Interfaces.VxWorks.IO is
is is
Status : int; Status : int;
Fd : int; Fd : int;
begin begin
Fd := fileno (File); Fd := fileno (File);
Status := ioctl (Fd, FIOSETOPTIONS, OPT_TERMINAL); Status := ioctl (Fd, FIOSETOPTIONS, OPT_TERMINAL);
Success := (if Status /= int (ERROR) then True else False);
if Status /= int (ERROR) then
Success := True;
else
Success := False;
end if;
end Disable_Get_Immediate; end Disable_Get_Immediate;
end Interfaces.VxWorks.IO; end Interfaces.VxWorks.IO;
...@@ -3427,8 +3427,8 @@ package body Make is ...@@ -3427,8 +3427,8 @@ package body Make is
end if; end if;
-- Start the compilation and record it. We can do this -- Start the compilation and record it. We can do this
-- because there is at least one free process. This -- because there is at least one free process. This might
-- might change the current directory. -- change the current directory.
Collect_Arguments_And_Compile Collect_Arguments_And_Compile
(Full_Source_File => Full_Source_File, (Full_Source_File => Full_Source_File,
......
...@@ -39,7 +39,7 @@ with Table; use Table; ...@@ -39,7 +39,7 @@ with Table; use Table;
with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Characters.Handling; use Ada.Characters.Handling;
with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with System.Case_Util; use System.Case_Util; with System.Case_Util; use System.Case_Util;
with System.CRTL; with System.CRTL;
with System.HTable; with System.HTable;
...@@ -613,13 +613,14 @@ package body Prj.Makr is ...@@ -613,13 +613,14 @@ package body Prj.Makr is
In_Tree => Tree); In_Tree => Tree);
begin begin
-- Add source file name to the source list file, if it is not -- Add source file name to the source list file if it is not
-- already there. -- already there.
if not Source_Files.Get (Current_Source.File_Name) then if not Source_Files.Get (Current_Source.File_Name) then
Source_Files.Set (Current_Source.File_Name, True); Source_Files.Set (Current_Source.File_Name, True);
Get_Name_String (Current_Source.File_Name); Get_Name_String (Current_Source.File_Name);
Add_Char_To_Name_Buffer (ASCII.LF); Add_Char_To_Name_Buffer (ASCII.LF);
if Write (Source_List_FD, if Write (Source_List_FD,
Name_Buffer (1)'Address, Name_Buffer (1)'Address,
Name_Len) /= Name_Len Name_Len) /= Name_Len
......
...@@ -232,12 +232,7 @@ package body System.Fat_Gen is ...@@ -232,12 +232,7 @@ package body System.Fat_Gen is
end loop; end loop;
end if; end if;
if X > 0.0 then Frac := (if X > 0.0 then Ax else -Ax);
Frac := Ax;
else
Frac := -Ax;
end if;
Expo := Ex; Expo := Ex;
end; end;
end if; end if;
......
...@@ -519,27 +519,17 @@ package body System.File_IO is ...@@ -519,27 +519,17 @@ package body System.File_IO is
end if; end if;
when Inout_File | Append_File => when Inout_File | Append_File =>
if Creat then Fopstr (1) := (if Creat then 'w' else 'r');
Fopstr (1) := 'w';
else
Fopstr (1) := 'r';
end if;
Fopstr (2) := '+'; Fopstr (2) := '+';
Fptr := 3; Fptr := 3;
end case; end case;
-- If text_translation_required is true then we need to append -- If text_translation_required is true then we need to append either a
-- either a t or b to the string to get the right mode -- "t" or "b" to the string to get the right mode.
if text_translation_required then if text_translation_required then
if Text then Fopstr (Fptr) := (if Text then 't' else 'b');
Fopstr (Fptr) := 't';
else
Fopstr (Fptr) := 'b';
end if;
Fptr := Fptr + 1; Fptr := Fptr + 1;
end if; end if;
......
...@@ -124,22 +124,13 @@ package body System.Img_Char is ...@@ -124,22 +124,13 @@ package body System.Img_Char is
if V in C0_Range then if V in C0_Range then
S (1 .. 3) := C0 (V); S (1 .. 3) := C0 (V);
P := (if S (3) = ' ' then 2 else 3);
if S (3) = ' ' then
P := 2;
else
P := 3;
end if;
elsif V in C1_Range then elsif V in C1_Range then
S (1 .. 3) := C1 (V); S (1 .. 3) := C1 (V);
if S (1) /= 'r' then if S (1) /= 'r' then
if S (3) = ' ' then P := (if S (3) = ' ' then 2 else 3);
P := 2;
else
P := 3;
end if;
-- Special case, res means RESERVED_nnn where nnn is the three digit -- Special case, res means RESERVED_nnn where nnn is the three digit
-- decimal value corresponding to the code position (more efficient -- decimal value corresponding to the code position (more efficient
......
...@@ -190,7 +190,7 @@ package body System.Task_Primitives.Operations is ...@@ -190,7 +190,7 @@ package body System.Task_Primitives.Operations is
procedure Initialize (Environment_Task : Task_Id) is procedure Initialize (Environment_Task : Task_Id) is
No_Tasking : Boolean; No_Tasking : Boolean;
begin begin
raise Program_Error with "Tasking not implemented on this configuration"; raise Program_Error with "tasking not implemented on this configuration";
end Initialize; end Initialize;
procedure Initialize (S : in out Suspension_Object) is procedure Initialize (S : in out Suspension_Object) is
......
...@@ -312,18 +312,17 @@ package body System.Task_Primitives.Operations is ...@@ -312,18 +312,17 @@ package body System.Task_Primitives.Operations is
Unlock (L, Global_Lock => True); Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled, -- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block -- WaitForSingleObject will simply not block.
if Rel_Time <= 0.0 then if Rel_Time <= 0.0 then
Timed_Out := True; Timed_Out := True;
Wait_Result := 0; Wait_Result := 0;
else else
if Rel_Time >= Duration (Time_Out_Max) / 1000 then Time_Out :=
Time_Out := Time_Out_Max; (if Rel_Time >= Duration (Time_Out_Max) / 1000
else then Time_Out_Max
Time_Out := DWORD (Rel_Time * 1000); else DWORD (Rel_Time * 1000));
end if;
Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
......
...@@ -340,11 +340,10 @@ package body System.Tasking.Restricted.Stages is ...@@ -340,11 +340,10 @@ package body System.Tasking.Restricted.Stages is
Write_Lock (C); Write_Lock (C);
if C.Common.Base_Priority < Get_Priority (Self_ID) then Activate_Prio :=
Activate_Prio := Get_Priority (Self_ID); (if C.Common.Base_Priority < Get_Priority (Self_ID)
else then Get_Priority (Self_ID)
Activate_Prio := C.Common.Base_Priority; else C.Common.Base_Priority);
end if;
STPO.Create_Task STPO.Create_Task
(C, Task_Wrapper'Address, (C, Task_Wrapper'Address,
...@@ -477,11 +476,10 @@ package body System.Tasking.Restricted.Stages is ...@@ -477,11 +476,10 @@ package body System.Tasking.Restricted.Stages is
pragma Assert (Stack_Address = Null_Address); pragma Assert (Stack_Address = Null_Address);
if Priority = Unspecified_Priority then Base_Priority :=
Base_Priority := Self_ID.Common.Base_Priority; (if Priority = Unspecified_Priority
else then Self_ID.Common.Base_Priority
Base_Priority := System.Any_Priority (Priority); else System.Any_Priority (Priority));
end if;
if Single_Lock then if Single_Lock then
Lock_RTS; Lock_RTS;
......
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