home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adapm_15.zip / win_bak2.adb < prev    next >
Text File  |  1994-03-17  |  56KB  |  1,550 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                               PM Bindings                                --
  4. --                                                                          --
  5. --                                  WIN                                     --
  6. --                                                                          --
  7. --                                 Body                                     --
  8. --                                                                          --
  9. --                            $Revision: .15 $                              --
  10. --                                                                          --
  11. --     Copyright (c) 1994 Dimensional Media Systems, All Rights Reserved    --
  12. --                                                                          --
  13. --   The PM bindings are free software; you can redistribute them and/or    --
  14. --   modify them under terms of the GNU General Public License as published --
  15. --   by the Free Software Foundation; either version 2, or (at your         --
  16. --   option) any later version.  The PM bindings are distributed in the     --
  17. --   hope that they will be useful, but WITH OUT ANY WARRANTY; without even --
  18. --   the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR    --
  19. --   PURPOSE.  See the GNU General Public License for more details.  You    --
  20. --   should have received a copy of the GNU General Public License          --
  21. --   distributed with The PM bindings; see file COPYING.  If not, write to  --
  22. --   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25. --                                                                          --
  26. --   For more information about these PM bindings and their usage with GNAT --
  27. --   you can contact Bill Yow at                                            --
  28. --                                                                          --  
  29. --      Dimensional Media Systems (DMS)                                     --
  30. --      1522 Festival Dr.                                                   --
  31. --      Houston TX, 77062                                                   --
  32. --      Phone - (713) 488-7050                                              --
  33. --      Email - Byow@mci.com                                                --
  34. --                                                                          --
  35. ------------------------------------------------------------------------------
  36.  
  37. with System;
  38. with Pm_Types;
  39.  
  40. with Text_IO;
  41.  
  42. with Unchecked_Conversion;
  43. with Unchecked_Deallocation;
  44.  
  45. package body Win is
  46.  
  47.   Short_True     : constant Pm_Types.U_Short := 1;
  48.   Short_False    : constant Pm_Types.U_Short := 0;
  49.  
  50.   Long_True      : constant Pm_Types.U_Long := 1;
  51.   Long_False     : constant Pm_Types.U_Long := 0;
  52.  
  53.   Boolean_Value  : constant array (Boolean) of PM_Types.U_Long := (0, 1);
  54.  
  55.   Boolean_Result : constant array (Pm_Types.U_Long range 0 .. 1) 
  56.                      of Boolean := (False, True);
  57.  
  58.   MB_Response : constant array (Pm_Types.U_Short range 1 .. 9) 
  59.                    of MB_Response_Type :=
  60.      (1 => MB_Ok_Pressed,
  61.       2 => MB_Cancel_Pressed,
  62.       3 => Mb_Abort_Pressed,
  63.       4 => Mb_Retry_Pressed,
  64.       5 => Mb_Ignore_Pressed,
  65.       6 => Mb_Yes_Pressed,
  66.       7 => Mb_No_Pressed,
  67.       8 => Mb_Help_Pressed,
  68.       9 => Mb_Enter_Pressed); 
  69.  
  70.   MB_Buttons : constant array (Mb_Button_Styles_Type) of Pm_Types.U_Long := 
  71.      (MB_Ok                 => 16#0000#,
  72.       MB_Ok_Cancel          => 16#0001#,
  73.       MB_Cancel             => 16#0006#,
  74.       MB_Enter              => 16#0007#,
  75.       MB_Enter_Cancel       => 16#0008#,
  76.       MB_Retry_Cancel       => 16#0002#,
  77.       MB_Abort_Retry_Ignore => 16#0003#,
  78.       MB_Yes_No             => 16#0004#,
  79.       MB_Yes_No_Cancel      => 16#0005#);
  80.  
  81.   MB_Icons : constant array (Mb_Icon_Styles_Type) of Pm_Types.U_Long := 
  82.       (Mb_No_Icon          => 16#0000#,
  83.        Mb_Icon_Hand        => 16#0040#,
  84.        Mb_Icon_Question    => 16#0010#,
  85.        Mb_Icon_Exclamation => 16#0020#,
  86.        Mb_Icon_Asterisk    => 16#0030#,
  87.        Mb_Information      => 16#0030#,
  88.        Mb_Query            => 16#0010#,
  89.        Mb_Warning          => 16#0020#,
  90.        Mb_Error            => 16#0040#);
  91.  
  92.   MB_Action : constant array (Mb_Default_Action_Type) of Pm_Types.U_Long := 
  93.        (MB_Default_on_Button_1 => 16#0000#,
  94.         MB_Default_on_Button_2 => 16#0100#,
  95.         MB_Default_on_Button_3 => 16#0200#);
  96.  
  97.   MB_Modality : constant array (Mb_Modality_Type) of Pm_Types.U_Long := 
  98.        (Mb_Application_Modal => 16#0000#,
  99.         Mb_System_Modal      => 16#1000#);
  100.  
  101.   MB_Help     : constant array (Boolean) 
  102.                     of Pm_Types.U_Long := (16#0000#, 16#2000#);
  103.   MB_Moveable : constant array (Boolean) 
  104.                     of Pm_Types.U_Long := (16#0000#, 16#4000#);
  105.  
  106.   ------------------------------------------------
  107.  
  108.   Win_Style_Values : constant array (Class_Style_Type) of Pm_Types.U_Long :=
  109.        (Cs_Size_Redraw    => 16#0000_0004#,
  110.         Cs_Sync_Paint     => 16#0200_0000#,
  111.         Cs_Move_Notify    => 16#0000_0001#,
  112.         Cs_Clip_Children  => 16#2000_0000#,
  113.         Cs_Clip_Siblings  => 16#1000_0000#,
  114.         Cs_Parent_Clip    => 16#0800_0000#,
  115.         Cs_Save_Bits      => 16#0400_0000#,
  116.         Cs_Public         => 16#0000_0010#,
  117.         Cs_Hit_Test       => 16#0000_0008#,
  118.         Cs_Frame          => 16#0000_0020#); 
  119.          
  120.   ------------------------------------------------
  121.  
  122.    Win_Position_Values : constant array (Position_Options_Type) 
  123.                                                      of Pm_Types.U_Long :=
  124.        (Swp_Size             => 16#0001#,
  125.         Swp_Move             => 16#0002#,
  126.         Swp_Z_Order          => 16#0004#,
  127.         Swp_Show             => 16#0008#,
  128.         Swp_Hide             => 16#0010#,
  129.         Swp_No_Redraw        => 16#0020#,
  130.         Swp_No_Adjust        => 16#0040#,
  131.         Swp_Activate         => 16#0080#,
  132.         Swp_Deactivate       => 16#0100#,
  133.         Swp_Ext_State_Change => 16#0200#,
  134.         Swp_Minimize         => 16#0400#,
  135.         Swp_Maximize         => 16#0800#,
  136.         Swp_Restore          => 16#1000#,
  137.         Swp_Focus_Active     => 16#2000#,
  138.         Swp_Focus_Deactivate => 16#4000#,
  139.         Swp_No_Auto_Close    => 16#8000#);
  140.  
  141.   ------------------------------------------------
  142.  
  143.    Window_Style_Values : constant array (Window_Style_Type) 
  144.                                         of PM_Types.U_Long := (
  145.       Ws_Sync_Paint         => 16#0200_0000#,
  146.       Ws_Clip_Children      => 16#2000_0000#,
  147.       Ws_Clip_Siblings      => 16#1000_0000#,
  148.       Ws_Disabled           => 16#4000_0000#,
  149.       Ws_Maximized          => 16#0080_0000#,
  150.       Ws_Mimimized          => 16#0100_0000#,
  151.       Ws_Parent_Clip        => 16#0800_0000#,
  152.       Ws_Save_Bits          => 16#0400_0000#,
  153.       Ws_Visible            => 16#8000_0000#,
  154.       Ws_Animate            => 16#0040_0000#,
  155.       Ws_Group              => 16#0001_0000#,
  156.       Ws_Tab_Stop           => 16#0002_0000#,
  157.       Ws_Multi_Select       => 16#0004_0000#,
  158.  
  159.       Fs_Screen_Align       => 16#0000_0200#,
  160.       Fs_Mouse_Align        => 16#0000_0400#,
  161.       Fs_Sizing_Border      => 16#0000_0800#,
  162.       Fs_Border             => 16#0000_0100#,
  163.       Fs_Dialog_Border      => 16#0000_0080#,
  164.       Fs_System_Modal       => 16#0000_0040#,
  165.       Fs_No_Byte_Align      => 16#0000_0010#,
  166.       Fs_Task_List          => 16#0000_0008#,
  167.       Fs_No_Move_With_Owner => 16#0000_0020#,
  168.       Fs_Auto_Icon          => 16#0000_1000#);
  169.  
  170.   ------------------------------------------------
  171.  
  172.    Frame_Values : constant array (Frame_Control_Flag_Type) 
  173.                    of Pm_Types.U_Long := (
  174.         Fcf_Title_Bar          => 16#0000_0001#,
  175.         Fcf_System_Menu        => 16#0000_0002#,
  176.         Fcf_Menu               => 16#0000_0004#,
  177.         Fcf_Min_Max            => 16#0000_0030#,
  178.         Fcf_Min_Button         => 16#0000_0010#,
  179.         Fcf_Max_Button         => 16#0000_0020#,
  180.         Fcf_Vert_Scroll_Bar    => 16#0000_0040#,
  181.         Fcf_Horz_Scroll_Bar    => 16#0000_0080#,
  182.         Fcf_Sizing_Border      => 16#0000_0008#,
  183.         Fcf_Border             => 16#0000_0200#,
  184.         Fcf_Dialog_Border      => 16#0000_0100#,
  185.         Fcf_Accel_Table        => 16#0000_8000#,
  186.         Fcf_Icon               => 16#0000_4000#,
  187.         Fcf_Shell_Position     => 16#0000_0400#,
  188.         Fcf_System_Modal       => 16#0001_0000#,
  189.         Fcf_No_Byte_Align      => 16#0000_1000#,
  190.         Fcf_Task_List          => 16#0000_0800#,
  191.         Fcf_No_Move_With_Owner => 16#0000_2000#,
  192.         Fcf_Standard           => 16#0000_CC3F#,
  193.         Fcf_Screen_Align       => 16#0002_0000#,
  194.         Fcf_Mouse_Align        => 16#0004_0000#,
  195.         Fcf_Auto_Icon          => 16#4000_0000#,
  196.         Fcf_Hide_Button        => 16#0100_0000#,
  197.         Fcf_Hide_Max           => 16#0100_0020#);
  198.  
  199.   Frame_Id_Values : constant array (Frame_Id_Type) of Pm_Types.U_Long := (
  200.          Fid_System_Menu      => 16#8002#,
  201.          Fid_Titlebar         => 16#8003#,
  202.          Fid_Min_Max          => 16#8004#,
  203.          Fid_Menu             => 16#8005#,
  204.          Fid_Vert_Scroll_Bar  => 16#8006#,
  205.          Fid_Horz_Scroll_Bar  => 16#8007#,
  206.          Fid_Client           => 16#8008#,
  207.          Fid_DBE_App_Stat     => 16#8010#,
  208.          Fid_DBE_Kbd_Stat     => 16#8011#,
  209.          Fid_DBE_Pecic        => 16#8012#,
  210.          Fid_Dbe_KK_Pop_Up    => 16#8013#);
  211.  
  212.    Command_Source_Values : constant array (Pm_Types.U_Short range 0 .. 7) 
  213.                             of Command_Source_Type := 
  214.        (0 => Cmd_Src_Other,
  215.         1 => Cmd_Src_Push_Button,
  216.         2 => Cmd_Src_Menu,
  217.         3 => Cmd_Src_Accelerator,
  218.         4 => Cmd_Src_Font_Dialog,
  219.         5 => Cmd_Src_File_Dialog,
  220.         6 => Cmd_Src_Print_Dialog,
  221.         7 => Cmd_Src_Color_Dialog);
  222.  
  223.   ------------------------------------------------
  224.  
  225.    MIS_Values : constant array (Menu_Style_Type) of Pm_Types.U_Short := (
  226.        MIS_Text             => 16#0001#,
  227.        MIS_Bitmap           => 16#0002#,
  228.        MIS_Separator        => 16#0004#,
  229.        MIS_Owner_Draw       => 16#0008#,
  230.        MIS_Submenu          => 16#0010#,
  231.        MIS_Mult_Menu        => 16#0020#,
  232.        MIS_Sys_Command      => 16#0030#,
  233.        MIS_Help             => 16#0080#,
  234.        MIS_Static           => 16#0100#,
  235.        MIS_Button_Separator => 16#0200#,
  236.        MIS_Break            => 16#0400#,
  237.        MIS_Break_Separator  => 16#0800#,
  238.        MIS_Group            => 16#1000#,
  239.        MIS_Single           => 16#2000#);
  240.  
  241.   ------------------------------------------------
  242.  
  243.    MIA_Values : constant array (Menu_Attribute_Type) of Pm_Types.U_Short := (
  244.         MIA_No_Dismiss  => 16#0020#,
  245.         MIA_Framed      => 16#1000#,
  246.         MIA_Checked     => 16#2000#,
  247.         MIA_Disabled    => 16#4000#,
  248.         MIA_Highlighted => 16#8000#);
  249.  
  250.   ------------------------------------------------
  251.  
  252.    Pop_Up_Values : constant array (Pop_Up_Option_Type) of Pm_Types.U_Short := (
  253.       Pu_Position_On_Item     => 16#0001#,
  254.       Pu_Horz_Constrained     => 16#0002#,
  255.       Pu_Vert_Constrained     => 16#0004#,
  256.       Pu_None                 => 16#0000#,
  257.       Pu_Mouse_Button_1_Down  => 16#0008#,
  258.       Pu_Mouse_Button_2_Down  => 16#0010#,
  259.       Pu_Mouse_Button_3_Down  => 16#0018#,
  260.       Pu_Select_Item          => 16#0020#,
  261.       Pu_Mouse_Button_1       => 16#0040#,
  262.       Pu_Mouse_Button_2       => 16#0080#,
  263.       Pu_Mouse_Button_3       => 16#0100#,
  264.       Pu_Keyboard             => 16#0200#);
  265.  
  266.   ------------------------------------------------
  267.  
  268.    type OS2_Menu_Item_Type is
  269.       record
  270.         IPosition   : Pm_Types.Short;
  271.         Style       : Pm_Types.U_Short;
  272.         Attribute   : Pm_Types.U_Short;
  273.         Id          : Pm_Types.U_Short;
  274.         SubMenu     : Handle_Type;
  275.         Item_Handle : Pm_Types.U_Long; 
  276.       end record;
  277.  
  278.   ------------------------------------------------
  279.  
  280.    function Failed (Value : Boolean) return Boolean is
  281.      begin
  282.        return not Value;
  283.      end Failed;
  284.  
  285.   ------------------------------------------------
  286.  
  287.   function To_Boolean   (Void : Void_Type) return Boolean is
  288.     begin
  289.       return Void = 1;
  290.     end To_Boolean;
  291.  
  292.   ------------------------------------------------
  293.  
  294.   function To_Short     (Void : Void_Type) return Pm_Types.Short is
  295.     begin
  296.       return Pm_Types.Short (Void);
  297.     end To_Short;
  298.  
  299.   ------------------------------------------------
  300.  
  301.   function To_U_Short   (Void : Void_Type) return Pm_Types.U_Short is
  302.     begin
  303.       return Pm_Types.U_Short (Void);
  304.     end To_U_Short;
  305.  
  306.   ------------------------------------------------
  307.  
  308.   function Parm_to_SPT is new Unchecked_Conversion (
  309.                                  Target => Short_Point_Type,
  310.                                  Source => Win.Parameter_Type);
  311.  
  312.   ------------------------------------------------
  313.  
  314.   function Is_Null (Window       : Handle_Type) return Boolean is
  315.     begin
  316.       return Window = Null_Window;
  317.     end Is_Null;
  318.  
  319.   ------------------------------------------------
  320.  
  321.   function Is_Null (Queue        : Queue_Handle_Type) return Boolean is
  322.     begin
  323.       return Queue = Null_Queue;
  324.     end Is_Null;
  325.  
  326.   ------------------------------------------------
  327.  
  328.   function Is_Null (Anchor_Block : Anchor_Block_Handle_Type) return Boolean is
  329.     begin
  330.       return Anchor_Block = Null_Anchor_Block;
  331.     end Is_Null;
  332.  
  333.   ------------------------------------------------
  334.  
  335.   function Is_Null (PS           : PS_Type) return Boolean is
  336.     begin
  337.       return PS = Null_Ps;
  338.     end Is_Null;
  339.  
  340.   ------------------------------------------------
  341.  
  342.   function Is_Null (Bitmap        : Bitmap_Handle_Type) return Boolean is
  343.     begin
  344.       return Bitmap = Null_Bitmap;
  345.     end Is_Null;
  346.  
  347.   ------------------------------------------------
  348.  
  349.   function Is_Null (Internal_Menu : Internal_Menu_Item_Type) return Boolean is
  350.     begin
  351.       return Internal_Menu = Null_Internal_Menu;
  352.     end Is_Null;
  353.  
  354.   ------------------------------------------------
  355.  
  356.   function Get_Error_Info (Anchor_Block : Anchor_Block_Handle_Type)
  357.                                      return Error_Info_Pointer_Type is
  358.      function WinGetErrorInfo (Hab : Anchor_Block_Handle_Type) 
  359.                                         return Error_Info_Pointer_Type;
  360.       pragma Import (Convention => C,
  361.                      Entity     => WinGetErrorInfo,
  362.                      Link_Name  => "*WinGetErrorInfo");
  363.      
  364.     begin
  365.       return WinGetErrorInfo (Anchor_Block);
  366.     end Get_Error_Info;
  367.  
  368.   ------------------------------------------------
  369.  
  370.   function Get_Last_Error (Anchor_Block : Anchor_Block_Handle_Type) 
  371.                                                   return Pm_Types.U_Long is
  372.   
  373.      function WinGetLastError (Hab : Anchor_Block_Handle_Type)
  374.                                                   return Pm_Types.U_Long;
  375.       pragma Import (Convention => C,
  376.                      Entity     => WinGetLastError,
  377.                      Link_Name  => "*WinGetLastError");
  378.      
  379.       Error : Pm_Types.U_Long;     
  380.     begin
  381.  
  382.       Text_IO.Put ("Pm_Types.U_Long Size => ");
  383.       Text_Io.Put_Line (Integer'Image (Pm_Types.U_Long'size));
  384.  
  385.       Error := WinGetLastError (Anchor_Block);
  386.       Text_Io.Put ("Error num is ");
  387.       Text_Io.Put_Line (Integer'image (Integer (Error)));
  388.       return Error;
  389.     end Get_Last_Error;
  390.  
  391.   ------------------------------------------------
  392.  
  393.   function Initialize (
  394.                        Options : Pm_Types.U_Long := System_Default  
  395.                                        ) return Anchor_Block_Handle_Type is
  396.  
  397.       function WinInitialize (Options : Pm_Types.U_Long) 
  398.                                           return Anchor_Block_Handle_Type;
  399.          pragma Import (Convention => C,
  400.                         Entity     => WinInitialize,
  401.                         Link_Name  => "*WinInitialize");
  402.     begin
  403. --      return Null_Anchor_Block;
  404.       return WinInitialize (Options);
  405.     end Initialize;
  406.  
  407.   ------------------------------------------------
  408.  
  409.   procedure Initialize (
  410.                Options      : in     Pm_Types.U_Long := System_Default;
  411.                Anchor_Block :    out Anchor_Block_Handle_Type) is
  412.     begin
  413.       Anchor_Block := Initialize (Options);
  414.       --Currently OS/2 does not use the Anchor_Block parameter.  It is 
  415.       --usally set to null and not used.  
  416.     end Initialize;
  417.  
  418.   ------------------------------------------------
  419.  
  420.    function Register_Class (Anchor_Block   : Anchor_Block_Handle_Type;
  421.                            Class_Name      : String;
  422.                            Message_Handler : Message_Handler_Function;
  423.                            Class_Style     : Class_Styles_Type;
  424.                            Extra_Storage   : Pm_Types.U_Short)
  425.                                                         return Boolean is
  426.  
  427.       function WinRegisterClass (Anchor_Block  : Anchor_Block_Handle_Type;
  428.                                  Name          : System.Address;
  429.                                  Msg_Handler   : Message_Handler_Function;
  430.                                  Win_Style     : Pm_Types.U_Long;
  431.                                  Extra_Storage : Pm_Types.U_Short) 
  432.                                                      return Pm_Types.U_Long;
  433.        pragma Import (Convention => C,
  434.                       Entity     => WinRegisterClass,
  435.                       Link_Name  => "*WinRegisterClass");
  436.  
  437.        Class_Str : String (Class_Name'first .. Class_Name'last + 1);
  438.  
  439.        Style     : Pm_Types.U_Long := 0;
  440.  
  441.        Result    : Pm_Types.U_Long;
  442.  
  443.       use Pm_Types;
  444.     begin
  445.  
  446.        Class_Str (Class_Str'first .. Class_Str'last - 1) := Class_Name;
  447.        Class_Str (Class_Str'last) := Ascii.Nul;
  448.  
  449.        for I in Class_Style'range loop
  450.          if Class_Style (I) then
  451.            Style := Style + Win_Style_Values (I);
  452.          end if;
  453.        end loop;
  454.  
  455.        Result := WinRegisterClass (
  456.             Anchor_Block  => Anchor_Block,
  457.             Name          => Class_Str (Class_Str'first)'address,
  458.             Msg_Handler   => Message_Handler,
  459.             Win_Style     => Style,
  460.             Extra_Storage => Extra_Storage); 
  461.  
  462.        if Result = 1 then
  463.           return True;
  464.        end if;
  465.  
  466.       return False;
  467.  
  468.     end Register_Class;
  469.  
  470.   ------------------------------------------------
  471.  
  472.   procedure Register_Class (Anchor_Block    : Anchor_Block_Handle_Type;
  473.                             Class_Name      : String;
  474.                             Message_Handler : Message_Handler_Function;
  475.                             Class_Style     : Class_Styles_Type;
  476.                             Extra_Storage   : Pm_Types.U_Short) is
  477.    begin
  478.     if Register_Class (Anchor_Block, 
  479.                        Class_Name, 
  480.                        Message_Handler, 
  481.                        Class_Style, 
  482.                        Extra_Storage) then
  483.       null;
  484.     else
  485.       raise Register_Failed;
  486.     end if;
  487.    end Register_Class;
  488.  
  489.   ------------------------------------------------
  490.  
  491.    Kc_Flag_Values : constant array (Key_Flag_Type) of Pm_Types.U_Short :=
  492.        (Kc_None              => 16#0000#,
  493.         Kc_Char              => 16#0001#,
  494.         Kc_Virtual_Key       => 16#0002#,
  495.         Kc_Scan_Code         => 16#0004#,
  496.         Kc_Shift             => 16#0008#,
  497.         Kc_Ctrl              => 16#0010#,
  498.         Kc_Atl               => 16#0020#,
  499.         Kc_Key_Up            => 16#0040#,
  500.         Kc_Previous_Down     => 16#0080#,
  501.         Kc_Lone_Key          => 16#0100#,
  502.         Kc_Dead_Key          => 16#0200#,
  503.         Kc_Composite         => 16#0400#,
  504.         Kc_Invalid_Composite => 16#0800#,
  505.         Kc_Toggle            => 16#1000#,
  506.         Kc_Invalid_Character => 16#2000#,
  507.         Kc_DB_CSR_SR_VD1     => 16#4000#,
  508.         Kc_Db_CSR_SR_VD2     => 16#8000#);
  509.  
  510.  
  511.     function Set_Flags (Key_Flag_Values : Pm_Types.U_Short) 
  512.                                               return Key_Flags_Type is
  513.        Values : Pm_Types.U_Short := Key_Flag_Values; 
  514.        Flags  : Key_Flags_Type := (Others => False);
  515.  
  516.        use Pm_Types;
  517.  
  518.     begin
  519.       
  520.        if Key_Flag_Values = 0 then
  521.           Flags (Kc_None) := True;
  522.        else
  523.  
  524.          for I in reverse Flags'range loop
  525.  
  526.            exit when I = Flags'first;
  527.  
  528.            if Values >= Kc_Flag_Values (I) then
  529.               Flags (I) := True;
  530.               Values := Values - Kc_Flag_Values (I);
  531.            end if;
  532.  
  533.          end loop;
  534.        end if;             
  535.          
  536.        return Flags;
  537.    end Set_Flags;
  538.  
  539.   ------------------------------------------------
  540.  
  541.    function Set_Virtual_Key (Virtual_Code : Pm_Types.U_Short) 
  542.                                             return Virtual_Key_Type is
  543.       V_Key : Virtual_Key_Type;
  544.      begin
  545.        
  546.        if Virtual_Code in 16#01# .. 16#38# then
  547.           V_Key := Virtual_Key_Type'Val (Integer (Virtual_Code) - 1);
  548.        else
  549.           V_Key := Vk_Null;
  550.        end if;
  551.  
  552.        if V_Key = Vk_F10 then
  553.           V_Key := Vk_Menu;
  554.        end if;
  555.  
  556.        return V_Key;
  557.      end Set_Virtual_Key;
  558.  
  559.  ------------------------------------------------
  560.  
  561.   type CM_1_Type is
  562.     record
  563.      Flags    : PM_Types.U_Short;
  564.      Repeat   : Pm_Types.U_Byte;
  565.      Scancode : Pm_Types.U_Byte;
  566.     end record;
  567.  
  568.   function Parm_To_Cm_1 is new Unchecked_Conversion (
  569.                                     Source => Parameter_Type,
  570.                                     Target => Cm_1_Type);  
  571.  
  572.   type Cm_2_Type is 
  573.     record
  574.      Char_Code    : Pm_Types.U_Short;
  575.      Virtual_Code : Pm_Types.U_Short;
  576.     end record; 
  577.  
  578.   function Parm_To_Cm_2 is new Unchecked_Conversion (
  579.                                     Source => Parameter_Type,
  580.                                     Target => Cm_2_Type);  
  581.  
  582.  function Key_Info_Is (Message_Parameter_1 : Parameter_Type;
  583.                        Message_Parameter_2 : Parameter_Type) 
  584.                                      return Key_Press_Info_Type is
  585.      Info : Key_Press_Info_Type;
  586.  
  587.      Cm_1 : Cm_1_Type;
  588.      Cm_2 : Cm_2_Type;
  589.  
  590.     begin
  591.  
  592.       Cm_1 := Parm_To_Cm_1 (Message_Parameter_1);
  593.       Cm_2 := Parm_To_Cm_2 (Message_Parameter_2);
  594.  
  595.       Info.Flags          := Set_Flags (Cm_1.Flags);
  596.       Info.Repeat_Count   := Cm_1.Repeat;
  597.       Info.Scan_Code      := Cm_1.Scancode;
  598.  
  599.       Info.Character_Code := Cm_2.Char_Code;
  600.       Info.Virtual_Key    := Set_Virtual_Key (Cm_2.Virtual_Code); 
  601.  
  602.       return Info;
  603.  
  604.     end Key_Info_Is;
  605.  
  606.   ------------------------------------------------
  607.  
  608.   type Command_Info_2_Type is 
  609.     record
  610.      Source     : Pm_Types.U_Short;
  611.      By_Pointer : Pm_Types.U_Short; 
  612.     end record; 
  613.  
  614.   function Parm_To_CI_2 is new Unchecked_Conversion (
  615.                                    Source => Parameter_Type,
  616.                                    Target => Command_Info_2_Type);  
  617.  
  618.   function Command_Info_Is (Message_Parameter_1 : Parameter_Type;
  619.                             Message_Parameter_2 : Parameter_Type) 
  620.                                           return Command_Info_Type is
  621.      Info   : Command_Info_Type;
  622.      Info_2 : Command_Info_2_Type; 
  623.     begin
  624.       
  625.       Info.Id         := Command_Id_Type (Message_Parameter_1);
  626.       Info_2          := Parm_To_Ci_2 (Message_Parameter_2);
  627.       Info.Source     := Command_Source_Values (Info_2.Source);
  628.       Info.By_Pointer := Info_2.By_Pointer = 1;
  629.  
  630.       return Info;
  631.     end Command_Info_Is;
  632.  
  633.   ------------------------------------------------
  634.  
  635.   function Pointer_Is (Parameter : Parameter_Type) return Point_Type is
  636.      Spt : Short_Point_Type;
  637.    begin
  638.      Spt := Parm_To_Spt (Parameter);
  639.      return (Pixel_Type (Spt.X), Pixel_Type (Spt.Y));
  640.    end Pointer_Is;
  641.  
  642.   ------------------------------------------------
  643.  
  644.      type Two_Shorts is
  645.        record
  646.          Short_1 : Pm_Types.U_Short;
  647.          Short_2 : Pm_Types.U_Short;
  648.        end record;
  649.      
  650.      function Shorts_To_Mp is new Unchecked_Conversion (
  651.                                            Target => Parameter_Type, 
  652.                                            Source => Two_Shorts);
  653.  
  654.      function Check_Menu_Item (
  655.               Menu    : Handle_Type;
  656.               Item_Id : Command_Id_Type;
  657.               Check   : Boolean) return Boolean is
  658.  
  659.        Mp_1   : Parameter_Type;
  660.        Mp_2   : Parameter_Type;
  661.  
  662.        Values : Two_Shorts; 
  663.  
  664.        Result : Boolean;
  665.       
  666.      begin 
  667.  
  668.         Values.Short_1 := Pm_Types.U_Short (Item_Id);
  669.         Values.Short_2 := Short_True; 
  670.         Mp_1 := Shorts_To_Mp (Values);
  671.  
  672.         Values.Short_1 := MIA_Values (Mia_Checked);
  673.  
  674.         if Check then
  675.           Values.Short_2 := MIA_Values (Mia_Checked);
  676.         else
  677.           Values.Short_2 := Short_False;
  678.         end if;
  679.  
  680.         Mp_2 := Shorts_To_Mp (Values);
  681.  
  682.         Result := To_Boolean (
  683.                     Send_Message (
  684.                         To_Window   => Menu,
  685.                         Message     => MM_Set_Item_Attr,
  686.                         Parameter_1 => Mp_1,
  687.                         Parameter_2 => Mp_2));
  688.                       
  689.         return Result;
  690.  
  691.       end Check_Menu_Item; 
  692.  
  693.   ------------------------------------------------
  694.  
  695.     function Enable_Menu_Item (
  696.               Menu     : Handle_Type;
  697.               Item_Id  : Command_Id_Type;
  698.               Enable   : Boolean) return Boolean is
  699.  
  700.        Mp_1   : Parameter_Type;
  701.        Mp_2   : Parameter_Type;
  702.  
  703.        Values : Two_Shorts; 
  704.  
  705.        Result : Boolean;
  706.       
  707.      begin 
  708.  
  709.         Values.Short_1 := Pm_Types.U_Short (Item_Id);
  710.         Values.Short_2 := Short_True; 
  711.         Mp_1 := Shorts_To_Mp (Values);
  712.  
  713.         Values.Short_1 := MIA_Values (Mia_Disabled);
  714.  
  715.         if Enable then
  716.           Values.Short_2 := MIA_Values (Mia_Disabled);
  717.         else
  718.           Values.Short_2 := Short_False;
  719.         end if;
  720.  
  721.         Mp_2 := Shorts_To_Mp (Values);
  722.  
  723.         Result := To_Boolean (
  724.                     Send_Message (
  725.                         To_Window   => Menu,
  726.                         Message     => MM_Set_Item_Attr,
  727.                         Parameter_1 => Mp_1,
  728.                         Parameter_2 => Mp_2));
  729.                       
  730.         return Result;
  731.  
  732.       end Enable_Menu_Item; 
  733.  
  734.   ------------------------------------------------
  735.  
  736.    function Load_Menu (
  737.                   Owner_Window : Handle_Type;
  738.                   Resource     : PULong;
  739.                   Menu_Id      : Id_Type) return Handle_Type is
  740.  
  741.       function WinLoadMenu (
  742.                   Owner_Window : Handle_Type;
  743.                   Resource     : PULong;
  744.                   Menu_Id      : Id_Type) return Handle_Type;
  745.  
  746.          pragma Import (Convention => C,
  747.                         Entity     => WinLoadMenu,
  748.                         Link_Name  => "*WinLoadMenu");
  749.        
  750.       Result : Handle_Type;
  751.  
  752.    begin
  753.  
  754.      Result := WinLoadMenu (
  755.                   Owner_Window => Owner_Window,
  756.                   Resource     => Resource,
  757.                   Menu_Id      => Menu_Id);
  758.  
  759.      return Result;
  760.    end Load_Menu;
  761.    
  762.   ------------------------------------------------
  763.   
  764.    function Convert_Pop_Up_Options (Options : Pop_Up_Options_Type) return Pm_Types.U_Short is
  765.      Value : Pm_Types.U_Short := 0;
  766.      use Pm_Types;
  767.    begin
  768.      for I in Options'range loop
  769.        if Options (I) then
  770.          Value := Value + Pop_Up_Values (I);
  771.        end if;
  772.      end loop;
  773.      return Value;
  774.    end Convert_Pop_Up_Options;
  775.  
  776.   ------------------------------------------------
  777.  
  778.    function Pop_Up_Menu (
  779.         Window       : Handle_Type;
  780.         Frame_Window : Handle_Type;
  781.         Menu_Window  : Handle_Type;
  782.         X            : Pixel_Type;
  783.         Y            : Pixel_Type;
  784.         Item_Id      : Command_Id_Type;
  785.         Options      : Pop_Up_Options_Type) return Boolean is
  786.     
  787.      function WinPopupMenu (
  788.         Window       : Handle_Type;
  789.         Frame_Window : Handle_Type;
  790.         Menu_Window  : Handle_Type;
  791.         X            : Pixel_Type;
  792.         Y            : Pixel_Type;
  793.         Item_Id      : Pm_Types.U_Long;
  794.         Options      : Pm_Types.U_Short) return Pm_Types.U_Long;
  795.  
  796.          pragma Import (Convention => C,
  797.                         Entity     => WinPopupMenu,
  798.                         Link_Name  => "*WinPopupMenu");
  799.        
  800.       Result : Pm_Types.U_Long;
  801.  
  802.    begin
  803.  
  804.       Result := WinPopupMenu (
  805.                  Window       => Window,
  806.                  Frame_Window => Frame_Window,
  807.                  Menu_Window  => Menu_Window,
  808.                  X            => X,
  809.                  Y            => Y,
  810.                  Item_Id      => Pm_Types.U_Long (Item_Id),
  811.                  Options      => Convert_Pop_Up_Options (Options));
  812.  
  813.       return Result = 1;
  814.    end Pop_Up_Menu;    
  815.  
  816.   -------------------------------------------------------
  817.              
  818.    procedure Pop_Up_Menu (
  819.         Window       : in Handle_Type;
  820.         Frame_Window : in Handle_Type;
  821.         Menu_Window  : in Handle_Type;
  822.         X            : in Pixel_Type;
  823.         Y            : in Pixel_Type;
  824.         Item_Id      : in Command_Id_Type;
  825.         Options      : in Pop_Up_Options_Type) is
  826.     begin
  827.       if Failed (Pop_Up_Menu (
  828.                    Window       => Window,
  829.                    Frame_Window => Frame_Window,
  830.                    Menu_Window  => Menu_Window,
  831.                    X            => X,
  832.                    Y            => Y,
  833.                    Item_Id      => Item_Id,
  834.                    Options      => Options)) then
  835.          raise Win_Error;
  836.       end if;
  837.     end Pop_Up_Menu;
  838.  
  839.   ------------------------------------------------
  840.  
  841.    function Create_Internal_Menu return Internal_Menu_Item_Type is
  842.      begin
  843.        return new OS2_Menu_Item_Type;
  844.      end Create_Internal_Menu;
  845.  
  846.   ------------------------------------------------
  847.    procedure Reclaim_Internal_Menu is new Unchecked_Deallocation (
  848.                                              OS2_Menu_Item_Type,
  849.                                              Internal_Menu_Item_Type);
  850.  
  851.    procedure Destroy_Internal_Menu (Internal_Menu : in out Internal_Menu_Item_Type) is
  852.      begin
  853.        Reclaim_Internal_Menu (Internal_Menu);
  854.        Internal_Menu := Null_Internal_Menu;
  855.      end Destroy_Internal_Menu;       
  856.  
  857.   ------------------------------------------------
  858.  
  859.    function Make_Mia_Value (Atts : Menu_Attributes_Type) return Pm_Types.U_Short is
  860.      Value : Pm_Types.U_Short := 0;
  861.      use Pm_Types;
  862.    begin
  863.  
  864.      for I in Atts'range loop
  865.        if Atts (I) then
  866.          Value := Value + Mia_Values (I);
  867.        end if;
  868.      end loop;
  869.  
  870.      return Value;
  871.    end Make_Mia_Value;
  872.  
  873.   ------------------------------------------------
  874.  
  875.  
  876.    function Convert_To_Internal (Menu_Item : Menu_Item_Type) 
  877.                                         return Internal_Menu_Item_Type is
  878.        I_Menu : Internal_Menu_Item_Type;
  879.      begin
  880.        I_Menu := Create_Internal_Menu;
  881.         
  882.        I_Menu.IPosition   := Pm_Types.Short (Menu_Item.Position);
  883.        I_Menu.Style       := MIS_Values (Menu_Item.Style);
  884.        I_Menu.Attribute   := Make_MIA_Value (Menu_Item.Attributes);
  885.        I_Menu.Id          := Pm_Types.U_Short (Menu_Item.Item_Id);
  886.        I_Menu.SubMenu     := Menu_Item.Sub_Menu;
  887.        I_Menu.Item_Handle := Pm_Types.U_Long (Menu_Item.Item_Handle);
  888.  
  889.        return I_Menu;
  890.  
  891.      end Convert_To_Internal;
  892.  
  893.   ------------------------------------------------
  894.  
  895.    function Convert_To_Style (Value : Pm_Types.U_Short) 
  896.                                          return Menu_Style_Type is
  897.      begin
  898.      
  899.        for I in MIS_Values'range loop
  900.          if MIS_Values (I) = Value then
  901.            return I;
  902.          end if;
  903.        end loop;
  904.  
  905.        return Mis_Text;
  906.      end Convert_To_Style;
  907.  
  908.   ------------------------------------------------
  909.  
  910.    function Convert_To_Attribute (Value : Pm_Types.U_Short) 
  911.                                        return Menu_Attributes_Type is
  912.       Atts : Menu_Attributes_Type;
  913.       Val  : Pm_Types.U_Short := Value;
  914.  
  915.       use Pm_Types;
  916.      begin
  917.  
  918.        Atts := (others => False);
  919.        for I in reverse MIA_Values'range loop
  920.  
  921.          if Val >= MIA_Values (I) then
  922.             Atts (I) := True;
  923.             Val := Val - Mia_Values (I);
  924.          end if;
  925.  
  926.        end loop;
  927.  
  928.        return Atts;
  929.  
  930.      end Convert_To_Attribute;
  931.  
  932.   ------------------------------------------------
  933.  
  934.    function Convert_To_External (Menu_Item : Internal_Menu_Item_Type) 
  935.                                                   return Menu_Item_Type is
  936.       Data : Menu_Item_Type;
  937.      begin
  938.  
  939.        Data.Position    := Menu_Position_Type (Menu_Item.IPosition);
  940.        Data.Style       := Convert_To_Style (Menu_Item.Style);
  941.        Data.Attributes  := Convert_To_Attribute (Menu_Item.Attribute);
  942.        Data.Item_Id     := Command_Id_Type (Menu_Item.ID);
  943.        Data.Sub_Menu    := Menu_Item.SubMenu;
  944.        Data.Item_Handle := Bitmap_Handle_Type (Menu_Item.Item_Handle);
  945.  
  946.        return Data;
  947.  
  948.      end Convert_To_External;
  949.  
  950.   ------------------------------------------------
  951.  
  952.      function Addr_To_Parm is new Unchecked_Conversion (
  953.                                  Target => Win.Parameter_Type,
  954.                                  Source => System.Address);
  955.  
  956.      function Addr_To_Int_Menu is new Unchecked_Conversion (
  957.                                  Target => Internal_Menu_Item_Type,
  958.                                  Source => System.Address);
  959.  
  960.   ------------------------------------------------
  961.  
  962.    function Query_Menu_Item (
  963.               Menu    : Handle_Type;
  964.               Item_Id : Command_Id_Type) return Menu_Item_Type is
  965.       Data    : Menu_Item_Type;
  966.       I_Menu  : OS2_Menu_Item_Type;
  967.       Mp_1    : Parameter_Type;
  968.       Mp_2    : Parameter_Type;
  969.       Mp_Data : Two_Shorts;
  970.  
  971.       Good  : Boolean;
  972.      begin
  973.  
  974.       Mp_Data.Short_1 := Pm_Types.U_Short (Item_Id);
  975.       Mp_Data.Short_2 := Short_True;
  976.  
  977.       Mp_1 := Shorts_To_Mp (Mp_Data);
  978.       Mp_2 := Addr_To_Parm (I_Menu'address);
  979.  
  980.       Good := To_Boolean (
  981.                   Send_Message (
  982.                     To_Window   => Menu,
  983.                     Message     => MM_Query_Item,
  984.                     Parameter_1 => Mp_1,
  985.                     Parameter_2 => Mp_2));
  986.  
  987.       if Good then     
  988.          return Convert_To_External (Addr_To_Int_Menu (I_Menu'address));
  989.       else
  990.          Text_Io.Put_Line ("The Send message failed");
  991.       end if;
  992.  
  993.       return Data;
  994.  
  995.      end Query_Menu_Item;       
  996.  
  997.   ------------------------------------------------
  998.  
  999.    procedure Set_Menu_Item (
  1000.                       Menu      : in Handle_Type;
  1001.                       Menu_Data : in Menu_Item_Type) is
  1002.      begin
  1003.        null;
  1004.      end Set_Menu_Item;
  1005.  
  1006.   ------------------------------------------------
  1007.  
  1008.    procedure Insert_Menu_Item (
  1009.                      Menu      : in Handle_Type;
  1010.                      Menu_Data : in Menu_Item_Type) is
  1011.      begin
  1012.        null;
  1013.      end Insert_Menu_Item;
  1014.  
  1015.   ------------------------------------------------
  1016.  
  1017.    procedure Delete_Menu_Item (
  1018.                      Menu      : in Handle_Type;
  1019.                      Menu_Data : in Menu_Item_Type) is
  1020.      begin
  1021.        null;
  1022.      end Delete_Menu_Item;
  1023.  
  1024.   ------------------------------------------------
  1025.  
  1026.   function Default_Window_Procedure 
  1027.                           (Window              : Handle_Type;
  1028.                            Message             : Message_Type;
  1029.                            Message_Parameter_1 : Parameter_Type;  
  1030.                            Message_Parameter_2 : Parameter_Type)                  
  1031.                                               return Pm_Types.U_Long is
  1032.  
  1033.      function WinDefWindowProc 
  1034.                           (Window              : Handle_Type;
  1035.                            Message             : Message_Type;
  1036.                            Message_Parameter_1 : Parameter_Type;  
  1037.                            Message_Parameter_2 : Parameter_Type)                  
  1038.                                                return Pm_Types.U_Long;
  1039.          pragma Import (Convention => C,
  1040.                         Entity     => WinDefWindowProc,
  1041.                         Link_Name  => "*WinDefWindowProc");
  1042.        
  1043.       Result : Pm_Types.U_Long;
  1044.     begin
  1045.       Result := WinDefWindowProc (
  1046.                          Window              => Window, 
  1047.                          Message             => Message, 
  1048.                          Message_Parameter_1 => Message_Parameter_1, 
  1049.                          Message_Parameter_2 => Message_Parameter_2);
  1050.       return Result;
  1051.  
  1052.     end Default_Window_Procedure;
  1053.  
  1054.   ------------------------------------------------
  1055.  
  1056.   function Window_From_Id (
  1057.             Parent_Window : Handle_Type;
  1058.             Frame_Id      : Frame_Id_Type) return Handle_Type is
  1059.     
  1060.         function WinWindowFromId (
  1061.             Parent_Window : Handle_Type;
  1062.             Frame_Id      : Pm_Types.U_Long) return Handle_Type;
  1063.     
  1064.         pragma Import (Convention => C,
  1065.                         Entity     => WinWindowFromId,
  1066.                         Link_Name  => "*WinWindowFromID");
  1067.      Window : Handle_Type;       
  1068.    begin
  1069.  
  1070.      Window := WinWindowFromId (
  1071.                 Parent_Window => Parent_Window,
  1072.                 Frame_id      => Frame_id_Values (Frame_ID));
  1073.  
  1074.      return Window;
  1075.  
  1076.    end Window_From_Id;
  1077.  
  1078.   ------------------------------------------------
  1079.  
  1080.  
  1081.   function Create_Standard_Window (
  1082.             Parent_Window       : Handle_Type;
  1083.             Window_Styles       : Window_Styles_Type;
  1084.             Frame_Control_Flags : Frame_Control_Flags_Type;
  1085.             Class_Name          : String;
  1086.             Window_Title        : String;
  1087.             Class_Style         : Class_Styles_Type;
  1088.             Resource            : PULong;
  1089.             Resource_ID         : Pm_Types.U_Long;
  1090.             New_Window          : Handle_Pointer_Type)
  1091.                                           return Handle_Type is
  1092.  
  1093.      function WinCreateStdWindow (
  1094.             Parent_Window       : Handle_Type;
  1095.             Window_Styles       : Pm_Types.U_Long;
  1096.             Frame_Control_Flags : System.Address;
  1097.             Class_Name          : System.Address;
  1098.             Window_Title        : System.Address;
  1099.             Class_Style         : Pm_Types.U_Long;
  1100.             Resource            : PULong;
  1101.             Resource_ID         : Pm_Types.U_Long;
  1102.             New_Window          : Handle_Pointer_Type) 
  1103.                                               return Handle_Type;
  1104.  
  1105.          pragma Import (Convention => C,
  1106.                         Entity     => WinCreateStdWindow,
  1107.                         Link_Name  => "*WinCreateStdWindow");
  1108.  
  1109.        Class_Str   : String (Class_Name'first .. Class_Name'last + 1);
  1110.        Title_Str   : String (Window_Title'first .. Window_Title'last + 1);
  1111.  
  1112.        Frame_Value : Pm_Types.U_Long := 0; 
  1113.        Win_Style   : Pm_Types.U_Long := 0;
  1114.        Style       : Pm_Types.U_Long := 0;
  1115.  
  1116.        use PM_Types;
  1117.     begin
  1118.  
  1119.       Class_Str (Class_Str'first .. Class_Str'last - 1) := Class_Name;
  1120.       Class_Str (Class_Str'last) := Ascii.Nul;
  1121.  
  1122.       Title_Str (Title_Str'first .. Title_Str'last - 1) := Window_Title;
  1123.       Title_Str (Title_Str'last) := Ascii.Nul;
  1124.  
  1125.       for I in Frame_Control_Flags'range loop
  1126.         if Frame_Control_Flags (I) then
  1127.            Frame_Value := Frame_Value + Frame_Values (I);
  1128.         end if;
  1129.       end loop;
  1130.       
  1131.       for I in Window_Styles'range loop
  1132.         if Window_Styles (I) then
  1133.            Win_Style := Win_Style + Window_Style_Values (I);
  1134.         end if;
  1135.       end loop;
  1136.  
  1137.        for I in Class_Style'range loop
  1138.          if Class_Style (I) then
  1139.            Style := Style + Win_Style_Values (I);
  1140.          end if;
  1141.        end loop;
  1142.  
  1143.       return WinCreateStdWindow (
  1144.                Parent_Window       => Parent_Window,
  1145.                Window_Styles       => Win_Style,
  1146.                Frame_Control_Flags => Frame_Value'address,
  1147.                Class_Name          => Class_Str (Class_Str'first)'address,
  1148.                Window_Title        => Title_Str (Title_Str'first)'address,
  1149.                Class_Style         => Style,
  1150.                Resource            => Resource,
  1151.                Resource_Id         => Resource_Id,
  1152.                New_Window          => New_Window); 
  1153.  
  1154.   end Create_Standard_Window;
  1155.  
  1156.   ------------------------------------------------
  1157.  
  1158.   function Set_Window_Position (
  1159.               Window           : Handle_Type;
  1160.               Behind_Window    : Handle_Type;
  1161.               X                : Device_Screen_Space_Type;
  1162.               Y                : Device_Screen_Space_Type;
  1163.               Width            : Device_Screen_Space_Type;
  1164.               Height           : Device_Screen_Space_Type;
  1165.               Position_Options : Position_Type) return Boolean is
  1166.  
  1167.     function WinSetWindowPos (
  1168.               Window           : Handle_Type;
  1169.               Behind_Window    : Handle_Type;
  1170.               X                : Device_Screen_Space_Type;
  1171.               Y                : Device_Screen_Space_Type;
  1172.               Width            : Device_Screen_Space_Type;
  1173.               Height           : Device_Screen_Space_Type;
  1174.               Position_Options : Pm_Types.U_Long) return Pm_Types.U_Long;    
  1175.  
  1176.          pragma Import (Convention => C,
  1177.                         Entity     => WinSetWindowPos,
  1178.                         Link_Name  => "*WinSetWindowPos");
  1179.      Pos_Value : Pm_Types.U_Long := 0;
  1180.      use Pm_Types;
  1181.    begin
  1182.  
  1183.      if Boolean_Value (Position_Options (Swp_Minimize)) +
  1184.         Boolean_Value (Position_Options (Swp_Maximize)) +
  1185.         Boolean_Value (Position_Options (Swp_Restore)) > 1 then
  1186.           raise Min_Max_Restore_Usage_Error;
  1187.      end if;
  1188.  
  1189.      for I in Position_Options'range loop
  1190.        if Position_Options (I) then
  1191.          Pos_Value := Pos_Value + Win_Position_Values (I);
  1192.        end if;
  1193.      end loop;
  1194.  
  1195.      return 0 /= WinSetWindowPos (
  1196.                    Window           => Window,
  1197.                    Behind_Window    => Behind_Window,
  1198.                    X                => X,
  1199.                    Y                => Y,
  1200.                    Width            => Width,
  1201.                    Height           => Height,
  1202.                    Position_Options => Pos_Value);
  1203.    end Set_Window_Position;
  1204.  
  1205.   ------------------------------------------------
  1206.  
  1207.   procedure Set_Window_Position (
  1208.               Window           : in Handle_Type;
  1209.               Behind_Window    : in Handle_Type;
  1210.               X                : in Device_Screen_Space_Type;
  1211.               Y                : in Device_Screen_Space_Type;
  1212.               Width            : in Device_Screen_Space_Type;
  1213.               Height           : in Device_Screen_Space_Type;
  1214.               Position_Options : in Position_Type) is
  1215.     begin
  1216.       if Set_Window_Position (Window, 
  1217.                               Behind_Window, 
  1218.                               X, Y, 
  1219.                               Width, Height, 
  1220.                               Position_Options) then
  1221.         null;
  1222.       else
  1223.         raise Set_Failed;
  1224.       end if;
  1225.     end Set_Window_Position;
  1226.  
  1227.   ------------------------------------------------
  1228.  
  1229.   function WinTerminate (Anchor : Anchor_Block_Handle_Type)
  1230.                                             return Pm_Types.U_Long;
  1231.  
  1232.    pragma Import (Convention => C,
  1233.                   Entity     => WinTerminate,
  1234.                   Link_Name  => "*WinTerminate");
  1235.  
  1236.  function Terminate_App (Anchor : Anchor_Block_Handle_Type) return Boolean is
  1237.  
  1238.    begin
  1239.      return WinTerminate (Anchor) /= 0;
  1240.    end Terminate_App;
  1241.  
  1242.   ------------------------------------------------
  1243.  
  1244.   function Create_Message_Queue (
  1245.               Anchor_Block  : Anchor_Block_Handle_Type;
  1246.               Queue_Size    : Pm_Types.Long := System_Default)
  1247.                               return Queue_Handle_Type is
  1248.         function WinCreateMsgQueue (
  1249.               Anchor_Block  : Anchor_Block_Handle_Type;
  1250.               Queue_Size    : Pm_Types.Long := System_Default)
  1251.                               return Queue_Handle_Type;
  1252.         pragma Import (Convention => C,
  1253.                        Entity     => WinCreateMsgQueue,
  1254.                        Link_Name  => "*WinCreateMsgQueue");
  1255.    begin
  1256.      return WinCreateMsgQueue (Anchor_Block, Queue_Size);
  1257.    end Create_Message_Queue;
  1258.  
  1259.   ------------------------------------------------
  1260.  
  1261.   procedure Create_Message_Queue (
  1262.               Anchor_Block  : in     Anchor_Block_Handle_Type;
  1263.               Queue_Size    : in     Pm_Types.Long := System_Default;
  1264.               Queue         :    out Queue_Handle_Type) is
  1265.      Temp_Queue : Queue_Handle_Type := Null_Queue;
  1266.     begin
  1267.       Temp_Queue := Create_Message_Queue (Anchor_Block, Queue_Size);
  1268.  
  1269.       if Is_Null (Temp_Queue) then
  1270.         raise Message_Queue_Was_Not_Created;
  1271.       end if;
  1272.  
  1273.       Queue := Temp_Queue;
  1274.     end Create_Message_Queue;
  1275.  
  1276.   ------------------------------------------------
  1277.  
  1278.   procedure Terminate_App (Anchor : in out Anchor_Block_Handle_Type) is
  1279.     Temp : Boolean;
  1280.    begin
  1281.     Temp   := Terminate_App (Anchor);
  1282.     Anchor := Null_Anchor_Block;
  1283.    end Terminate_App;
  1284.  
  1285.   ------------------------------------------------
  1286.  
  1287.   procedure Destroy_Message_Queue (Message_Queue : in out Queue_Handle_Type) is
  1288.     Temp : Boolean;
  1289.    begin
  1290.      Temp := Destroy_Message_Queue (Message_Queue);
  1291.      --Could add a check here and raise an exception if the message queue is
  1292.      --not destroyed. BJY 1/31/94
  1293.      Message_Queue := Null_Queue;
  1294.    end Destroy_Message_Queue;
  1295.  
  1296.   ------------------------------------------------
  1297.  
  1298.   function Destroy_Message_Queue (Message_Queue : Queue_Handle_Type)
  1299.                                                             return Boolean is
  1300.    
  1301.     function WinDestroyMsgQueue (Queue : Queue_Handle_Type)
  1302.                                                      return Pm_Types.U_Long;
  1303.  
  1304.     pragma Import (Convention => C,
  1305.                    Entity     => WinDestroyMsgQueue,
  1306.                    Link_Name  => "*WinDestroyMsgQueue");
  1307.    begin
  1308.      return WinDestroyMsgQueue (Message_Queue) /= 0;
  1309.    end Destroy_Message_Queue;
  1310.  
  1311.   ------------------------------------------------
  1312.  
  1313.   procedure Destroy_Window (Window : in out Handle_Type) is
  1314.      Temp : Boolean;
  1315.     begin
  1316.      Temp := Destroy_Window (Window);
  1317.      --Could add a check and raise and exception if the windows 
  1318.      --is not destroyed.  BJY 1/31/94
  1319.      Window := Null_Window;
  1320.     end Destroy_Window;
  1321.      
  1322.   ------------------------------------------------
  1323.  
  1324.   function Destroy_Window (Window : Handle_Type) return Boolean is
  1325.    
  1326.     function WinDestroyWindow (Window : Handle_Type) return Pm_Types.U_Long;
  1327.  
  1328.     pragma Import (Convention => C,
  1329.                    Entity     => WinDestroyWindow,
  1330.                    Link_Name  => "*WinDestroyWindow");
  1331.    begin
  1332.      return WinDestroyWindow (Window) /= 0;
  1333.    end Destroy_Window;
  1334.  
  1335.   ------------------------------------------------
  1336.  
  1337.    function Make_Style (
  1338.             Buttons        : MB_Button_Styles_Type;
  1339.             Icons          : MB_Icon_Styles_Type;   
  1340.             Default_Action : MB_Default_Action_Type;
  1341.             Modality       : MB_Modality_Type := MB_Application_Modal;
  1342.             Help_Button    : Boolean          := False;
  1343.             Moveable       : Boolean          := True) 
  1344.                                             return Pm_Types.U_Long is
  1345.        Style_Value : Pm_Types.U_Long := 0;
  1346.        use Pm_Types;
  1347.      begin
  1348.        Style_Value := Mb_Buttons (Buttons)
  1349.                        + MB_Icons (Icons)
  1350.                         + MB_Action (Default_Action)
  1351.                          + MB_Modality (Modality)
  1352.                           + MB_Help (Help_Button)
  1353.                            + MB_Moveable (Moveable);
  1354.        return Style_Value; 
  1355.      end Make_Style;
  1356.  
  1357.   ------------------------------------------------
  1358.  
  1359.   function Message_Box (
  1360.             Parent_Window  : Handle_Type;
  1361.             Request_Owner  : Handle_Type;
  1362.             Message        : String;
  1363.             Title          : String;
  1364.             Help_Id        : Help_Id_Type;
  1365.             Buttons        : MB_Button_Styles_Type;
  1366.             Icons          : MB_Icon_Styles_Type;   
  1367.             Default_Action : MB_Default_Action_Type;
  1368.             Modality       : MB_Modality_Type := MB_Application_Modal;
  1369.             Help_Button    : Boolean          := False;
  1370.             Moveable       : Boolean          := True)
  1371.                                             return MB_Response_Type is
  1372.  
  1373.        function WinMessageBox (
  1374.                    Parent    : Handle_Type;
  1375.                    Owner     : Handle_Type;
  1376.                    Text      : System.Address;
  1377.                    Title     : System.Address;
  1378.                    Window_Id : Pm_Types.U_Short;
  1379.                    Style     : Pm_Types.U_Long) return Pm_Types.U_Short;
  1380.  
  1381.         pragma Import (Convention => C,
  1382.                        Entity     => WinMessageBox,
  1383.                        Link_Name  => "*WinMessageBox");
  1384.        Response : Pm_Types.U_Short;
  1385.        Result   : Mb_Response_Type;
  1386.        Style    : Pm_Types.U_Long;
  1387.  
  1388.        Text_Str  : String (Message'first .. Message'last + 1);
  1389.        Title_Str : String (Title'first .. Title'last + 1); 
  1390.  
  1391.     begin
  1392.  
  1393.       Text_Str (Text_Str'first .. Text_Str'last - 1) := Message;
  1394.       Text_Str (Text_Str'last) := AscII.Nul;
  1395.  
  1396.       Title_Str (Title_Str'first .. Title_Str'last - 1) := Title;
  1397.       Title_Str (Title_Str'last) := AscII.Nul; 
  1398.  
  1399.       Style := Make_Style (Buttons, 
  1400.                            Icons, 
  1401.                            Default_Action, 
  1402.                            Modality, 
  1403.                            Help_Button, 
  1404.                            Moveable);
  1405.  
  1406.       Response := WinMessageBox (
  1407.                         Parent    => Parent_Window,
  1408.                         Owner     => Request_Owner, 
  1409.                         Text      => Text_Str (Text_Str'first)'address,
  1410.                         Title     => Title_Str (Title_Str'first)'address,
  1411.                         Window_Id => Pm_Types.U_Short (Help_Id),    
  1412.                         Style     => Style);
  1413.  
  1414.       if Response in MB_Response'range then
  1415.          return Mb_Response (Response);
  1416.       end if;
  1417.  
  1418.       return Mb_Error;
  1419.  
  1420.     end Message_Box;
  1421.  
  1422.   ------------------------------------------------
  1423.  
  1424.      function WinGetMsg (
  1425.                Anchor_Block : Anchor_Block_Handle_Type;
  1426.                Message      : Queue_Message_Pointer_Type;
  1427.                Window       : Handle_Type;
  1428.                First        : Pm_Types.U_Long;
  1429.                Last         : Pm_Types.U_Long) return Pm_Types.U_Long;
  1430.         pragma Import (Convention => C,
  1431.                        Entity     => WinGetMsg,
  1432.                        Link_Name  => "*WinGetMsg");
  1433.  
  1434.    function Get_Message (
  1435.                Anchor_Block : Anchor_Block_Handle_Type;
  1436.                Message      : Queue_Message_Pointer_Type;
  1437.                Window       : Handle_Type;
  1438.                First        : Pm_Types.U_Long;
  1439.                Last         : Pm_Types.U_Long) return Boolean is
  1440.      
  1441.      begin         
  1442.         return WinGetMsg (Anchor_Block, Message, Window, First, Last) = 1;
  1443.      end Get_Message;
  1444.  
  1445.   ------------------------------------------------
  1446.  
  1447.      Function WinDispatchMsg (
  1448.                Anchor_Block : in Anchor_Block_Handle_Type;
  1449.                Message      : in Queue_Message_Pointer_Type) 
  1450.                                                 return Pm_Types.U_Long;
  1451.         pragma Import (Convention => C,
  1452.                        Entity     => WinDispatchMsg,
  1453.                        Link_Name  => "*WinDispatchMsg");
  1454.  
  1455.    procedure Dispatch_Message (
  1456.                Anchor_Block : in Anchor_Block_Handle_Type;
  1457.                Message      : in Queue_Message_Pointer_Type) is
  1458.      
  1459.     Junk : Pm_Types.U_Long;
  1460.    begin
  1461.     Junk :=  WinDispatchMsg (Anchor_Block, Message);
  1462.    end Dispatch_Message;
  1463.  
  1464.   ------------------------------------------------
  1465.  
  1466.    function Send_Message (   
  1467.          To_Window   : Handle_Type;
  1468.          Message     : Message_Type;
  1469.          Parameter_1 : Parameter_Type;
  1470.          Parameter_2 : Parameter_Type) return Void_Type is
  1471.  
  1472.      function WinSendMsg (   
  1473.            To_Window   : Handle_Type;
  1474.            Message     : Message_Type;
  1475.            Parameter_1 : Parameter_Type;
  1476.            Parameter_2 : Parameter_Type) return Void_Type;
  1477.        
  1478.         pragma Import (Convention => C,
  1479.                        Entity     => WinSendMsg,
  1480.                        Link_Name  => "*WinSendMsg");
  1481.  
  1482.      Result : Void_Type;
  1483.    begin
  1484.      Result := WinSendMsg (
  1485.                 To_Window   => To_Window,
  1486.                 Message     => Message,
  1487.                 Parameter_1 => Parameter_1,
  1488.                 Parameter_2 => Parameter_2);
  1489.  
  1490.      return Result;
  1491.    end Send_Message;
  1492.   
  1493.   ------------------------------------------------
  1494.  
  1495.       function WinPostMsg (   
  1496.          To_Window   : Handle_Type;
  1497.          Message     : Message_Type;
  1498.          Parameter_1 : Parameter_Type;
  1499.          Parameter_2 : Parameter_Type) return Boolean;
  1500.        
  1501.         pragma Import (Convention => C,
  1502.                        Entity     => WinPostMsg,
  1503.                        Link_Name  => "*WinPostMsg");
  1504.    function Post_Message (   
  1505.          To_Window   : Handle_Type;
  1506.          Message     : Message_Type;
  1507.          Parameter_1 : Parameter_Type;
  1508.          Parameter_2 : Parameter_Type) return Boolean is
  1509.  
  1510.      begin
  1511.        return WinPostMsg (To_Window, Message, Parameter_1, Parameter_2);
  1512.      end Post_Message;
  1513.  
  1514.   ------------------------------------------------
  1515.  
  1516.      function WinGetPS (Window : Handle_Type) return Ps_Type;
  1517.  
  1518.      pragma Import (Convention => C,
  1519.                     Entity     => WinGetPS,
  1520.                     Link_Name  => "*WinGetPS");
  1521.  
  1522.    function Get_PS (Window : Handle_Type) return Ps_Type is 
  1523.  
  1524.      begin
  1525.        return WinGetPS (Window);
  1526.      end Get_Ps;
  1527.  
  1528.   ------------------------------------------------
  1529.  
  1530.     function WinReleasePs (Ps_Handle : Ps_Type) return Pm_Types.U_Long;
  1531.  
  1532.     pragma Import (Convention => C,
  1533.                    Entity     => WinReleasePS,
  1534.                    Link_Name  => "*WinReleasePS");
  1535.  
  1536.    procedure Release_Ps (Ps_Handle : in out Ps_Type) is
  1537.  
  1538.     begin
  1539.       if WinReleasePs (PS_Handle) = 1 then
  1540.          PS_Handle := Null_Ps;
  1541.       end if;
  1542.     end Release_Ps; 
  1543.      
  1544.   ------------------------------------------------
  1545.  
  1546. end Win;
  1547.    
  1548.  
  1549.  
  1550.