论坛首页 海阔天空论坛

首发64bit Ada for Windows

浏览 1342 次
精华帖 (0) :: 良好帖 (0) :: 灌水帖 (0) :: 隐藏帖 (0)
作者 正文
   发表时间:2011-06-15   最后修改:2011-06-15



项目地址:http://sourceforge.net/projects/ya-mingw64/files/


ada的语法相当精湛
with Ada.Text_IO; use Ada.Text_IO;
 
procedure Traffic is
 
   type Airplane_ID is range 1..10;         -- 10 airplanes (= tasks)
 
   task type Airplane(ID: Airplane_ID);     -- task type representing airplanes
   type Airplane_Access is access Airplane; -- access type (reference) to Airplane
 
   protected type Runway is             -- a protected object - the shared runway
      entry Assign_Aircraft(ID: Airplane_ID);
      entry Cleared_Runway (ID : Airplane_ID);
      entry Wait_For_Clear;
   private
      Clear: Boolean := True; -- protected private data - generally more than just a flag...
   end Runway;
   type Runway_Access is access all Runway;
 
   -- the air traffic controller takes requests for takeoff and landing
   task type Controller(My_Runway: Runway_Access) is
      entry Request_Takeoff (ID: in Airplane_ID; Takeoff: out Runway_Access);
      entry Request_Approach(ID: in Airplane_ID; Approach: out Runway_Access);
   end Controller;
 
   Runway1    : aliased Runway;             -- instantiate a runway
   Controller1: Controller(Runway1'Access); -- and a controller to manage it
 
  ------ the implementations of the above types ------
   protected body Runway is
      entry Assign_Aircraft (ID : Airplane_ID)
        when Clear is   -- the entry guard - tasks are blocked until this is true
      begin
        Clear := False;     Put_Line (Airplane_ID'Image (ID) & " on runway ");
      end;
 
      entry Cleared_Runway (ID : Airplane_ID) when not Clear is
      begin
         Clear := True;     Put_Line (Airplane_ID'Image (ID) & " cleared runway ");
      end;
 
      entry Wait_For_Clear when Clear is begin
         null;
      end;
   end Runway;
 
   task body Controller is
   begin
      loop
         My_Runway.Wait_For_Clear;   -- wait until runway is available
         select                      -- wait for two types of requests
            when Request_Approach'count = 0 =>  -- landings have priority
             accept Request_Takeoff (ID : in Airplane_ID; Takeoff : out Runway_Access) do
               My_Runway.Assign_Aircraft (ID);  -- reserve runway
               Takeoff := My_Runway;            -- tell airplane which runway
            end Request_Takeoff;                -- end of the synchronised part
         or
            accept Request_Approach (ID : in Airplane_ID; Approach : out Runway_Access) do
               My_Runway.Assign_Aircraft (ID);
               Approach := My_Runway;
            end Request_Approach;
         or                          -- terminate if nobody left who could call
            terminate;
         end select;
      end loop;
   end;
 
   task body Airplane is
      Rwy : Runway_Access;
   begin
      Controller1.Request_Takeoff (ID, Rwy); -- wait to be cleared for takeoff
      Put_Line (Airplane_ID'Image (ID) & "  taking off...");  delay 2.0;
      Rwy.Cleared_Runway (ID);
      delay 5.0; -- fly around a bit...
      loop
         select   -- try to request a runway
            Controller1.Request_Approach (ID, Rwy); -- this is a blocking call
            exit; -- if call returned we're clear for landing - proceed...
 
         or delay 3.0;  -- timeout - if no answer in 3 seconds, do something else
            Put_Line (Airplane_ID'Image (ID) & "   in holding pattern");
         end select;
      end loop;
      delay 4.0;  -- do landing approach...
      Put_Line (Airplane_ID'Image (ID) & "            touched down!");
      Rwy.Cleared_Runway(ID);  -- notify runway that we're done here.
   end;
 
   New_Airplane: Airplane_Access;
begin
   for I in Airplane_ID'Range loop  -- create a few airplane tasks
      New_Airplane := new Airplane(I); delay 3.0;
   end loop;
end Traffic;

可以看出.NET中的PLING和ASYNC从ADA中学习了很多
  • 大小: 51.3 KB
   发表时间:2011-06-16  
呵呵,今天收到MinGW64项目组的邀请,让我加入他们的项目
0 请登录后投票
论坛首页 海阔天空版

跳转论坛:
Global site tag (gtag.js) - Google Analytics