Add the beginnings of a real Ada wrapping around libdispatch!

Makefile

@@ -16,7 +16,7 @@ LDFLAGS+=-L/usr/local/lib -ldispatch
 .PHONY: clean test setup
 
 test: dispatch-test dispatch-ada-test
-	./dispatch-test
+	./dispatch-ada-test
 
 setup:
 	mkdir -p obj

dispatch-test.c

@@ -9,7 +9,6 @@ int main(int argc, char **argv) {
 	printf(">>> Starting test\n");
 
 	dispatch_queue_t main = dispatch_get_main_queue();
-
 	/*
 	 * Dispatch 3 seconds from now. This will be queued serially after the
 	 * block below this which sleeps the entire thread, GCD main queue included
@@ -28,7 +27,7 @@ int main(int argc, char **argv) {
 
 	dispatch_async(main, ^{
 			printf("burp\n");
-			sleep(3);
+			sleep(1);
 			printf("ahem\n");
 			});
 

dispatch.gpr

@@ -27,11 +27,13 @@ project Dispatch is
    end Ide;
 
    package Compiler is
-      for Default_Switches ("ada") use ("-gnat12", "-gnatf", "-g", "-gnata");
+      for Default_Switches ("ada") use ("-gnat2012", "-gnatf", "-g", "-gnata");
    end Compiler;
 
    package Linker is
-      for Default_Switches ("ada") use ("-g");
+      for Default_Switches ("ada") use ("-g",
+                                        "-L/usr/local/lib",
+                                        "-ldispatch");
    end Linker;
 
 end Dispatch;

src/dispatch.adb

@@ -0,0 +1,19 @@
+package body Dispatch is
+   procedure Async (Q        : in Queue_Type;
+                    Callback : access procedure) is
+   begin
+      dispatch_async_f (Q, System.Null_Address, Callback);
+   end Async;
+
+
+   procedure Schedule (Q        : in Queue_Type;
+                       Secs     : in Long_Integer;
+                       Callback : access procedure) is
+      D : Long_Natural := Secs * NANO_SECS_PER_SEC;
+   begin
+      dispatch_after_f (dispatch_time (TIME_NOW, D),
+                        Q,
+                        System.Null_Address,
+                        Callback);
+   end Schedule;
+end Dispatch;

src/dispatch.ads

@@ -0,0 +1,47 @@
+with System;
+
+package Dispatch is
+   subtype Queue_Type is System.Address;
+
+   procedure Async (Q        : in Queue_Type;
+                    Callback : access procedure);
+
+   procedure Schedule (Q        : in Queue_Type;
+                       Secs     : in Long_Integer;
+                       Callback : access procedure);
+
+   procedure Run;
+   pragma Import (C, Run, "dispatch_main");
+   --
+   --  Using "with" for aspects doesn't seem to work and confuses the compiler.
+   --  Hopefully with GNAT GPL 2014, this will be fixed :(
+
+   function Main return Queue_Type;
+   pragma Import (C, Main, "dispatch_get_main_queue");
+
+   private
+
+   NANO_SECS_PER_SEC : constant := 1000000000;
+   TIME_NOW : constant := 0;
+   subtype Long_Natural is Long_Integer range 0 .. Long_Integer'Last;
+
+   function dispatch_time (Time  : in Long_Natural;
+                            D     : in Long_Natural) return Long_Natural;
+   pragma Import (c, dispatch_time);
+
+   procedure dispatch_after_f (Time     : in Long_Natural;
+                               Q        : in Queue_Type;
+                               Ctx      : in System.Address;
+                               Callback : access procedure);
+   pragma Import (C, dispatch_after_f);
+
+   procedure dispatch_async_f (Q        : in Queue_Type;
+                               Ctx      : in System.Address;
+                               Callback : access procedure);
+   pragma Import (C, dispatch_async_f);
+
+   procedure dispatch_sync_f (Q        : in Queue_Type;
+                              Ctx      : in System.Address;
+                              Callback : access procedure);
+   pragma Import (C, dispatch_sync_f);
+end Dispatch;

test/test_runner.adb

@@ -1,5 +1,41 @@
+with Ada.Command_Line,
+     Ada.Text_IO;
 
-procedure TestRunner is
+with Dispatch;
+
+
+procedure Test_Runner is
+   use Ada.Text_IO;
+
+   procedure Honk is
+   begin
+      Put_Line ("honk honk");
+      delay 1.0;
+      Put_Line ("honk");
+   end Honk;
+
+   procedure c_exit;
+   pragma Import (C, c_exit, "exit");
+
+   procedure Suicide is
+   begin
+      Put_Line ("terminating!");
+      c_exit;
+   end Suicide;
+
+   procedure Beep is
+   begin
+      Put_Line ("deferred beep");
+      Dispatch.Async (Dispatch.Main, Suicide'Access);
+   end Beep;
 begin
-   null;
-end TestRunner;
+   Put_Line (">> Running Dispatch-Ada tests");
+
+   Dispatch.Async (Dispatch.Main, Honk'Access);
+   Dispatch.Schedule (Dispatch.Main, 4, Beep'Access);
+
+   Put_Line ("..starting runloop");
+
+   Dispatch.Run;
+
+end Test_Runner;