with Ada.Containers.Ordered_Maps; use Ada.Containers;
with Ada.Unchecked_Conversion;
with Ada.Command_Line;
with Ada.Finalization;
package body GLUT is
use System;
package User_Data_Vector is new Ordered_Maps (Integer, System.Address);
use User_Data_Vector;
User_Window_Data : Map := Empty_Map;
function GetWindowData return System.Address is
begin
if Find (User_Window_Data, GetWindow) = No_Element then
return System.Null_Address;
else
return Element (User_Window_Data, GetWindow);
end if;
end GetWindowData;
procedure SetWindowData (Data : System.Address) is
begin
if Find (User_Window_Data, GetWindow) = No_Element then
Insert (User_Window_Data, GetWindow, Data);
else
Replace (User_Window_Data, GetWindow, Data);
end if;
end SetWindowData;
procedure LeaveMainLoop is
begin
null;
end LeaveMainLoop;
procedure CloseFunc (Callback : Glut_Proc_2) is
begin
null;
end CloseFunc;
procedure SetOption (option_flag : Integer; value : Integer) is
begin
null;
end SetOption;
type Argvz is array (0 .. 500) of aliased Interfaces.C.Strings.chars_ptr;
type Arg_Type is new Ada.Finalization.Controlled with record
v : Argvz := (others => Interfaces.C.Strings.Null_Ptr);
v_Count : Natural := 0;
end record;
overriding procedure Finalize (Self : in out Arg_Type)
is
use Interfaces.C.Strings;
begin
if Self.v (0) /= Interfaces.C.Strings.Null_Ptr then
Free (Self.v (0));
end if;
for I in 1 .. Self.v_Count loop
Free (Self.v (I));
end loop;
end Finalize;
Arg : Arg_Type;
procedure Glutinit (Argcp : access Integer;
Argv : access Interfaces.C.Strings.chars_ptr);
pragma Import (StdCall, Glutinit, "glutInit");
procedure Init is
use Ada.Command_Line;
use Interfaces.C.Strings;
Argc : aliased Integer := Argument_Count + 1;
begin
Arg.v_Count := Argument_Count;
Arg.v (0) := New_String (Command_Name);
for I in 1 .. Arg.v_Count loop
Arg.v (I) := New_String (Argument (I));
end loop;
Glutinit (Argc'Access, Arg.v (0)'Access);
end Init;
function CreateWindow (Title : String) return Integer is
Result : Integer;
C_Title : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (Title);
begin
Result := CreateWindow (C_Title);
Interfaces.C.Strings.Free (C_Title);
return Result;
end CreateWindow;
procedure InitDisplayString (str : String) is
C_Name : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (str);
begin
InitDisplayString (C_Name);
Interfaces.C.Strings.Free (C_Name);
pragma Unreferenced (C_Name);
end InitDisplayString;
procedure SetWindowTitle (Title : String) is
C_Title : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (Title);
begin
SetWindowTitle (C_Title);
Interfaces.C.Strings.Free (C_Title);
pragma Unreferenced (C_Title);
end SetWindowTitle;
procedure SetIconTitle (Title : String) is
C_Title : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (Title);
begin
SetIconTitle (C_Title);
Interfaces.C.Strings.Free (C_Title);
pragma Unreferenced (C_Title);
end SetIconTitle;
procedure AddMenuEntry (Label : String; Value : Integer) is
C_Label : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (Label);
begin
AddMenuEntry (C_Label, Value);
Interfaces.C.Strings.Free (C_Label);
pragma Unreferenced (C_Label);
end AddMenuEntry;
procedure AddSubMenu (Label : String; Submenu : Integer) is
C_Label : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (Label);
begin
AddSubMenu (C_Label, Submenu);
Interfaces.C.Strings.Free (C_Label);
pragma Unreferenced (C_Label);
end AddSubMenu;
procedure ChangeToMenuEntry
(Item : Integer;
Label : String;
Value : Integer)
is
C_Label : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (Label);
begin
ChangeToMenuEntry (Item, C_Label, Value);
Interfaces.C.Strings.Free (C_Label);
pragma Unreferenced (C_Label);
end ChangeToMenuEntry;
procedure ChangeToSubMenu
(Item : Integer;
Label : String;
Submenu : Integer)
is
C_Label : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (Label);
begin
ChangeToSubMenu (Item, C_Label, Submenu);
Interfaces.C.Strings.Free (C_Label);
pragma Unreferenced (C_Label);
end ChangeToSubMenu;
function ExtensionSupported (str : String) return Integer is
Result : Integer;
C_Name : Interfaces.C.Strings.chars_ptr
:= Interfaces.C.Strings.New_String (str);
begin
Result := ExtensionSupported (C_Name);
Interfaces.C.Strings.Free (C_Name);
return Result;
end ExtensionSupported;
function CreateMenu (P1 : System.Address) return Integer is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_1);
begin
return CreateMenu (Cvt (P1));
end CreateMenu;
procedure DisplayFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_2);
begin
DisplayFunc (Cvt (P1));
end DisplayFunc;
procedure ReshapeFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_3);
begin
ReshapeFunc (Cvt (P1));
end ReshapeFunc;
procedure KeyboardFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_4);
begin
KeyboardFunc (Cvt (P1));
end KeyboardFunc;
procedure KeyboardUpFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_KeyUpFunc);
begin
KeyboardUpFunc (Cvt (P1));
end KeyboardUpFunc;
procedure MouseFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_5);
begin
MouseFunc (Cvt (P1));
end MouseFunc;
procedure MotionFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_6);
begin
MotionFunc (Cvt (P1));
end MotionFunc;
procedure PassiveMotionFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_7);
begin
PassiveMotionFunc (Cvt (P1));
end PassiveMotionFunc;
procedure IdleFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_10);
begin
IdleFunc (Cvt (P1));
end IdleFunc;
procedure SpecialFunc (P1 : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_13);
begin
SpecialFunc (Cvt (P1));
end SpecialFunc;
procedure SpecialUpFunc (Func : System.Address) is
function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_SpecialUp);
begin
SpecialUpFunc (Cvt (Func));
end SpecialUpFunc;
end GLUT;