openglada_glfw_0.9.0_fc25165c/src/glfw-errors.adb

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
--  part of OpenGLAda, (c) 2017 Felix Krause
--  released under the terms of the MIT license, see the file "COPYING"

with Interfaces.C.Strings;

with Glfw.API;

package body Glfw.Errors is

   Cur_Callback : Callback := null;

   procedure Raw_Handler (Code : Kind;
                          Description : Interfaces.C.Strings.chars_ptr);
   pragma Convention (C, Raw_Handler);

   procedure Raw_Handler (Code : Kind;
                          Description : Interfaces.C.Strings.chars_ptr) is
   begin
      if Cur_Callback /= null then
         Cur_Callback.all (Code, Interfaces.C.Strings.Value (Description));
      end if;
   end Raw_Handler;

   procedure Set_Callback (Handler : Callback) is
      Previous : API.Error_Callback;
      pragma Warnings (Off, Previous);
   begin
      Cur_Callback := Handler;
      if Handler = null then
         Previous := API.Set_Error_Callback (null);
      else
         Previous := API.Set_Error_Callback (Raw_Handler'Access);
      end if;
   end Set_Callback;

end Glfw.Errors;