home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / pros2pm.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  35KB  |  1,215 lines
  1. /* -*-C-*-
  2.  
  3. $Id: pros2pm.c,v 1.21 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1994-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. #include "scheme.h"
  23. #include "prims.h"
  24. #define INCL_WIN
  25. #define INCL_GPI
  26. #include "os2.h"
  27.  
  28. static PPOINTL coordinate_vector_point_args
  29.   (unsigned int, unsigned int, unsigned long *);
  30.  
  31. static qid_t pm_qid;
  32.  
  33. static qid_t
  34. qid_argument (unsigned int arg_number)
  35. {
  36.   unsigned int qid = (arg_index_integer (arg_number, (QID_MAX + 1)));
  37.   if (! ((OS2_qid_openp (qid)) && ((OS2_qid_twin (qid)) != QID_NONE)))
  38.     error_bad_range_arg (arg_number);
  39.   return (qid);
  40. }
  41.  
  42. static psid_t
  43. psid_argument (unsigned int arg_number)
  44. {
  45.   unsigned long result = (arg_ulong_integer (arg_number));
  46.   if (!OS2_psid_validp (result))
  47.     error_bad_range_arg (arg_number);
  48.   return (result);
  49. }
  50.  
  51. static psid_t
  52. memory_psid_argument (unsigned int arg_number)
  53. {
  54.   psid_t psid = (psid_argument (arg_number));
  55.   if (!OS2_memory_ps_p (psid))
  56.     error_bad_range_arg (arg_number);
  57.   return (psid);
  58. }
  59.  
  60. static wid_t
  61. wid_argument (unsigned int arg_number)
  62. {
  63.   unsigned long result = (arg_ulong_integer (arg_number));
  64.   if (!OS2_wid_validp (result))
  65.     error_bad_range_arg (arg_number);
  66.   return (result);
  67. }
  68.  
  69. static bid_t
  70. bid_argument (unsigned int arg_number)
  71. {
  72.   unsigned long result = (arg_ulong_integer (arg_number));
  73.   if (!OS2_bid_validp (result))
  74.     error_bad_range_arg (arg_number);
  75.   return (result);
  76. }
  77.  
  78. static short
  79. short_arg (unsigned int arg_number)
  80. {
  81.   long result = (arg_integer (arg_number));
  82.   if (! ((-32768 <= result) && (result < 32768)))
  83.     error_bad_range_arg (arg_number);
  84.   return (result);
  85. }
  86.  
  87. #define SSHORT_ARG short_arg
  88. #define USHORT_ARG(n) arg_index_integer ((n), 0x10000)
  89.  
  90. static unsigned short
  91. dimension_arg (unsigned int arg_number)
  92. {
  93.   unsigned short result = (USHORT_ARG (arg_number));
  94.   if (result == 0)
  95.     error_bad_range_arg (arg_number);
  96.   return (result);
  97. }
  98.  
  99. #define COORDINATE_ARG SSHORT_ARG
  100. #define DIMENSION_ARG dimension_arg
  101. #define HWND_ARG(n) ((HWND) (arg_ulong_integer (n)))
  102.  
  103. void
  104. OS2_initialize_window_primitives (void)
  105. {
  106.   pm_qid = (OS2_create_pm_qid (OS2_scheme_tqueue));
  107. }
  108.  
  109. DEFINE_PRIMITIVE ("OS2WIN-ALARM", Prim_OS2_window_alarm, 1, 1, 0)
  110. {
  111.   PRIMITIVE_HEADER (1);
  112.   PRIMITIVE_RETURN
  113.     (BOOLEAN_TO_OBJECT (WinAlarm (HWND_DESKTOP, (arg_ulong_integer (1)))));
  114. }
  115.  
  116. DEFINE_PRIMITIVE ("OS2WIN-BEEP", Prim_OS2_window_beep, 2, 2, 0)
  117. {
  118.   PRIMITIVE_HEADER (2);
  119.   DosBeep ((arg_ulong_integer (1)), (arg_ulong_integer (2)));
  120.   PRIMITIVE_RETURN (UNSPECIFIC);
  121. }
  122.  
  123. DEFINE_PRIMITIVE ("OS2PM-SYNCHRONIZE", Prim_OS2_pm_synchronize, 0, 0, 0)
  124. {
  125.   PRIMITIVE_HEADER (0);
  126.   OS2_pm_synchronize (pm_qid);
  127.   PRIMITIVE_RETURN (UNSPECIFIC);
  128. }
  129.  
  130. DEFINE_PRIMITIVE ("OS2WIN-OPEN", Prim_OS2_window_open, 2, 2, 0)
  131. {
  132.   PRIMITIVE_HEADER (2);
  133.   PRIMITIVE_RETURN
  134.     (ulong_to_integer (OS2_window_open (pm_qid,
  135.                     (OS2_qid_twin (qid_argument (1))),
  136.                     (FCF_TITLEBAR | FCF_SYSMENU
  137.                      | FCF_SHELLPOSITION | FCF_SIZEBORDER
  138.                      | FCF_MINMAX | FCF_TASKLIST
  139.                      | FCF_NOBYTEALIGN),
  140.                     NULLHANDLE,
  141.                     1,
  142.                     0,
  143.                     (STRING_ARG (2)))));
  144. }
  145.  
  146. DEFINE_PRIMITIVE ("OS2WIN-CLOSE", Prim_OS2_window_close, 1, 1, 0)
  147. {
  148.   PRIMITIVE_HEADER (1);
  149.   OS2_window_close (wid_argument (1));
  150.   PRIMITIVE_RETURN (UNSPECIFIC);
  151. }
  152.  
  153. DEFINE_PRIMITIVE ("OS2WIN-SHOW", Prim_OS2_window_show, 2, 2, 0)
  154. {
  155.   PRIMITIVE_HEADER (2);
  156.   OS2_window_show ((wid_argument (1)), (BOOLEAN_ARG (2)));
  157.   PRIMITIVE_RETURN (UNSPECIFIC);
  158. }
  159.  
  160. DEFINE_PRIMITIVE ("OS2WIN-MOVE-CURSOR", Prim_OS2_window_move_cursor, 3, 3, 0)
  161. {
  162.   PRIMITIVE_HEADER (3);
  163.   OS2_window_move_cursor ((wid_argument (1)),
  164.               (COORDINATE_ARG (2)),
  165.               (COORDINATE_ARG (3)));
  166.   PRIMITIVE_RETURN (UNSPECIFIC);
  167. }
  168.  
  169. DEFINE_PRIMITIVE ("OS2WIN-SHAPE-CURSOR", Prim_OS2_window_shape_cursor, 4, 4, 0)
  170. {
  171.   PRIMITIVE_HEADER (4);
  172.   OS2_window_shape_cursor ((wid_argument (1)),
  173.                (DIMENSION_ARG (2)),
  174.                (DIMENSION_ARG (3)),
  175.                (USHORT_ARG (4)));
  176.   PRIMITIVE_RETURN (UNSPECIFIC);
  177. }
  178.  
  179. DEFINE_PRIMITIVE ("OS2WIN-SHOW-CURSOR", Prim_OS2_window_show_cursor, 2, 2, 0)
  180. {
  181.   PRIMITIVE_HEADER (2);
  182.   OS2_window_show_cursor ((wid_argument (1)), (BOOLEAN_ARG (2)));
  183.   PRIMITIVE_RETURN (UNSPECIFIC);
  184. }
  185.  
  186. DEFINE_PRIMITIVE ("OS2WIN-SCROLL", Prim_OS2_window_scroll, 7, 7, 0)
  187. {
  188.   PRIMITIVE_HEADER (7);
  189.   OS2_window_scroll ((wid_argument (1)),
  190.              (COORDINATE_ARG (2)),
  191.              (COORDINATE_ARG (3)),
  192.              (COORDINATE_ARG (4)),
  193.              (COORDINATE_ARG (5)),
  194.              (SSHORT_ARG (6)),
  195.              (SSHORT_ARG (7)));
  196.   PRIMITIVE_RETURN (UNSPECIFIC);
  197. }
  198.  
  199. DEFINE_PRIMITIVE ("OS2WIN-INVALIDATE", Prim_OS2_window_invalidate, 5, 5, 0)
  200. {
  201.   PRIMITIVE_HEADER (5);
  202.   OS2_window_invalidate ((wid_argument (1)),
  203.              (COORDINATE_ARG (2)),
  204.              (COORDINATE_ARG (3)),
  205.              (COORDINATE_ARG (4)),
  206.              (COORDINATE_ARG (5)));
  207.   PRIMITIVE_RETURN (UNSPECIFIC);
  208. }
  209.  
  210. DEFINE_PRIMITIVE ("OS2WIN-SET-GRID", Prim_OS2_window_set_grid, 3, 3, 0)
  211. {
  212.   PRIMITIVE_HEADER (3);
  213.   OS2_window_set_grid ((wid_argument (1)),
  214.                (DIMENSION_ARG (2)),
  215.                (DIMENSION_ARG (3)));
  216.   PRIMITIVE_RETURN (UNSPECIFIC);
  217. }
  218.  
  219. DEFINE_PRIMITIVE ("OS2WIN-ACTIVATE", Prim_OS2_window_activate, 1, 1, 0)
  220. {
  221.   PRIMITIVE_HEADER (1);
  222.   OS2_window_activate (wid_argument (1));
  223.   PRIMITIVE_RETURN (UNSPECIFIC);
  224. }
  225.  
  226. DEFINE_PRIMITIVE ("OS2WIN-GET-POS", Prim_OS2_window_get_pos, 1, 1, 0)
  227. {
  228.   PRIMITIVE_HEADER (1);
  229.   {
  230.     SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
  231.     short x;
  232.     short y;
  233.     OS2_window_pos ((wid_argument (1)), (& x), (& y));
  234.     SET_PAIR_CAR (p, (LONG_TO_FIXNUM (x)));
  235.     SET_PAIR_CDR (p, (LONG_TO_FIXNUM (y)));
  236.     PRIMITIVE_RETURN (p);
  237.   }
  238. }
  239.  
  240. DEFINE_PRIMITIVE ("OS2WIN-SET-POS", Prim_OS2_window_set_pos, 3, 3, 0)
  241. {
  242.   PRIMITIVE_HEADER (3);
  243.   OS2_window_set_pos ((wid_argument (1)), (SSHORT_ARG (2)), (SSHORT_ARG (3)));
  244.   PRIMITIVE_RETURN (UNSPECIFIC);
  245. }
  246.  
  247. DEFINE_PRIMITIVE ("OS2WIN-GET-SIZE", Prim_OS2_window_get_size, 1, 1, 0)
  248. {
  249.   PRIMITIVE_HEADER (1);
  250.   {
  251.     SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
  252.     unsigned short width;
  253.     unsigned short height;
  254.     OS2_window_size ((wid_argument (1)), (& width), (& height));
  255.     SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
  256.     SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
  257.     PRIMITIVE_RETURN (p);
  258.   }
  259. }
  260.  
  261. DEFINE_PRIMITIVE ("OS2WIN-GET-FRAME-SIZE", Prim_OS2_window_get_frame_size, 1, 1, 0)
  262. {
  263.   PRIMITIVE_HEADER (1);
  264.   {
  265.     SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
  266.     unsigned short width;
  267.     unsigned short height;
  268.     OS2_window_frame_size ((wid_argument (1)), (& width), (& height));
  269.     SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
  270.     SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
  271.     PRIMITIVE_RETURN (p);
  272.   }
  273. }
  274.  
  275. DEFINE_PRIMITIVE ("OS2WIN-SET-SIZE", Prim_OS2_window_set_size, 3, 3, 0)
  276. {
  277.   PRIMITIVE_HEADER (3);
  278.   OS2_window_set_size ((wid_argument (1)), (USHORT_ARG (2)), (USHORT_ARG (3)));
  279.   PRIMITIVE_RETURN (UNSPECIFIC);
  280. }
  281.  
  282. DEFINE_PRIMITIVE ("OS2WIN-FOCUS?", Prim_OS2_window_focusp, 1, 1, 0)
  283. {
  284.   PRIMITIVE_HEADER (1);
  285.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS2_window_focusp (wid_argument (1))));
  286. }
  287.  
  288. DEFINE_PRIMITIVE ("OS2WIN-SET-STATE", Prim_OS2_window_set_state, 2, 2, 0)
  289. {
  290.   PRIMITIVE_HEADER (2);
  291.   OS2_window_set_state
  292.     ((wid_argument (1)),
  293.      ((window_state_t) (arg_index_integer (2, ((long) state_supremum)))));
  294.   PRIMITIVE_RETURN (UNSPECIFIC);
  295. }
  296.  
  297. DEFINE_PRIMITIVE ("OS2WIN-SET-TITLE", Prim_OS2_window_set_title, 2, 2, 0)
  298. {
  299.   PRIMITIVE_HEADER (2);
  300.   OS2_window_set_title ((wid_argument (1)), (STRING_ARG (2)));
  301.   PRIMITIVE_RETURN (UNSPECIFIC);
  302. }
  303.  
  304. DEFINE_PRIMITIVE ("OS2WIN-TRACK-MOUSE", Prim_OS2_window_track_mouse, 2, 2, 0)
  305. {
  306.   PRIMITIVE_HEADER (2);
  307.   OS2_window_mousetrack ((wid_argument (1)), (BOOLEAN_ARG (2)));
  308.   PRIMITIVE_RETURN (UNSPECIFIC);
  309. }
  310.  
  311. DEFINE_PRIMITIVE ("OS2WIN-FRAME-HANDLE", Prim_OS2_window_frame_handle, 1, 1, 0)
  312. {
  313.   PRIMITIVE_HEADER (1);
  314.   PRIMITIVE_RETURN
  315.     (ulong_to_integer (OS2_window_frame_handle (wid_argument (1))));
  316. }
  317.  
  318. DEFINE_PRIMITIVE ("OS2WIN-CLIENT-HANDLE", Prim_OS2_window_client_handle, 1, 1, 0)
  319. {
  320.   PRIMITIVE_HEADER (1);
  321.   PRIMITIVE_RETURN
  322.     (ulong_to_integer (OS2_window_client_handle (wid_argument (1))));
  323. }
  324.  
  325. DEFINE_PRIMITIVE ("OS2WIN-UPDATE-FRAME", Prim_OS2_window_update_frame, 2, 2, 0)
  326. {
  327.   PRIMITIVE_HEADER (2);
  328.   OS2_window_update_frame ((wid_argument (1)), (USHORT_ARG (2)));
  329.   PRIMITIVE_RETURN (UNSPECIFIC);
  330. }
  331.  
  332. DEFINE_PRIMITIVE ("OS2-WINDOW-HANDLE-FROM-ID", Prim_OS2_window_handle_from_id, 2, 2, 0)
  333. {
  334.   PRIMITIVE_HEADER (2);
  335.   PRIMITIVE_RETURN
  336.     (ulong_to_integer (OS2_window_handle_from_id (pm_qid,
  337.                           (arg_ulong_integer (1)),
  338.                           (arg_ulong_integer (2)))));
  339. }
  340.  
  341. DEFINE_PRIMITIVE ("OS2WIN-QUERY-SYS-VALUE", Prim_OS2_window_query_sys_value, 2, 2, 0)
  342. {
  343.   PRIMITIVE_HEADER (2);
  344.   PRIMITIVE_RETURN
  345.     (ulong_to_integer (OS2_window_query_sys_value (pm_qid,
  346.                            (HWND_ARG (1)),
  347.                            (arg_integer (2)))));
  348. }
  349.  
  350. DEFINE_PRIMITIVE ("OS2-MAP-WINDOW-POINT", Prim_OS2_map_window_point, 3, 3, 0)
  351. {
  352.   PRIMITIVE_HEADER (3);
  353.   {
  354.     SCHEME_OBJECT scheme_point;
  355.     POINTL point;
  356.     BOOL rc;
  357.  
  358.     CHECK_ARG (3, PAIR_P);
  359.     scheme_point = (ARG_REF (3));
  360.     if ((!INTEGER_P (PAIR_CAR (scheme_point)))
  361.     || (!INTEGER_P (PAIR_CDR (scheme_point))))
  362.       error_wrong_type_arg (3);
  363.     if ((!integer_to_long_p (PAIR_CAR (scheme_point)))
  364.     || (!integer_to_long_p (PAIR_CDR (scheme_point))))
  365.       error_bad_range_arg (3);
  366.     (point . x) = (integer_to_long (PAIR_CAR (scheme_point)));
  367.     (point . y) = (integer_to_long (PAIR_CDR (scheme_point)));
  368.     rc = (WinMapWindowPoints ((HWND_ARG (1)), (HWND_ARG (2)), (&point), 1));
  369.     if (rc)
  370.       {
  371.     SET_PAIR_CAR (scheme_point, (long_to_integer (point . x)));
  372.     SET_PAIR_CDR (scheme_point, (long_to_integer (point . y)));
  373.       }
  374.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (rc));
  375.   }
  376. }
  377.  
  378. DEFINE_PRIMITIVE ("OS2WIN-SET-CAPTURE", PRIM_OS2_WINDOW_SET_CAPTURE, 2, 2, 0)
  379. {
  380.   PRIMITIVE_HEADER (2);
  381.   PRIMITIVE_RETURN
  382.     (BOOLEAN_TO_OBJECT
  383.      (OS2_window_set_capture ((wid_argument (1)), (BOOLEAN_ARG (2)))));
  384. }
  385.  
  386. DEFINE_PRIMITIVE ("OS2WIN-PS", Prim_OS2_window_ps, 1, 1, 0)
  387. {
  388.   PRIMITIVE_HEADER (1);
  389.   PRIMITIVE_RETURN
  390.     (ulong_to_integer (OS2_window_client_ps (wid_argument (1))));
  391. }
  392.  
  393. DEFINE_PRIMITIVE ("OS2PS-CREATE-MEMORY-PS", Prim_OS2_create_memory_ps, 0, 0, 0)
  394. {
  395.   PRIMITIVE_HEADER (0);
  396.   PRIMITIVE_RETURN (ulong_to_integer (OS2_create_memory_ps (pm_qid)));
  397. }
  398.  
  399. DEFINE_PRIMITIVE ("OS2PS-DESTROY-MEMORY-PS", Prim_OS2_destroy_memory_ps, 1, 1, 0)
  400. {
  401.   PRIMITIVE_HEADER (1);
  402.   OS2_destroy_memory_ps (memory_psid_argument (1));
  403.   PRIMITIVE_RETURN (UNSPECIFIC);
  404. }
  405.  
  406. DEFINE_PRIMITIVE ("OS2PS-CREATE-BITMAP", Prim_OS2_create_bitmap, 3, 3, 0)
  407. {
  408.   PRIMITIVE_HEADER (3);
  409.   PRIMITIVE_RETURN
  410.     (ulong_to_integer (OS2_create_bitmap ((psid_argument (1)),
  411.                       (USHORT_ARG (2)),
  412.                       (USHORT_ARG (3)))));
  413. }
  414.  
  415. DEFINE_PRIMITIVE ("OS2PS-DESTROY-BITMAP", Prim_OS2_destroy_bitmap, 1, 1, 0)
  416. {
  417.   PRIMITIVE_HEADER (1);
  418.   OS2_destroy_bitmap (bid_argument (1));
  419.   PRIMITIVE_RETURN (UNSPECIFIC);
  420. }
  421.  
  422. DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP", Prim_OS2_ps_get_bitmap, 1, 1, 0)
  423. {
  424.   PRIMITIVE_HEADER (1);
  425.   {
  426.     bid_t bid = (OS2_ps_get_bitmap ((memory_psid_argument (1))));
  427.     PRIMITIVE_RETURN ((bid == BID_NONE) ? SHARP_F : (ulong_to_integer (bid)));
  428.   }
  429. }
  430.  
  431. DEFINE_PRIMITIVE ("OS2PS-SET-BITMAP", Prim_OS2_ps_set_bitmap, 2, 2, 0)
  432. {
  433.   PRIMITIVE_HEADER (2);
  434.   {
  435.     bid_t bid
  436.       = (OS2_ps_set_bitmap
  437.      ((memory_psid_argument (1)),
  438.       (((ARG_REF (2)) == SHARP_F) ? BID_NONE : (bid_argument (2)))));
  439.     PRIMITIVE_RETURN ((bid == BID_NONE) ? SHARP_F : (ulong_to_integer (bid)));
  440.   }
  441. }
  442.  
  443. DEFINE_PRIMITIVE ("OS2PS-BITBLT", Prim_OS2_ps_bitblt, 6, 6, 0)
  444. {
  445.   PRIMITIVE_HEADER (6);
  446.   {
  447.     void * position = dstack_position;
  448.     psid_t target = (psid_argument (1));
  449.     psid_t source = (psid_argument (2));
  450.     unsigned long npoints;
  451.     PPOINTL points = (coordinate_vector_point_args (3, 4, (& npoints)));
  452.     LONG rop = (arg_index_integer (5, 0x100));
  453.     ULONG options = (arg_ulong_integer (6));
  454.     if (! ((npoints == 3) || (npoints == 4)))
  455.       error_bad_range_arg (3);
  456.     OS2_ps_bitblt (target, source, npoints, points, rop, options);
  457.     dstack_set_position (position);
  458.   }
  459.   PRIMITIVE_RETURN (UNSPECIFIC);
  460. }
  461.  
  462. DEFINE_PRIMITIVE ("OS2PS-WRITE", Prim_OS2_ps_write, 6, 6, 0)
  463. {
  464.   PRIMITIVE_HEADER (6);
  465.   CHECK_ARG (4, STRING_P);
  466.   {
  467.     SCHEME_OBJECT string = (ARG_REF (4));
  468.     unsigned long start = (arg_ulong_integer (5));
  469.     unsigned long end = (arg_ulong_integer (6));
  470.     if (end > (STRING_LENGTH (string)))
  471.       error_bad_range_arg (6);
  472.     if (start > end)
  473.       error_bad_range_arg (5);
  474.     OS2_ps_draw_text ((psid_argument (1)),
  475.               (COORDINATE_ARG (2)),
  476.               (COORDINATE_ARG (3)),
  477.               (STRING_LOC (string, start)),
  478.               (end - start));
  479.   }
  480.   PRIMITIVE_RETURN (UNSPECIFIC);
  481. }
  482.  
  483. DEFINE_PRIMITIVE ("OS2PS-TEXT-WIDTH", Prim_OS2_ps_text_width, 4, 4, 0)
  484. {
  485.   PRIMITIVE_HEADER (4);
  486.   CHECK_ARG (2, STRING_P);
  487.   {
  488.     SCHEME_OBJECT string = (ARG_REF (2));
  489.     unsigned long start = (arg_ulong_integer (3));
  490.     unsigned long end = (arg_ulong_integer (4));
  491.     if (end > (STRING_LENGTH (string)))
  492.       error_bad_range_arg (4);
  493.     if (start > end)
  494.       error_bad_range_arg (3);
  495.     PRIMITIVE_RETURN
  496.       (ulong_to_integer
  497.        (OS2_ps_text_width ((psid_argument (1)),
  498.                (STRING_LOC (string, start)),
  499.                (end - start))));
  500.   }
  501. }
  502.  
  503. static SCHEME_OBJECT
  504. convert_font_metrics (font_metrics_t * m)
  505. {
  506.   if (m == 0)
  507.     return (SHARP_F);
  508.   else
  509.     {
  510.       SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
  511.       VECTOR_SET (v, 0, (ulong_to_integer (FONT_METRICS_WIDTH (m))));
  512.       VECTOR_SET (v, 1, (ulong_to_integer (FONT_METRICS_HEIGHT (m))));
  513.       VECTOR_SET (v, 2, (ulong_to_integer (FONT_METRICS_DESCENDER (m))));
  514.       OS_free (m);
  515.       return (v);
  516.     }
  517. }
  518.  
  519. DEFINE_PRIMITIVE ("OS2PS-GET-FONT-METRICS", Prim_OS2_ps_get_font_metrics, 1, 1, 0)
  520. {
  521.   PRIMITIVE_HEADER (1);
  522.   PRIMITIVE_RETURN
  523.     (convert_font_metrics (OS2_ps_get_font_metrics (psid_argument (1))));
  524. }
  525.  
  526. DEFINE_PRIMITIVE ("OS2PS-SET-FONT", Prim_OS2_ps_set_font, 3, 3, 0)
  527. {
  528.   PRIMITIVE_HEADER (3);
  529.   PRIMITIVE_RETURN
  530.     (convert_font_metrics (OS2_ps_set_font ((psid_argument (1)),
  531.                         (USHORT_ARG (2)),
  532.                         (STRING_ARG (3)))));
  533. }
  534.  
  535. DEFINE_PRIMITIVE ("OS2PS-CLEAR", Prim_OS2_ps_clear, 5, 5, 0)
  536. {
  537.   PRIMITIVE_HEADER (5);
  538.   OS2_ps_clear ((psid_argument (1)),
  539.         (COORDINATE_ARG (2)),
  540.         (COORDINATE_ARG (3)),
  541.         (COORDINATE_ARG (4)),
  542.         (COORDINATE_ARG (5)));
  543.   PRIMITIVE_RETURN (UNSPECIFIC);
  544. }
  545.  
  546. DEFINE_PRIMITIVE ("OS2PS-SET-COLORS", Prim_OS2_ps_set_colors, 3, 3, 0)
  547. {
  548.   PRIMITIVE_HEADER (3);
  549.   OS2_ps_set_colors ((psid_argument (1)),
  550.              (arg_index_integer (2, 0x1000000)),
  551.              (arg_index_integer (3, 0x1000000)));
  552.   PRIMITIVE_RETURN (UNSPECIFIC);
  553. }
  554.  
  555. DEFINE_PRIMITIVE ("OS2PS-MOVE-GRAPHICS-CURSOR", Prim_OS2_ps_move_gcursor, 3, 3, 0)
  556. {
  557.   PRIMITIVE_HEADER (3);
  558.   OS2_ps_move_gcursor ((psid_argument (1)),
  559.                (COORDINATE_ARG (2)),
  560.                (COORDINATE_ARG (3)));
  561.   PRIMITIVE_RETURN (UNSPECIFIC);
  562. }
  563.  
  564. DEFINE_PRIMITIVE ("OS2PS-LINE", Prim_OS2_ps_line, 3, 3, 0)
  565. {
  566.   PRIMITIVE_HEADER (3);
  567.   OS2_ps_draw_line ((psid_argument (1)),
  568.             (COORDINATE_ARG (2)),
  569.             (COORDINATE_ARG (3)));
  570.   PRIMITIVE_RETURN (UNSPECIFIC);
  571. }
  572.  
  573. DEFINE_PRIMITIVE ("OS2PS-DRAW-POINT", Prim_OS2_ps_draw_point, 3, 3, 0)
  574. {
  575.   PRIMITIVE_HEADER (3);
  576.   OS2_ps_draw_point ((psid_argument (1)),
  577.              (COORDINATE_ARG (2)),
  578.              (COORDINATE_ARG (3)));
  579.   PRIMITIVE_RETURN (UNSPECIFIC);
  580. }
  581.  
  582. DEFINE_PRIMITIVE ("OS2PS-POLY-LINE", Prim_OS2_ps_poly_line, 3, 3, 0)
  583. {
  584.   PRIMITIVE_HEADER (3);
  585.   {
  586.     void * position = dstack_position;
  587.     unsigned long npoints;
  588.     PPOINTL points = (coordinate_vector_point_args (2, 3, (& npoints)));
  589.     OS2_ps_poly_line ((psid_argument (1)),
  590.               npoints,
  591.               points);
  592.     dstack_set_position (position);
  593.   }
  594.   PRIMITIVE_RETURN (UNSPECIFIC);
  595. }
  596.  
  597. DEFINE_PRIMITIVE ("OS2PS-POLY-LINE-DISJOINT", Prim_OS2_ps_poly_line_disjoint, 3, 3, 0)
  598. {
  599.   PRIMITIVE_HEADER (3);
  600.   {
  601.     void * position = dstack_position;
  602.     unsigned long npoints;
  603.     PPOINTL points = (coordinate_vector_point_args (2, 3, (& npoints)));
  604.     OS2_ps_poly_line_disjoint ((psid_argument (1)),
  605.                    npoints,
  606.                    points);
  607.     dstack_set_position (position);
  608.   }
  609.   PRIMITIVE_RETURN (UNSPECIFIC);
  610. }
  611.  
  612. static PPOINTL
  613. coordinate_vector_point_args (unsigned int x_no, unsigned int y_no,
  614.                   unsigned long * npoints)
  615. {
  616.   SCHEME_OBJECT x_vector = (ARG_REF (x_no));
  617.   SCHEME_OBJECT y_vector = (ARG_REF (y_no));
  618.   if (!VECTOR_P (x_vector))
  619.     error_wrong_type_arg (x_no);
  620.   if (!VECTOR_P (y_vector))
  621.     error_wrong_type_arg (y_no);
  622.   {
  623.     unsigned long length = (VECTOR_LENGTH (x_vector));
  624.     if (length != (VECTOR_LENGTH (y_vector)))
  625.       error_bad_range_arg (x_no);
  626.     {
  627.       SCHEME_OBJECT * scan_x = (VECTOR_LOC (x_vector, 0));
  628.       SCHEME_OBJECT * end_x = (VECTOR_LOC (x_vector, length));
  629.       SCHEME_OBJECT * scan_y = (VECTOR_LOC (y_vector, 0));
  630.       PPOINTL points = (dstack_alloc (length * (sizeof (POINTL))));
  631.       PPOINTL scan_points = points;
  632.       while (scan_x < end_x)
  633.     {
  634.       SCHEME_OBJECT x = (*scan_x++);
  635.       SCHEME_OBJECT y = (*scan_y++);
  636.       if (!FIXNUM_P (x))
  637.         error_bad_range_arg (x_no);
  638.       if (!FIXNUM_P (y))
  639.         error_bad_range_arg (y_no);
  640.       (scan_points -> x) = (FIXNUM_TO_LONG (x));
  641.       (scan_points -> y) = (FIXNUM_TO_LONG (y));
  642.       scan_points += 1;
  643.     }
  644.       (* npoints) = length;
  645.       return (points);
  646.     }
  647.   }
  648. }
  649.  
  650. DEFINE_PRIMITIVE ("OS2PS-SET-LINE-TYPE", Prim_OS2_ps_set_line_type, 2, 2, 0)
  651. {
  652.   PRIMITIVE_HEADER (2);
  653.   OS2_ps_set_line_type ((psid_argument (1)), (arg_index_integer (2, 10)));
  654.   PRIMITIVE_RETURN (UNSPECIFIC);
  655. }
  656.  
  657. DEFINE_PRIMITIVE ("OS2PS-SET-MIX", Prim_OS2_ps_set_mix, 2, 2, 0)
  658. {
  659.   PRIMITIVE_HEADER (2);
  660.   OS2_ps_set_mix ((psid_argument (1)), (arg_index_integer (2, 18)));
  661.   PRIMITIVE_RETURN (UNSPECIFIC);
  662. }
  663.  
  664. DEFINE_PRIMITIVE ("OS2PS-QUERY-CAPABILITIES", Prim_OS2_ps_query_caps, 3, 3, 0)
  665. {
  666.   PRIMITIVE_HEADER (3);
  667.   {
  668.     LONG count = (arg_nonnegative_integer (3));
  669.     PLONG values = (OS_malloc (count * (sizeof (LONG))));
  670.     OS2_ps_query_caps ((psid_argument (1)),
  671.                (arg_nonnegative_integer (2)),
  672.                count,
  673.                values);
  674.     {
  675.       SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, count, 1));
  676.       LONG index = 0;
  677.       while (index < count)
  678.     {
  679.       VECTOR_SET (v, index, (long_to_integer (values [index])));
  680.       index += 1;
  681.     }
  682.       OS_free (values);
  683.       PRIMITIVE_RETURN (v);
  684.     }
  685.   }
  686. }
  687.  
  688. DEFINE_PRIMITIVE ("OS2PS-QUERY-CAPABILITY", Prim_OS2_ps_query_cap, 2, 2, 0)
  689. {
  690.   LONG values [1];
  691.   PRIMITIVE_HEADER (2);
  692.   OS2_ps_query_caps ((psid_argument (1)),
  693.              (arg_nonnegative_integer (2)),
  694.              1,
  695.              values);
  696.   PRIMITIVE_RETURN (long_to_integer (values [0]));
  697. }
  698.  
  699. DEFINE_PRIMITIVE ("OS2PS-RESET-CLIP-RECTANGLE", Prim_OS2_ps_reset_clip_rectangle, 1, 1, 0)
  700. {
  701.   PRIMITIVE_HEADER (1);
  702.   OS2_ps_reset_clip_rectangle (psid_argument (1));
  703.   PRIMITIVE_RETURN (UNSPECIFIC);
  704. }
  705.  
  706. DEFINE_PRIMITIVE ("OS2PS-SET-CLIP-RECTANGLE", Prim_OS2_ps_set_clip_rectangle, 5, 5, 0)
  707. {
  708.   PRIMITIVE_HEADER (5);
  709.   OS2_ps_set_clip_rectangle ((psid_argument (1)),
  710.                  (COORDINATE_ARG (2)),
  711.                  (COORDINATE_ARG (3)),
  712.                  (COORDINATE_ARG (4)),
  713.                  (COORDINATE_ARG (5)));
  714.   PRIMITIVE_RETURN (UNSPECIFIC);
  715. }
  716.  
  717. DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP-PARAMETERS", Prim_OS2_ps_get_bitmap_parameters, 1, 1, 0)
  718. {
  719.   PRIMITIVE_HEADER (1);
  720.   {
  721.     SCHEME_OBJECT s = (allocate_string (sizeof (BITMAPINFOHEADER)));
  722.     PBITMAPINFOHEADER params = ((PBITMAPINFOHEADER) (STRING_LOC (s, 0)));
  723.     (params -> cbFix) = (sizeof (BITMAPINFOHEADER));
  724.     OS2_get_bitmap_parameters ((bid_argument (1)), params);
  725.     PRIMITIVE_RETURN (s);
  726.   }
  727. }
  728.  
  729. DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP-BITS", Prim_OS2_ps_get_bitmap_bits, 5, 5, 0)
  730. {
  731.   PRIMITIVE_HEADER (5);
  732.   PRIMITIVE_RETURN
  733.     (ulong_to_integer
  734.      (OS2_ps_get_bitmap_bits ((memory_psid_argument (1)),
  735.                   (arg_ulong_integer (2)),
  736.                   (arg_ulong_integer (3)),
  737.                   (STRING_ARG (4)),
  738.                   ((void *) (STRING_ARG (5))))));
  739. }
  740.  
  741. DEFINE_PRIMITIVE ("OS2PS-SET-BITMAP-BITS", Prim_OS2_ps_set_bitmap_bits, 5, 5, 0)
  742. {
  743.   PRIMITIVE_HEADER (5);
  744.   PRIMITIVE_RETURN
  745.     (ulong_to_integer
  746.      (OS2_ps_set_bitmap_bits ((memory_psid_argument (1)),
  747.                   (arg_ulong_integer (2)),
  748.                   (arg_ulong_integer (3)),
  749.                   (STRING_ARG (4)),
  750.                   ((void *) (STRING_ARG (5))))));
  751. }
  752.  
  753. DEFINE_PRIMITIVE ("OS2-CLIPBOARD-WRITE-TEXT", Prim_OS2_clipboard_write_text, 1, 1, 0)
  754. {
  755.   PRIMITIVE_HEADER (1);
  756.   OS2_clipboard_write_text (pm_qid, (STRING_ARG (1)));
  757.   PRIMITIVE_RETURN (UNSPECIFIC);
  758. }
  759.  
  760. DEFINE_PRIMITIVE ("OS2-CLIPBOARD-READ-TEXT", Prim_OS2_clipboard_read_text, 0, 0, 0)
  761. {
  762.   PRIMITIVE_HEADER (0);
  763.   {
  764.     const char * text = (OS2_clipboard_read_text (pm_qid));
  765.     SCHEME_OBJECT result;
  766.     if (text == 0)
  767.       result = SHARP_F;
  768.     else
  769.       {
  770.     result = (char_pointer_to_string ((unsigned char *) text));
  771.     OS_free ((void *) text);
  772.       }
  773.     PRIMITIVE_RETURN (result);
  774.   }
  775. }
  776.  
  777. DEFINE_PRIMITIVE ("OS2MENU-CREATE", Prim_OS2_menu_create, 3, 3, 0)
  778. {
  779.   PRIMITIVE_HEADER (3);
  780.   PRIMITIVE_RETURN
  781.     (ulong_to_integer (OS2_menu_create (pm_qid,
  782.                     (HWND_ARG (1)),
  783.                     (USHORT_ARG (2)),
  784.                     (USHORT_ARG (3)))));
  785. }
  786.  
  787. DEFINE_PRIMITIVE ("OS2MENU-DESTROY", Prim_OS2_menu_destroy, 1, 1, 0)
  788. {
  789.   PRIMITIVE_HEADER (1);
  790.   OS2_menu_destroy (pm_qid, (HWND_ARG (1)));
  791.   PRIMITIVE_RETURN (UNSPECIFIC);
  792. }
  793.  
  794. DEFINE_PRIMITIVE ("OS2MENU-INSERT-ITEM", Prim_OS2_menu_insert_item, 7, 7, 0)
  795. {
  796.   PRIMITIVE_HEADER (7);
  797.   PRIMITIVE_RETURN
  798.     (ulong_to_integer (OS2_menu_insert_item (pm_qid,
  799.                          (HWND_ARG (1)),
  800.                          (USHORT_ARG (2)),
  801.                          (USHORT_ARG (3)),
  802.                          (USHORT_ARG (4)),
  803.                          (USHORT_ARG (5)),
  804.                          (HWND_ARG (6)),
  805.                          (STRING_ARG (7)))));
  806. }
  807.  
  808. DEFINE_PRIMITIVE ("OS2MENU-REMOVE-ITEM", Prim_OS2_menu_remove_item, 4, 4, 0)
  809. {
  810.   PRIMITIVE_HEADER (4);
  811.   PRIMITIVE_RETURN
  812.     (ulong_to_integer (OS2_menu_remove_item (pm_qid,
  813.                          (HWND_ARG (1)),
  814.                          (USHORT_ARG (2)),
  815.                          (BOOLEAN_ARG (3)),
  816.                          (BOOLEAN_ARG (4)))));
  817. }
  818.  
  819. DEFINE_PRIMITIVE ("OS2MENU-GET-ITEM", Prim_OS2_menu_get_item, 3, 3, 0)
  820. {
  821.   PMENUITEM item;
  822.   SCHEME_OBJECT result;
  823.   PRIMITIVE_HEADER (3);
  824.  
  825.   item = (OS2_menu_get_item (pm_qid,
  826.                  (HWND_ARG (1)),
  827.                  (USHORT_ARG (2)),
  828.                  (BOOLEAN_ARG (3))));
  829.   if (item == 0)
  830.     PRIMITIVE_RETURN (SHARP_F);
  831.   result = (allocate_marked_vector (TC_VECTOR, 6, 1));
  832.   VECTOR_SET (result, 0, (long_to_integer (item -> iPosition)));
  833.   VECTOR_SET (result, 1, (ulong_to_integer (item -> afStyle)));
  834.   VECTOR_SET (result, 2, (ulong_to_integer (item -> afAttribute)));
  835.   VECTOR_SET (result, 3, (ulong_to_integer (item -> id)));
  836.   VECTOR_SET (result, 4, (ulong_to_integer (item -> hwndSubMenu)));
  837.   VECTOR_SET (result, 5, (ulong_to_integer (item -> hItem)));
  838.   OS_free (item);
  839.   PRIMITIVE_RETURN (result);
  840. }
  841.  
  842. DEFINE_PRIMITIVE ("OS2MENU-N-ITEMS", Prim_OS2_menu_n_items, 1, 1, 0)
  843. {
  844.   PRIMITIVE_HEADER (1);
  845.   PRIMITIVE_RETURN
  846.     (ulong_to_integer (OS2_menu_n_items (pm_qid, (HWND_ARG (1)))));
  847. }
  848.  
  849. DEFINE_PRIMITIVE ("OS2MENU-NTH-ITEM-ID", Prim_OS2_menu_nth_item_id, 2, 2, 0)
  850. {
  851.   PRIMITIVE_HEADER (2);
  852.   PRIMITIVE_RETURN
  853.     (ulong_to_integer (OS2_menu_nth_item_id (pm_qid,
  854.                          (HWND_ARG (1)),
  855.                          (USHORT_ARG (2)))));
  856. }
  857.  
  858. DEFINE_PRIMITIVE ("OS2MENU-GET-ITEM-ATTRIBUTES", Prim_OS2_menu_get_item_attributes, 4, 4, 0)
  859. {
  860.   PRIMITIVE_HEADER (4);
  861.   PRIMITIVE_RETURN
  862.     (ulong_to_integer (OS2_menu_get_item_attributes (pm_qid,
  863.                              (HWND_ARG (1)),
  864.                              (USHORT_ARG (2)),
  865.                              (BOOLEAN_ARG (3)),
  866.                              (USHORT_ARG (4)))));
  867. }
  868.  
  869. DEFINE_PRIMITIVE ("OS2MENU-SET-ITEM-ATTRIBUTES", Prim_OS2_menu_set_item_attributes, 5, 5, 0)
  870. {
  871.   PRIMITIVE_HEADER (5);
  872.   PRIMITIVE_RETURN
  873.     (BOOLEAN_TO_OBJECT (OS2_menu_set_item_attributes (pm_qid,
  874.                               (HWND_ARG (1)),
  875.                               (USHORT_ARG (2)),
  876.                               (BOOLEAN_ARG (3)),
  877.                               (USHORT_ARG (4)),
  878.                               (USHORT_ARG (5)))));
  879. }
  880.  
  881. DEFINE_PRIMITIVE ("OS2WIN-LOAD-MENU", Prim_OS2_window_load_menu, 3, 3, 0)
  882. {
  883.   PRIMITIVE_HEADER (3);
  884.   PRIMITIVE_RETURN
  885.     (ulong_to_integer (OS2_window_load_menu ((wid_argument (1)),
  886.                          (arg_ulong_integer (2)),
  887.                          (arg_ulong_integer (3)))));
  888. }
  889.  
  890. DEFINE_PRIMITIVE ("OS2WIN-POPUP-MENU", Prim_OS2_window_popup_menu, 7, 7, 0)
  891. {
  892.   PRIMITIVE_HEADER (7);
  893.   PRIMITIVE_RETURN
  894.     (BOOLEAN_TO_OBJECT
  895.      (OS2_window_popup_menu (pm_qid,
  896.                  (HWND_ARG (1)),
  897.                  (HWND_ARG (2)),
  898.                  (HWND_ARG (3)),
  899.                  (arg_integer (4)),
  900.                  (arg_integer (5)),
  901.                  (arg_integer (6)),
  902.                  (arg_ulong_integer (7)))));
  903. }
  904.  
  905. DEFINE_PRIMITIVE ("OS2WIN-FONT-DIALOG", Prim_OS2_window_font_dialog, 2, 2, 0)
  906. {
  907.   const char * spec;
  908.   SCHEME_OBJECT result;
  909.   PRIMITIVE_HEADER (2);
  910.  
  911.   spec = (OS2_window_font_dialog ((wid_argument (1)),
  912.                   (((ARG_REF (2)) == SHARP_F)
  913.                    ? 0
  914.                    : (STRING_ARG (2)))));
  915.   if (spec == 0)
  916.     PRIMITIVE_RETURN (SHARP_F);
  917.   result = (char_pointer_to_string ((char *) spec));
  918.   OS_free ((void *) spec);
  919.   PRIMITIVE_RETURN (result);
  920. }
  921.  
  922. DEFINE_PRIMITIVE ("OS2-QUERY-SYSTEM-POINTER", Prim_OS2_query_system_pointer, 3, 3, 0)
  923. {
  924.   PRIMITIVE_HEADER (3);
  925.   PRIMITIVE_RETURN
  926.     (ulong_to_integer (OS2_query_system_pointer (pm_qid,
  927.                          (HWND_ARG (1)),
  928.                          (arg_integer (2)),
  929.                          (BOOLEAN_ARG (3)))));
  930. }
  931.  
  932. DEFINE_PRIMITIVE ("OS2-SET-POINTER", Prim_OS2_set_pointer, 2, 2, 0)
  933. {
  934.   PRIMITIVE_HEADER (2);
  935.   PRIMITIVE_RETURN
  936.     (BOOLEAN_TO_OBJECT (OS2_set_pointer (pm_qid,
  937.                      (HWND_ARG (1)),
  938.                      (arg_ulong_integer (2)))));
  939. }
  940.  
  941. DEFINE_PRIMITIVE ("OS2WIN-LOAD-POINTER", Prim_OS2_window_load_pointer, 3, 3, 0)
  942. {
  943.   PRIMITIVE_HEADER (3);
  944.   PRIMITIVE_RETURN
  945.     (ulong_to_integer (OS2_window_load_pointer (pm_qid,
  946.                         (HWND_ARG (1)),
  947.                         (arg_ulong_integer (2)),
  948.                         (arg_ulong_integer (3)))));
  949. }
  950.  
  951. DEFINE_PRIMITIVE ("OS2WIN-DESTROY-POINTER", Prim_OS2_window_destroy_pointer, 1, 1, 0)
  952. {
  953.   PRIMITIVE_HEADER (1);
  954.   PRIMITIVE_RETURN
  955.     (BOOLEAN_TO_OBJECT (OS2_window_destroy_pointer (pm_qid,
  956.                             (arg_ulong_integer (1)))));
  957. }
  958.  
  959. DEFINE_PRIMITIVE ("OS2WIN-SET-ICON", Prim_OS2_window_set_icon, 2, 2, 0)
  960. {
  961.   PRIMITIVE_HEADER (2);
  962.   PRIMITIVE_RETURN
  963.     (BOOLEAN_TO_OBJECT
  964.      (OS2_window_set_icon ((wid_argument (1)), (arg_ulong_integer (2)))));
  965. }
  966.  
  967. DEFINE_PRIMITIVE ("OS2WIN-OPEN-EVENT-QID", Prim_OS2_window_open_event_qid, 0, 0, 0)
  968. {
  969.   qid_t local;
  970.   qid_t remote;
  971.   PRIMITIVE_HEADER (0);
  972.   OS2_make_qid_pair ((&local), (&remote));
  973.   OS2_open_qid (local, OS2_scheme_tqueue);
  974.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (local));
  975. }
  976.  
  977. DEFINE_PRIMITIVE ("OS2WIN-CLOSE-EVENT-QID", Prim_OS2_window_close_event_qid, 1, 1, 0)
  978. {
  979.   PRIMITIVE_HEADER (1);
  980.   OS2_close_qid_pair (qid_argument (1));
  981.   PRIMITIVE_RETURN (UNSPECIFIC);
  982. }
  983.  
  984. #define ET_BUTTON    0
  985. #define ET_CLOSE    1
  986. #define ET_FOCUS    2
  987. #define ET_KEY        3
  988. #define ET_PAINT    4
  989. #define ET_RESIZE    5
  990. #define ET_VISIBILITY    6
  991. #define ET_COMMAND    7
  992. #define ET_HELP        8
  993. #define ET_MOUSEMOVE    9
  994.  
  995. #define CVT_USHORT(n, v)                        \
  996.   VECTOR_SET (result, n, (LONG_TO_UNSIGNED_FIXNUM (v)))
  997. #define CVT_SHORT(n, v)                            \
  998.   VECTOR_SET (result, n, (LONG_TO_FIXNUM (v)))
  999. #define CVT_BOOLEAN(n, v)                        \
  1000.   VECTOR_SET (result, n, (BOOLEAN_TO_OBJECT (v)))
  1001.  
  1002. static SCHEME_OBJECT make_button_event
  1003.   (wid_t, MPARAM, MPARAM, unsigned short, unsigned short);
  1004.  
  1005. DEFINE_PRIMITIVE ("OS2WIN-GET-EVENT", Prim_OS2_window_get_event, 2, 2, 0)
  1006. {
  1007.   qid_t qid;
  1008.   int blockp;
  1009.   PRIMITIVE_HEADER (2);
  1010.  
  1011.   qid = (qid_argument (1));
  1012.   blockp = (BOOLEAN_ARG (2));
  1013.   Primitive_GC_If_Needed (8);
  1014.   while (1)
  1015.     {
  1016.       msg_t * message = (OS2_receive_message (qid, blockp, 1));
  1017.       SCHEME_OBJECT result = SHARP_F;
  1018.       if (message == 0)
  1019.     PRIMITIVE_RETURN (result);
  1020.       switch (MSG_TYPE (message))
  1021.     {
  1022.     case mt_pm_event:
  1023.       {
  1024.         wid_t wid = (SM_PM_EVENT_WID (message));
  1025.         ULONG msg = (SM_PM_EVENT_MSG (message));
  1026.         MPARAM mp1 = (SM_PM_EVENT_MP1 (message));
  1027.         MPARAM mp2 = (SM_PM_EVENT_MP2 (message));
  1028.         OS2_destroy_message (message);
  1029.         switch (msg)
  1030.           {
  1031.           case WM_SETFOCUS:
  1032.         {
  1033.           result = (allocate_marked_vector (TC_VECTOR, 3, 0));
  1034.           CVT_USHORT (0, ET_FOCUS);
  1035.           CVT_USHORT (1, wid);
  1036.           CVT_BOOLEAN (2, (SHORT1FROMMP (mp2)));
  1037.           break;
  1038.         }
  1039.           case WM_SIZE:
  1040.         {
  1041.           result = (allocate_marked_vector (TC_VECTOR, 4, 0));
  1042.           CVT_USHORT (0, ET_RESIZE);
  1043.           CVT_USHORT (1, wid);
  1044.           CVT_USHORT (2, (SHORT1FROMMP (mp2)));
  1045.           CVT_USHORT (3, (SHORT2FROMMP (mp2)));
  1046.           break;
  1047.         }
  1048.           case WM_CLOSE:
  1049.         {
  1050.           result = (allocate_marked_vector (TC_VECTOR, 2, 0));
  1051.           CVT_USHORT (0, ET_CLOSE);
  1052.           CVT_USHORT (1, wid);
  1053.           break;
  1054.         }
  1055.           case WM_COMMAND:
  1056.           case WM_HELP:
  1057.         {
  1058.           result = (allocate_marked_vector (TC_VECTOR, 5, 0));
  1059.           CVT_USHORT (0,
  1060.                 ((msg == WM_HELP) ? ET_HELP : ET_COMMAND));
  1061.           CVT_USHORT (1, wid);
  1062.           CVT_USHORT (2, (SHORT1FROMMP (mp1)));
  1063.           CVT_USHORT (3, (SHORT1FROMMP (mp2)));
  1064.           CVT_BOOLEAN (4, (SHORT2FROMMP (mp2)));
  1065.           break;
  1066.         }
  1067.           case WM_SHOW:
  1068.         {
  1069.           result = (allocate_marked_vector (TC_VECTOR, 3, 0));
  1070.           CVT_USHORT (0, ET_VISIBILITY);
  1071.           CVT_USHORT (1, wid);
  1072.           CVT_BOOLEAN (2, (SHORT1FROMMP (mp1)));
  1073.           break;
  1074.         }
  1075.           case WM_CHAR:
  1076.         {
  1077.           unsigned short code;
  1078.           unsigned short flags;
  1079.           unsigned char repeat;
  1080.           if (OS2_translate_wm_char (mp1, mp2,
  1081.                          (&code), (&flags), (&repeat)))
  1082.             {
  1083.               result = (allocate_marked_vector (TC_VECTOR, 5, 0));
  1084.               CVT_USHORT (0, ET_KEY);
  1085.               CVT_USHORT (1, wid);
  1086.               CVT_USHORT (2, code);
  1087.               CVT_USHORT (3, flags);
  1088.               CVT_USHORT (4, repeat);
  1089.             }
  1090.           break;
  1091.         }
  1092.           case WM_BUTTON1DOWN:
  1093.         result = (make_button_event (wid, mp1, mp2, 0, 0));
  1094.         break;
  1095.           case WM_BUTTON1UP:
  1096.         result = (make_button_event (wid, mp1, mp2, 0, 1));
  1097.         break;
  1098.           case WM_BUTTON1CLICK:
  1099.         result = (make_button_event (wid, mp1, mp2, 0, 2));
  1100.         break;
  1101.           case WM_BUTTON1DBLCLK:
  1102.         result = (make_button_event (wid, mp1, mp2, 0, 3));
  1103.         break;
  1104.           case WM_BUTTON2DOWN:
  1105.         result = (make_button_event (wid, mp1, mp2, 1, 0));
  1106.         break;
  1107.           case WM_BUTTON2UP:
  1108.         result = (make_button_event (wid, mp1, mp2, 1, 1));
  1109.         break;
  1110.           case WM_BUTTON2CLICK:
  1111.         result = (make_button_event (wid, mp1, mp2, 1, 2));
  1112.         break;
  1113.           case WM_BUTTON2DBLCLK:
  1114.         result = (make_button_event (wid, mp1, mp2, 1, 3));
  1115.         break;
  1116.           case WM_BUTTON3DOWN:
  1117.         result = (make_button_event (wid, mp1, mp2, 2, 0));
  1118.         break;
  1119.           case WM_BUTTON3UP:
  1120.         result = (make_button_event (wid, mp1, mp2, 2, 1));
  1121.         break;
  1122.           case WM_BUTTON3CLICK:
  1123.         result = (make_button_event (wid, mp1, mp2, 2, 2));
  1124.         break;
  1125.           case WM_BUTTON3DBLCLK:
  1126.         result = (make_button_event (wid, mp1, mp2, 2, 3));
  1127.         break;
  1128.           case WM_MOUSEMOVE:
  1129.         result = (allocate_marked_vector (TC_VECTOR, 6, 0));
  1130.         CVT_USHORT (0, ET_MOUSEMOVE);
  1131.         CVT_USHORT (1, wid);
  1132.         CVT_SHORT (2, (SHORT1FROMMP (mp1)));
  1133.         CVT_SHORT (3, (SHORT2FROMMP (mp1)));
  1134.         CVT_USHORT (4, (SHORT1FROMMP (mp2)));
  1135.         CVT_USHORT (5, (SHORT2FROMMP (mp2)));
  1136.         break;
  1137.           default:
  1138.         break;
  1139.           }
  1140.         break;
  1141.       }
  1142.     case mt_paint_event:
  1143.       {
  1144.         result = (allocate_marked_vector (TC_VECTOR, 6, 0));
  1145.         CVT_USHORT (0, ET_PAINT);
  1146.         CVT_USHORT (1, (SM_PAINT_EVENT_WID (message)));
  1147.         CVT_USHORT (2, (SM_PAINT_EVENT_XL (message)));
  1148.         CVT_USHORT (3, (SM_PAINT_EVENT_XH (message)));
  1149.         CVT_USHORT (4, (SM_PAINT_EVENT_YL (message)));
  1150.         CVT_USHORT (5, (SM_PAINT_EVENT_YH (message)));
  1151.         OS2_destroy_message (message);
  1152.         break;
  1153.       }
  1154.     default:
  1155.       OS2_destroy_message (message);
  1156.       OS2_error_anonymous ();
  1157.       break;
  1158.     }
  1159.       if (result != SHARP_F)
  1160.     PRIMITIVE_RETURN (result);
  1161.     }
  1162. }
  1163.  
  1164. static SCHEME_OBJECT
  1165. make_button_event (wid_t wid, MPARAM mp1, MPARAM mp2,
  1166.            unsigned short number, unsigned short type)
  1167. {
  1168.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 7, 0));
  1169.   CVT_USHORT (0, ET_BUTTON);
  1170.   CVT_USHORT (1, wid);
  1171.   CVT_USHORT (2, number);
  1172.   CVT_USHORT (3, type);
  1173.   CVT_SHORT (4, (SHORT1FROMMP (mp1)));
  1174.   CVT_SHORT (5, (SHORT2FROMMP (mp1)));
  1175.   CVT_USHORT (6, ((SHORT2FROMMP (mp2)) & (KC_SHIFT | KC_CTRL | KC_ALT)));
  1176.   return (result);
  1177. }
  1178.  
  1179. DEFINE_PRIMITIVE ("OS2WIN-EVENT-READY?", Prim_OS2_window_event_ready, 2, 2, 0)
  1180. {
  1181.   PRIMITIVE_HEADER (2);
  1182.   switch (OS2_message_availablep ((qid_argument (1)), (BOOLEAN_ARG (2))))
  1183.     {
  1184.     case mat_available:
  1185.       PRIMITIVE_RETURN (SHARP_T);
  1186.     case mat_not_available:
  1187.       PRIMITIVE_RETURN (SHARP_F);
  1188.     case mat_interrupt:
  1189.       PRIMITIVE_RETURN (FIXNUM_ZERO);
  1190.     }
  1191. }
  1192.  
  1193. DEFINE_PRIMITIVE ("OS2WIN-CONSOLE-WID", Prim_OS2_window_console_wid, 0, 0, 0)
  1194. {
  1195.   extern wid_t OS2_console_wid (void);
  1196.   PRIMITIVE_HEADER (0);
  1197.   PRIMITIVE_RETURN (ulong_to_integer (OS2_console_wid ()));
  1198. }
  1199.  
  1200. DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-WIDTH", Prim_OS2_window_desktop_width, 0, 0, 0)
  1201. {
  1202.   SWP swp;
  1203.   PRIMITIVE_HEADER (0);
  1204.   WinQueryWindowPos (HWND_DESKTOP, (& swp));
  1205.   PRIMITIVE_RETURN (long_to_integer (swp . cx));
  1206. }
  1207.  
  1208. DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-HEIGHT", Prim_OS2_window_desktop_height, 0, 0, 0)
  1209. {
  1210.   SWP swp;
  1211.   PRIMITIVE_HEADER (0);
  1212.   WinQueryWindowPos (HWND_DESKTOP, (& swp));
  1213.   PRIMITIVE_RETURN (long_to_integer (swp . cy));
  1214. }
  1215.