Is there a pattern for a fire and forget mechanism in Ada? When I call a task entry, I don't want the caller to be blocked until the message has been processed. I would like the task to be asynchronous. What I've tried is
loop
select
accept xxx(params) do
-- save the parameters in a queue
end accept;
...
else
-- pick the next item off the queue and process it
end select;
end loop;
It looks like a clumsy mechanism. Maybe fire and forget is the wrong term. I've also tried one task filling up the queue and another taking entries off the queue. Is there a better way of implementing asynchronous tasks in Ada.
If you’re using Ada 2012, the way to go would be to use Ada.Containers.Unbounded_Synchronized_Queues (or the Bounded version): your user code calls Enqueue, your server task calls Dequeue which blocks if the queue is empty.
If not, the normal approach would be to use your own protected object to encapsulate a queue (which is how the Ada 2012 packages do it). Something like
package Parameters is new Ada.Containers.Vectors (Positive, Parameter);
protected Queue is
procedure Put (P : Parameter);
entry Get (P : out Parameter);
private
The_Queue : Parameters.Vector;
end Queue;
protected body Queue is
procedure Put (P : Parameter) is
begin
The_Queue.Append (P);
end Put;
entry Get (P : out Parameter) when not The_Queue.Is_Empty is
begin
P := The_Queue.First_Element;
The_Queue.Delete_First;
end Get;
end Queue;
and then
task body Server is
P : Parameter;
begin
loop
Queue.Get (P);
-- process P
end loop;
end Server;
Related
I'm kinda new with Ada and recently got an error that I don't seem to know how to solve.
I have the following code:
data.ads
with Text_IO; use text_io;
with ada.Integer_Text_IO; use ada.Integer_Text_IO;
package data is
type file is private;
type file_set is array (Integer range <>) of file;
procedure file_Print (T : in out file); --Not used
private
type file is record
start, deadline : integer;
end record;
end data;
Main.adb
with ada.Integer_Text_IO; use ada.Integer_Text_IO;
procedure Main is
Num_files: integer:=3;
Files:file_set(1..Num_files);
begin
Files(1):=(2,10); -- Expected private type "file" defined at data.ads
for i in 1..Num_Files loop
Put(integer'Image(i));
New_Line;
data.File_Print(Files(i));
But I'm getting this error Expected private type "file" defined at data.ads
How can I access the file type and declare a new array of values in main?
That's right - you don't get to see or manipulate what's inside a private type. That would be breaking encapsulation. Bugs and security risks follow.
You can only interact with a private type via its methods : functions and procedures declared in the package where it's declared.
Now file_set is NOT a private type (you might consider making it private later, for better encapsulation, but for now ....) you can index it to access a file within it (using one of those procedures).
Files(1):=(2,10);
As you want to create a file here, you need a method to create a file ... a bit similar to a constructor in C++, but really more like the Object Factory design pattern. Add this to the package:
function new_file(start, deadline : integer) return file;
And implement it in the package body:
package body data is
function new_file(start, deadline : integer) return file is
begin
-- check these values are valid so we can guarantee a proper file
-- I have NO idea what start, deadline mean, so write your own checks!
-- also there are better ways, using preconditions in Ada-2012
-- without writing explicit checks, but this illustrates the idea
if deadline < NOW or start < 0 then
raise Program_Error;
end if;
return (start => start, deadline => deadline);
end new_file;
procedure file_Print (T : in out file) is ...
end package body;
and that gives the users of your package permission to write
Files(1):= new_file(2,10);
Files(2):= new_file(start => 3, deadline => 15);
but if they attempt to create garbage to exploit your system
Files(3):= new_file(-99,-10); -- Oh no you don't!
this is the ONLY way to create a file, so they can't bypass your checks.
I have the following code, related to the dining philosopher problem. I am very new to Ada so am not sure about how to implement the Id_Dispenser package.
with Ada.Text_IO; use Ada.Text_IO;
with Id_Dispenser;
with Semaphores; use Semaphores;
procedure Philos is
No_of_Philos : constant Positive := 5; -- Number of philosophers
Meditation : constant Duration := 0.0;
type Table_Ix is mod No_of_Philos;
Forks : array (Table_Ix) of Binary_Semaphore (Initially_Available => True);
package Index_Dispenser is new Id_Dispenser (Element => Table_Ix);
use Index_Dispenser;
task type Philo;
task body Philo is
Philo_Nr : Table_Ix; -- Philisopher number
begin
Dispenser.Draw_Id (Id => Philo_Nr);
Put_Line ("Philosopher" & Table_Ix'Image (Philo_Nr) & " looks for forks.");
Forks (Philo_Nr).Wait; delay Meditation; Forks (Philo_Nr + 1).Wait;
Put_Line ("Philosopher" & Table_Ix'Image (Philo_Nr) & " eats.");
Forks (Philo_Nr).Signal; Forks (Philo_Nr + 1).Signal;
Put_Line ("Philosopher" & Table_Ix'Image (Philo_Nr) & " dropped forks.");
end Philo;
Table : array (Table_Ix) of Philo; pragma Unreferenced (Table);
begin
null;
end Philos;
I have implemented the following semaphore, which I think should be correct
package body semaphores is
protected body Binary_Semaphore is
entry Wait when Count > 0 is
begin
Count := Count - 1;
end Wait;
entry Release when Count < 1 is
begin
Count := Count + 1;
end Signal
end Binary_Semaphore;
end semaphores;
What does the Id_Dispenser need?
Looking at your code,
type Table_Ix is mod No_of_Philos;
...
package Index_Dispenser is new Id_Dispenser (Element => Table_Ix);
we can tell that Id_Dispenser is a generic package with a formal type named Element, and that the formal type is modular:
generic
type Element is mod <>;
package Id_Dispenser is
This
Philo_Nr : Table_Ix; -- Philisopher number
begin
Dispenser.Draw_Id (Id => Philo_Nr);
tells us that Id_Dispenser has some sort of component called Dispenser with a subprogram Draw_Id with an out parameter named Id which returns an Element.
Now, since this is a concurrent program, I'm going to guess that Dispenser is a protected object:
protected Dispenser is
procedure Draw_Id (Id : out Element);
private
...
end Dispenser;
The private part could simply be an array of Boolean indexed by Element,
Available : array (Element) of Boolean := (others => True);
but unfortunately you can't have an anonymous array as a component, so you need a proper type, giving
generic
type Element is mod <>;
package Id_Dispenser is
type Availability is array (Element) of Boolean;
protected Dispenser is
procedure Draw_Id (Id : out Element);
private
Available : Availability := (others => True);
end Dispenser;
end Id_Dispenser;
I'm not happy that the type Availability is visible, but the package now just needs implementing (!)
We could make Availability invisible by making Id_Dispenser.Dispenser a package, with Availability and the actual PO declared in the body. But that may be getting a little too purist for Ben’s context.
Firstly, you shouldn't really shorten identifiers, so you should have task type Philosophers... You can always use a renaming later on.
Shouldn't you model the forks and the philosophers? Each Philosopher as a task (hint array of task types).
Look at protected objects to model the forks.
Id_dispenser needs to implement a Draw_ID method.
Since the Dispenser variable is not declared here, it must presumably be declared in Id_dispenser. This hidden declaration is not very good style, as you can see it causes confusion; I would use a qualified name to make it obvious where it came from, as Index_Dispenser.Dispenser (which can then be renamed to reduce clutter in the rest of the code).
Id_dispenser may also need to provide an object factory method to initialise the Dispenser variable at its declaration.
Or, the intent may be that Dispenser will be the only one of its type, in which case you can treat Id_dispenser as a singleton package with Dispenser as the only object.
I have a tagged type that implements a number of functions. In one case I need one of these functions to instead enter an infinite loop. Unfortunately as far as I can tell there is no way for me to compile this such that it doesn't raise a warning. I wish to still use -gnatwe to ensure there are no warnings in my code, but how can I implement such a function.
Here is what the function looks like:
function Foo (This : Some_Type) return Some_Type'Class is
begin
loop
Do_Useful_Stuff_Indefinitely_With (This);
end loop;
-- return This; (if needed?)
end Foo;
I have tried pragma (No_Return) except that is only applicable for procedures (and the Foo function is used as a proper function elsewhere so must have the same signature).
I also tried pragma Suppress (All_Checks) but that still raised a warning for unreachable code or missing return statement error.
Is there any way whatsoever to have a once-off function that runs forever without raising a warning?
Taking the same example that Jean-François provided, you can avoid the warning by declaring and calling a "private" procedure (you don't have to declare it in spec) wrapping your loop as in the following :
package body foo is
procedure Infinite_Loop is
begin
loop
null;
end loop;
end Infinite_Loop;
function bar return integer is
begin
Infinite_Loop;
return 12;
end bar;
end foo;
pragma Suppress (All_Checks) acts on run-time checks. Won't help you there. Leave that alone unless you focus on performance, but then you have -p option to do it using command line switches
The pragma Suppress suppresses compiler-generated run-time checks. If a run-time check is disabled, an exception may be suppressed and undefined behavior could result. pragma Suppress is used at the programmer's risk.
You need the return statement, but you can wrap it around 2 pragma warnings statements (A case where have you tried turning it off and on again? works)
pragma warnings(off,"unreachable code");
return This;
pragma warnings(on,"unreachable code");
note that the text is optional but enables to filter other warnings that could occur (if needed). It's better since turning off all warnings is generally bad practice.
Note that you have to turn warnings on again after the statement.
Self-contained demo. foo.adb looks like:
package body foo is
function bar return integer is
begin
loop
null;
end loop;
pragma warnings(off,"unreachable code");
return 12;
pragma warnings(on,"unreachable code");
end bar;
end foo;
foo.ads looks like:
package foo is
function bar return integer;
end foo;
If I comment out the pragma lines:
$ gcc -c -gnatwe foo.adb
foo.adb:8:05: warning: unreachable code
uncommenting them removes the warning.
I recently started Ada programming and now I'm stuck.
I created a program with multiple tasks. The main-task is managing incoming communication and as a consequence starts working-tasks or transfers data to the working-tasks.
The working-tasks are all of the same kind but with different identifiers.
They do their work and should finish after that. For example:
task body Access_Protected is
begin
accept Start(foo: in Integer; foo2: out Integer)
do something
end Start;
while Go_loop loop
select
accept Quit do
Go_loop := false;
end Quit;
or
accept Insert(foo3: in Integer)
do something
if something = 0 then
Go_loop := false;
end if;
end Insert;
or delay 2.0;
end select;
end loop;
end Access_Protected;
I understand that the working-task should be terminated when the Go_loop is finished. Am I right?
It works to start the task one time but when the main-task tries to restart the working-task by calling the Start procedure, nothing happens.
Can someone please tell me which point I am missing.
A task and subprogram are somewhat related in that when the body is completed the construct ends, this is to say that the construct ends with it's appropriate end; in the case of a procedure control returns to the caller, in the case of a function the exception PROGRAM_ERROR is raised, and in the case of a task the controlling "thread" terminates.
What's happening in your particular problem, it seems, boils down to the following:
Package Example is
Task Type Message_Task is
Entry Execute;
End Message_Task;
End Example;
Package Body Example is
Task Body Message_Task is
Use Ada.Text_IO;
Begin
accept Execute do
Put_Line( "Rendezvous!" );
end Execute;
delay 0.2; -- Stub delay.
Put_Line( "Finishing Task." );
-- Task Ends Here.
End Message_Task;
End Example;
--...
Test : Example.Message_Task;
--...
Test.Execute;
-- Test.Execute can't be accepted here because it can only accept "Execute"
-- the one time, as per the body's definition.
The reason that this really is like your problem is because, likewise once you say "X.Start(1,2)" another call to Start doesn't reset the position of the task's execution back up to that accept.
If you wanted the task to "stay alive" for further processing you could do one of two options.
Option 1 -- set up a 'protocol':
Package Example is
Task Type Message_Task is
Entry Initialization;
Entry Execute;
Entry Quit;
End Message_Task;
End Example;
Package Body Example is
Task Body Message_Task is
Use Ada.Text_IO;
Has_quit : Boolean := False;
Begin
Main:
loop
select
accept Initialization do
null;
end Initialization;
accept Execute do
null;
end Execute;
or
accept Quit do
Has_Quit := True;
end Quit;
end select;
Exit Main when Has_Quit;
end loop Main;
End Message_Task;
End Example;
Option 2 -- Allow termination.
Package Example is
Task Type Message_Task is
Entry Initialization;
Entry Execute;
End Message_Task;
End Example;
Package Body Example is
Task Body Message_Task is
Use Ada.Text_IO;
Has_quit : Boolean := False;
Begin
accept Initialization do
null;
end Initialization;
Main:
loop
select
accept Execute do
null;
end Execute;
or
terminate;
end select;
end loop Main;
End Message_Task;
End Example;
The subtle difference is Option 2 gets rid of the Quit entry, allowing the task to 'rest' on the terminate alternative while Option 1 is more explicit in control (and required in some cases), but requiring that Initialization & Execute be called in pairs.
A task only runs until it reaches the end of its main sequence of statements (ignoring various technicalities).
If you want a task to do something, and then pause until it receives an external trigger, you should put a loop around the statements you have in the task body.
Can anyone tell me what ControlGetHandle() does behind the scenes? What Windows API function does it invoke? How can I see it? (logs/debug mode).
It sometimes succeeds and sometimes fails and I don't understand why. I looked all over the place, including AutoIT .au3 include files, but I couldn't find any information.
So, I discovered this amazing tool called "API Monitor". It shows you API calls made to the OS. You can filter etc. When running AutoIT with "ControlGetHandle" you can see that it actually calls two functions:
EnumWindows
EnumChildWindows
With the relevant parameters to get the handle you wish.
Thanks!
I believe it uses GetDlgCtrlID among other things. If you are having trouble getting it to return a handle sometimes changing the controlID parameter will fix it. Also, make sure you are waiting for the control to load first. If the control exists and you are using the right controlID parameters AutoIt will be able to get a controls handle 99.9999% of the time.
The first thing that comes to mind, the function finds the window with matching caption, lists the controls, finds the control with suitable criteria( class name and text), and returns his HWnd. This is done using the API EnumWindows/GetWindowTextLength/GetWindowText,GetWindowClassName.
Here, I wrote a small example, but it is in Pascal ( Excuse me. later rewritten in AutoIt. ;) ;) ;)
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
fhw:hwnd;
cls,txt:string;
wind:hwnd;
implementation
{$R *.dfm}
function GetText(wnd:hwnd):string;
var
len:integer;
begin
len:=GetWindowTextLength(wnd)+1;
SetLength(result,len);
SetLength(Result,GetWindowText(wnd,pchar(result),len));
end;
function GetClsName(wnd:hwnd):string;
begin
SetLength(result,5000);
SetLength(result,GetClassName(wnd,pchar(result),5000));
end;
function EnumChildProc(wnd:HWnd; param:Integer):bool;stdcall;
var
wintext,wincls:string;
ccmp,tcmp:boolean;
begin
wintext:=gettext(wnd);
wincls:=getclsname(wnd);
if cls <> '' then
ccmp:=(comparetext(cls,wincls)=0)
else
ccmp:=true;
if txt <> '' then
tcmp:=(comparetext(txt,wintext)=0)
else
tcmp:=true;
result:=not (tcmp and ccmp);
if not result then
wind:=wnd;
end;
procedure GetControlHandle(title:string; wtext:string; clsname:string);
var
hw:hwnd;
begin
wind:=0;
hw:=findwindow(nil,pchar(title));
if hw <> 0 then
begin
cls:=clsname;
txt:=wtext;
EnumChildWindows(hw,#EnumChildProc,integer(pointer(result)));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
w:hwnd;
begin
getcontrolhandle('New Project','','Button');
w:=wind;
CloseWindow(w);
end;
end.