← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/microcode/pros2pm.c

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/microcode/pros2pm.c
 
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
}