1. with Ada.Containers.Ordered_Maps; use Ada.Containers; 
  2.  
  3. with Ada.Unchecked_Conversion; 
  4. with Ada.Command_Line; 
  5. with Ada.Finalization; 
  6.  
  7. package body GLUT is 
  8.  
  9.    use System; 
  10.    package User_Data_Vector is new Ordered_Maps (Integer, System.Address); 
  11.    use User_Data_Vector; 
  12.  
  13.    User_Window_Data  : Map := Empty_Map; 
  14.  
  15.    function GetWindowData return System.Address is 
  16.  
  17.    begin 
  18.       if Find (User_Window_Data, GetWindow) = No_Element then 
  19.          return System.Null_Address; 
  20.       else 
  21.          return Element (User_Window_Data, GetWindow); 
  22.       end if; 
  23.    end GetWindowData; 
  24.  
  25.    procedure SetWindowData (Data  : System.Address) is 
  26.  
  27.    begin 
  28.       if Find (User_Window_Data, GetWindow) = No_Element then 
  29.          Insert (User_Window_Data, GetWindow, Data); 
  30.       else 
  31.          Replace (User_Window_Data, GetWindow, Data); 
  32.       end if; 
  33.    end SetWindowData; 
  34.  
  35.    procedure LeaveMainLoop is 
  36.  
  37.    begin 
  38.       null; 
  39.    end LeaveMainLoop; 
  40.  
  41.    procedure CloseFunc (Callback  : Glut_Proc_2) is 
  42.  
  43.    begin 
  44.       null; 
  45.    end CloseFunc; 
  46.  
  47.    procedure SetOption (option_flag  : Integer;   value  : Integer) is 
  48.  
  49.    begin 
  50.       null; 
  51.    end SetOption; 
  52.  
  53.    -- finalization - free Argv strings 
  54.    -- 
  55.    -- RK 23 - Oct - 2006, to remove the memory leak in question. 
  56.    -- 
  57.  
  58.    type Argvz is array (0 .. 500) of aliased Interfaces.C.Strings.chars_ptr; 
  59.  
  60.    type Arg_Type is new Ada.Finalization.Controlled with record 
  61.      v        : Argvz := (others => Interfaces.C.Strings.Null_Ptr); 
  62.      v_Count  : Natural := 0; 
  63.    end record; 
  64.  
  65.    overriding procedure Finalize (Self  : in out Arg_Type) 
  66.    is 
  67.       use Interfaces.C.Strings; 
  68.    begin 
  69.       if Self.v (0) /= Interfaces.C.Strings.Null_Ptr then 
  70.         Free (Self.v (0)); 
  71.       end if; 
  72.  
  73.       for I in 1 .. Self.v_Count loop 
  74.          Free (Self.v (I)); 
  75.       end loop; 
  76.    end Finalize; 
  77.  
  78.    Arg  : Arg_Type; 
  79.  
  80.    procedure Glutinit (Argcp  : access Integer; 
  81.       Argv  : access Interfaces.C.Strings.chars_ptr); 
  82.    -- pragma Import (C, Glutinit, "glutInit", "glutInit"); -- APEX 
  83.    pragma Import (StdCall, Glutinit, "glutInit"); -- GNAT/OA 
  84.  
  85.    -- Pure Ada method, from IBM / Rational Apex support: 
  86.  
  87.    -- "This procedure may be a useful replacement when porting an 
  88.    --  Ada program written for Gnat, which imports argc and argv like this: 
  89.    --  argc  : aliased integer; 
  90.    --  pragma Import (C, argc, "gnat_argc"); 
  91.    -- 
  92.    --  argv  : chars_ptr_ptr; 
  93.    --  pragma Import (C, argv, "gnat_argv"); 
  94.    -- " 
  95.  
  96.    -- http://www - 1.ibm.com/support/docview.wss?uid=swg21125019 
  97.  
  98.    procedure Init is 
  99.       use Ada.Command_Line; 
  100.       use Interfaces.C.Strings; 
  101.  
  102.       Argc  : aliased Integer := Argument_Count + 1; 
  103.    begin 
  104.       Arg.v_Count := Argument_Count; 
  105.  
  106.       Arg.v (0) := New_String (Command_Name); 
  107.       for I in 1 .. Arg.v_Count loop 
  108.           Arg.v (I) := New_String (Argument (I)); 
  109.       end loop; 
  110.  
  111.       Glutinit (Argc'Access, Arg.v (0)'Access); 
  112.    end Init; 
  113.  
  114.    function CreateWindow (Title  : String) return Integer is 
  115.       Result  : Integer; 
  116.       C_Title  : Interfaces.C.Strings.chars_ptr 
  117.         := Interfaces.C.Strings.New_String (Title); 
  118.    begin 
  119.       Result := CreateWindow (C_Title); 
  120.       Interfaces.C.Strings.Free (C_Title); 
  121.       return Result; 
  122.    end CreateWindow; 
  123.  
  124.    procedure InitDisplayString (str  : String) is 
  125.       C_Name  : Interfaces.C.Strings.chars_ptr 
  126.         := Interfaces.C.Strings.New_String (str); 
  127.    begin 
  128.       InitDisplayString (C_Name); 
  129.       Interfaces.C.Strings.Free (C_Name); 
  130.       pragma Unreferenced (C_Name); 
  131.    end InitDisplayString; 
  132.  
  133.    procedure SetWindowTitle (Title  : String) is 
  134.       C_Title  : Interfaces.C.Strings.chars_ptr 
  135.         := Interfaces.C.Strings.New_String (Title); 
  136.    begin 
  137.       SetWindowTitle (C_Title); 
  138.       Interfaces.C.Strings.Free (C_Title); 
  139.       pragma Unreferenced (C_Title); 
  140.    end SetWindowTitle; 
  141.  
  142.    procedure SetIconTitle (Title  : String) is 
  143.       C_Title  : Interfaces.C.Strings.chars_ptr 
  144.         := Interfaces.C.Strings.New_String (Title); 
  145.    begin 
  146.       SetIconTitle (C_Title); 
  147.       Interfaces.C.Strings.Free (C_Title); 
  148.       pragma Unreferenced (C_Title); 
  149.    end SetIconTitle; 
  150.  
  151.    procedure AddMenuEntry (Label  : String; Value  : Integer) is 
  152.       C_Label  : Interfaces.C.Strings.chars_ptr 
  153.         := Interfaces.C.Strings.New_String (Label); 
  154.    begin 
  155.       AddMenuEntry (C_Label, Value); 
  156.       Interfaces.C.Strings.Free (C_Label); 
  157.       pragma Unreferenced (C_Label); 
  158.    end AddMenuEntry; 
  159.  
  160.    procedure AddSubMenu (Label  : String; Submenu  : Integer) is 
  161.       C_Label  : Interfaces.C.Strings.chars_ptr 
  162.         := Interfaces.C.Strings.New_String (Label); 
  163.    begin 
  164.       AddSubMenu (C_Label, Submenu); 
  165.       Interfaces.C.Strings.Free (C_Label); 
  166.       pragma Unreferenced (C_Label); 
  167.    end AddSubMenu; 
  168.  
  169.    procedure ChangeToMenuEntry 
  170.      (Item   : Integer; 
  171.       Label  : String; 
  172.       Value  : Integer) 
  173.    is 
  174.       C_Label  : Interfaces.C.Strings.chars_ptr 
  175.         := Interfaces.C.Strings.New_String (Label); 
  176.    begin 
  177.       ChangeToMenuEntry (Item, C_Label, Value); 
  178.       Interfaces.C.Strings.Free (C_Label); 
  179.       pragma Unreferenced (C_Label); 
  180.    end ChangeToMenuEntry; 
  181.  
  182.    procedure ChangeToSubMenu 
  183.      (Item     : Integer; 
  184.       Label    : String; 
  185.       Submenu  : Integer) 
  186.    is 
  187.       C_Label  : Interfaces.C.Strings.chars_ptr 
  188.         := Interfaces.C.Strings.New_String (Label); 
  189.    begin 
  190.       ChangeToSubMenu (Item, C_Label, Submenu); 
  191.       Interfaces.C.Strings.Free (C_Label); 
  192.       pragma Unreferenced (C_Label); 
  193.    end ChangeToSubMenu; 
  194.  
  195.    function ExtensionSupported (str  : String) return Integer is 
  196.       Result  : Integer; 
  197.       C_Name  : Interfaces.C.Strings.chars_ptr 
  198.         := Interfaces.C.Strings.New_String (str); 
  199.    begin 
  200.       Result := ExtensionSupported (C_Name); 
  201.       Interfaces.C.Strings.Free (C_Name); 
  202.       return Result; 
  203.    end ExtensionSupported; 
  204.  
  205.    ----------------------------------------------------- 
  206.    -- GdM 2005 : callbacks with the 'Address attribute -- 
  207.    ----------------------------------------------------- 
  208.  
  209.   -- This method is functionally identical as GNAT's Unrestricted_Access 
  210.   -- but has no type safety (cf GNAT Docs) 
  211.  
  212.    function CreateMenu (P1  : System.Address) return Integer is 
  213.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_1); 
  214.    begin 
  215.      return CreateMenu (Cvt (P1)); 
  216.    end CreateMenu; 
  217.  
  218.    procedure DisplayFunc (P1  : System.Address) is 
  219.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_2); 
  220.    begin 
  221.      DisplayFunc (Cvt (P1)); 
  222.    end DisplayFunc; 
  223.  
  224.    procedure ReshapeFunc (P1  : System.Address) is 
  225.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_3); 
  226.    begin 
  227.      ReshapeFunc (Cvt (P1)); 
  228.    end ReshapeFunc; 
  229.  
  230.    procedure KeyboardFunc (P1  : System.Address) is 
  231.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_4); 
  232.    begin 
  233.      KeyboardFunc (Cvt (P1)); 
  234.    end KeyboardFunc; 
  235.  
  236.    procedure KeyboardUpFunc (P1  : System.Address) is 
  237.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_KeyUpFunc); 
  238.    begin 
  239.      KeyboardUpFunc (Cvt (P1)); 
  240.    end KeyboardUpFunc; 
  241.  
  242.    procedure MouseFunc (P1  : System.Address) is 
  243.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_5); 
  244.    begin 
  245.      MouseFunc (Cvt (P1)); 
  246.    end MouseFunc; 
  247.  
  248.    procedure MotionFunc (P1  : System.Address) is 
  249.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_6); 
  250.    begin 
  251.      MotionFunc (Cvt (P1)); 
  252.    end MotionFunc; 
  253.  
  254.    procedure PassiveMotionFunc (P1  : System.Address) is 
  255.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_7); 
  256.    begin 
  257.      PassiveMotionFunc (Cvt (P1)); 
  258.    end PassiveMotionFunc; 
  259.  
  260.    procedure IdleFunc (P1  : System.Address) is 
  261.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_10); 
  262.    begin 
  263.      IdleFunc (Cvt (P1)); 
  264.    end IdleFunc; 
  265.  
  266.    procedure SpecialFunc (P1  : System.Address) is 
  267.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_Proc_13); 
  268.    begin 
  269.      SpecialFunc (Cvt (P1)); 
  270.    end SpecialFunc; 
  271.  
  272.    procedure SpecialUpFunc (Func  : System.Address) is 
  273.      function Cvt is new Ada.Unchecked_Conversion (System.Address, Glut_SpecialUp); 
  274.    begin 
  275.      SpecialUpFunc (Cvt (Func)); 
  276.    end SpecialUpFunc; 
  277.  
  278. end GLUT;