/* -*-C-*-
$Id: pros2pm.c,v 1.21 1999/01/02 06:11:34 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
#include "scheme.h"
#include "prims.h"
#define INCL_WIN
#define INCL_GPI
#include "os2.h"
static PPOINTL coordinate_vector_point_args
(unsigned int, unsigned int, unsigned long *);
static qid_t pm_qid;
static qid_t
qid_argument (unsigned int arg_number)
{
unsigned int qid = (arg_index_integer (arg_number, (QID_MAX + 1)));
if (! ((OS2_qid_openp (qid)) && ((OS2_qid_twin (qid)) != QID_NONE)))
error_bad_range_arg (arg_number);
return (qid);
}
static psid_t
psid_argument (unsigned int arg_number)
{
unsigned long result = (arg_ulong_integer (arg_number));
if (!OS2_psid_validp (result))
error_bad_range_arg (arg_number);
return (result);
}
static psid_t
memory_psid_argument (unsigned int arg_number)
{
psid_t psid = (psid_argument (arg_number));
if (!OS2_memory_ps_p (psid))
error_bad_range_arg (arg_number);
return (psid);
}
static wid_t
wid_argument (unsigned int arg_number)
{
unsigned long result = (arg_ulong_integer (arg_number));
if (!OS2_wid_validp (result))
error_bad_range_arg (arg_number);
return (result);
}
static bid_t
bid_argument (unsigned int arg_number)
{
unsigned long result = (arg_ulong_integer (arg_number));
if (!OS2_bid_validp (result))
error_bad_range_arg (arg_number);
return (result);
}
static short
short_arg (unsigned int arg_number)
{
long result = (arg_integer (arg_number));
if (! ((-32768 <= result) && (result < 32768)))
error_bad_range_arg (arg_number);
return (result);
}
#define SSHORT_ARG short_arg
#define USHORT_ARG(n) arg_index_integer ((n), 0x10000)
static unsigned short
dimension_arg (unsigned int arg_number)
{
unsigned short result = (USHORT_ARG (arg_number));
if (result == 0)
error_bad_range_arg (arg_number);
return (result);
}
#define COORDINATE_ARG SSHORT_ARG
#define DIMENSION_ARG dimension_arg
#define HWND_ARG(n) ((HWND) (arg_ulong_integer (n)))
void
OS2_initialize_window_primitives (void)
{
pm_qid = (OS2_create_pm_qid (OS2_scheme_tqueue));
}
DEFINE_PRIMITIVE ("OS2WIN-ALARM", Prim_OS2_window_alarm, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT (WinAlarm (HWND_DESKTOP, (arg_ulong_integer (1)))));
}
DEFINE_PRIMITIVE ("OS2WIN-BEEP", Prim_OS2_window_beep, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
DosBeep ((arg_ulong_integer (1)), (arg_ulong_integer (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PM-SYNCHRONIZE", Prim_OS2_pm_synchronize, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
OS2_pm_synchronize (pm_qid);
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-OPEN", Prim_OS2_window_open, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_open (pm_qid,
(OS2_qid_twin (qid_argument (1))),
(FCF_TITLEBAR | FCF_SYSMENU
| FCF_SHELLPOSITION | FCF_SIZEBORDER
| FCF_MINMAX | FCF_TASKLIST
| FCF_NOBYTEALIGN),
NULLHANDLE,
1,
0,
(STRING_ARG (2)))));
}
DEFINE_PRIMITIVE ("OS2WIN-CLOSE", Prim_OS2_window_close, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_window_close (wid_argument (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-SHOW", Prim_OS2_window_show, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_window_show ((wid_argument (1)), (BOOLEAN_ARG (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-MOVE-CURSOR", Prim_OS2_window_move_cursor, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_window_move_cursor ((wid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-SHAPE-CURSOR", Prim_OS2_window_shape_cursor, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
OS2_window_shape_cursor ((wid_argument (1)),
(DIMENSION_ARG (2)),
(DIMENSION_ARG (3)),
(USHORT_ARG (4)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-SHOW-CURSOR", Prim_OS2_window_show_cursor, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_window_show_cursor ((wid_argument (1)), (BOOLEAN_ARG (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-SCROLL", Prim_OS2_window_scroll, 7, 7, 0)
{
PRIMITIVE_HEADER (7);
OS2_window_scroll ((wid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)),
(COORDINATE_ARG (4)),
(COORDINATE_ARG (5)),
(SSHORT_ARG (6)),
(SSHORT_ARG (7)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-INVALIDATE", Prim_OS2_window_invalidate, 5, 5, 0)
{
PRIMITIVE_HEADER (5);
OS2_window_invalidate ((wid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)),
(COORDINATE_ARG (4)),
(COORDINATE_ARG (5)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-SET-GRID", Prim_OS2_window_set_grid, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_window_set_grid ((wid_argument (1)),
(DIMENSION_ARG (2)),
(DIMENSION_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-ACTIVATE", Prim_OS2_window_activate, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_window_activate (wid_argument (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-GET-POS", Prim_OS2_window_get_pos, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
short x;
short y;
OS2_window_pos ((wid_argument (1)), (& x), (& y));
SET_PAIR_CAR (p, (LONG_TO_FIXNUM (x)));
SET_PAIR_CDR (p, (LONG_TO_FIXNUM (y)));
PRIMITIVE_RETURN (p);
}
}
DEFINE_PRIMITIVE ("OS2WIN-SET-POS", Prim_OS2_window_set_pos, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_window_set_pos ((wid_argument (1)), (SSHORT_ARG (2)), (SSHORT_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-GET-SIZE", Prim_OS2_window_get_size, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
unsigned short width;
unsigned short height;
OS2_window_size ((wid_argument (1)), (& width), (& height));
SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
PRIMITIVE_RETURN (p);
}
}
DEFINE_PRIMITIVE ("OS2WIN-GET-FRAME-SIZE", Prim_OS2_window_get_frame_size, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
unsigned short width;
unsigned short height;
OS2_window_frame_size ((wid_argument (1)), (& width), (& height));
SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
PRIMITIVE_RETURN (p);
}
}
DEFINE_PRIMITIVE ("OS2WIN-SET-SIZE", Prim_OS2_window_set_size, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_window_set_size ((wid_argument (1)), (USHORT_ARG (2)), (USHORT_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-FOCUS?", Prim_OS2_window_focusp, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS2_window_focusp (wid_argument (1))));
}
DEFINE_PRIMITIVE ("OS2WIN-SET-STATE", Prim_OS2_window_set_state, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_window_set_state
((wid_argument (1)),
((window_state_t) (arg_index_integer (2, ((long) state_supremum)))));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-SET-TITLE", Prim_OS2_window_set_title, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_window_set_title ((wid_argument (1)), (STRING_ARG (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-TRACK-MOUSE", Prim_OS2_window_track_mouse, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_window_mousetrack ((wid_argument (1)), (BOOLEAN_ARG (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2WIN-FRAME-HANDLE", Prim_OS2_window_frame_handle, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_frame_handle (wid_argument (1))));
}
DEFINE_PRIMITIVE ("OS2WIN-CLIENT-HANDLE", Prim_OS2_window_client_handle, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_client_handle (wid_argument (1))));
}
DEFINE_PRIMITIVE ("OS2WIN-UPDATE-FRAME", Prim_OS2_window_update_frame, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_window_update_frame ((wid_argument (1)), (USHORT_ARG (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2-WINDOW-HANDLE-FROM-ID", Prim_OS2_window_handle_from_id, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_handle_from_id (pm_qid,
(arg_ulong_integer (1)),
(arg_ulong_integer (2)))));
}
DEFINE_PRIMITIVE ("OS2WIN-QUERY-SYS-VALUE", Prim_OS2_window_query_sys_value, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_query_sys_value (pm_qid,
(HWND_ARG (1)),
(arg_integer (2)))));
}
DEFINE_PRIMITIVE ("OS2-MAP-WINDOW-POINT", Prim_OS2_map_window_point, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
{
SCHEME_OBJECT scheme_point;
POINTL point;
BOOL rc;
CHECK_ARG (3, PAIR_P);
scheme_point = (ARG_REF (3));
if ((!INTEGER_P (PAIR_CAR (scheme_point)))
|| (!INTEGER_P (PAIR_CDR (scheme_point))))
error_wrong_type_arg (3);
if ((!integer_to_long_p (PAIR_CAR (scheme_point)))
|| (!integer_to_long_p (PAIR_CDR (scheme_point))))
error_bad_range_arg (3);
(point . x) = (integer_to_long (PAIR_CAR (scheme_point)));
(point . y) = (integer_to_long (PAIR_CDR (scheme_point)));
rc = (WinMapWindowPoints ((HWND_ARG (1)), (HWND_ARG (2)), (&point), 1));
if (rc)
{
SET_PAIR_CAR (scheme_point, (long_to_integer (point . x)));
SET_PAIR_CDR (scheme_point, (long_to_integer (point . y)));
}
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (rc));
}
}
DEFINE_PRIMITIVE ("OS2WIN-SET-CAPTURE", PRIM_OS2_WINDOW_SET_CAPTURE, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT
(OS2_window_set_capture ((wid_argument (1)), (BOOLEAN_ARG (2)))));
}
DEFINE_PRIMITIVE ("OS2WIN-PS", Prim_OS2_window_ps, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_client_ps (wid_argument (1))));
}
DEFINE_PRIMITIVE ("OS2PS-CREATE-MEMORY-PS", Prim_OS2_create_memory_ps, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN (ulong_to_integer (OS2_create_memory_ps (pm_qid)));
}
DEFINE_PRIMITIVE ("OS2PS-DESTROY-MEMORY-PS", Prim_OS2_destroy_memory_ps, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_destroy_memory_ps (memory_psid_argument (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-CREATE-BITMAP", Prim_OS2_create_bitmap, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_create_bitmap ((psid_argument (1)),
(USHORT_ARG (2)),
(USHORT_ARG (3)))));
}
DEFINE_PRIMITIVE ("OS2PS-DESTROY-BITMAP", Prim_OS2_destroy_bitmap, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_destroy_bitmap (bid_argument (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP", Prim_OS2_ps_get_bitmap, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
bid_t bid = (OS2_ps_get_bitmap ((memory_psid_argument (1))));
PRIMITIVE_RETURN ((bid == BID_NONE) ? SHARP_F : (ulong_to_integer (bid)));
}
}
DEFINE_PRIMITIVE ("OS2PS-SET-BITMAP", Prim_OS2_ps_set_bitmap, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
{
bid_t bid
= (OS2_ps_set_bitmap
((memory_psid_argument (1)),
(((ARG_REF (2)) == SHARP_F) ? BID_NONE : (bid_argument (2)))));
PRIMITIVE_RETURN ((bid == BID_NONE) ? SHARP_F : (ulong_to_integer (bid)));
}
}
DEFINE_PRIMITIVE ("OS2PS-BITBLT", Prim_OS2_ps_bitblt, 6, 6, 0)
{
PRIMITIVE_HEADER (6);
{
void * position = dstack_position;
psid_t target = (psid_argument (1));
psid_t source = (psid_argument (2));
unsigned long npoints;
PPOINTL points = (coordinate_vector_point_args (3, 4, (& npoints)));
LONG rop = (arg_index_integer (5, 0x100));
ULONG options = (arg_ulong_integer (6));
if (! ((npoints == 3) || (npoints == 4)))
error_bad_range_arg (3);
OS2_ps_bitblt (target, source, npoints, points, rop, options);
dstack_set_position (position);
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-WRITE", Prim_OS2_ps_write, 6, 6, 0)
{
PRIMITIVE_HEADER (6);
CHECK_ARG (4, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (4));
unsigned long start = (arg_ulong_integer (5));
unsigned long end = (arg_ulong_integer (6));
if (end > (STRING_LENGTH (string)))
error_bad_range_arg (6);
if (start > end)
error_bad_range_arg (5);
OS2_ps_draw_text ((psid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)),
(STRING_LOC (string, start)),
(end - start));
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-TEXT-WIDTH", Prim_OS2_ps_text_width, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
CHECK_ARG (2, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (2));
unsigned long start = (arg_ulong_integer (3));
unsigned long end = (arg_ulong_integer (4));
if (end > (STRING_LENGTH (string)))
error_bad_range_arg (4);
if (start > end)
error_bad_range_arg (3);
PRIMITIVE_RETURN
(ulong_to_integer
(OS2_ps_text_width ((psid_argument (1)),
(STRING_LOC (string, start)),
(end - start))));
}
}
static SCHEME_OBJECT
convert_font_metrics (font_metrics_t * m)
{
if (m == 0)
return (SHARP_F);
else
{
SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
VECTOR_SET (v, 0, (ulong_to_integer (FONT_METRICS_WIDTH (m))));
VECTOR_SET (v, 1, (ulong_to_integer (FONT_METRICS_HEIGHT (m))));
VECTOR_SET (v, 2, (ulong_to_integer (FONT_METRICS_DESCENDER (m))));
OS_free (m);
return (v);
}
}
DEFINE_PRIMITIVE ("OS2PS-GET-FONT-METRICS", Prim_OS2_ps_get_font_metrics, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(convert_font_metrics (OS2_ps_get_font_metrics (psid_argument (1))));
}
DEFINE_PRIMITIVE ("OS2PS-SET-FONT", Prim_OS2_ps_set_font, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
PRIMITIVE_RETURN
(convert_font_metrics (OS2_ps_set_font ((psid_argument (1)),
(USHORT_ARG (2)),
(STRING_ARG (3)))));
}
DEFINE_PRIMITIVE ("OS2PS-CLEAR", Prim_OS2_ps_clear, 5, 5, 0)
{
PRIMITIVE_HEADER (5);
OS2_ps_clear ((psid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)),
(COORDINATE_ARG (4)),
(COORDINATE_ARG (5)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-SET-COLORS", Prim_OS2_ps_set_colors, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_ps_set_colors ((psid_argument (1)),
(arg_index_integer (2, 0x1000000)),
(arg_index_integer (3, 0x1000000)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-MOVE-GRAPHICS-CURSOR", Prim_OS2_ps_move_gcursor, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_ps_move_gcursor ((psid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-LINE", Prim_OS2_ps_line, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_ps_draw_line ((psid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-DRAW-POINT", Prim_OS2_ps_draw_point, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
OS2_ps_draw_point ((psid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-POLY-LINE", Prim_OS2_ps_poly_line, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
{
void * position = dstack_position;
unsigned long npoints;
PPOINTL points = (coordinate_vector_point_args (2, 3, (& npoints)));
OS2_ps_poly_line ((psid_argument (1)),
npoints,
points);
dstack_set_position (position);
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-POLY-LINE-DISJOINT", Prim_OS2_ps_poly_line_disjoint, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
{
void * position = dstack_position;
unsigned long npoints;
PPOINTL points = (coordinate_vector_point_args (2, 3, (& npoints)));
OS2_ps_poly_line_disjoint ((psid_argument (1)),
npoints,
points);
dstack_set_position (position);
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
static PPOINTL
coordinate_vector_point_args (unsigned int x_no, unsigned int y_no,
unsigned long * npoints)
{
SCHEME_OBJECT x_vector = (ARG_REF (x_no));
SCHEME_OBJECT y_vector = (ARG_REF (y_no));
if (!VECTOR_P (x_vector))
error_wrong_type_arg (x_no);
if (!VECTOR_P (y_vector))
error_wrong_type_arg (y_no);
{
unsigned long length = (VECTOR_LENGTH (x_vector));
if (length != (VECTOR_LENGTH (y_vector)))
error_bad_range_arg (x_no);
{
SCHEME_OBJECT * scan_x = (VECTOR_LOC (x_vector, 0));
SCHEME_OBJECT * end_x = (VECTOR_LOC (x_vector, length));
SCHEME_OBJECT * scan_y = (VECTOR_LOC (y_vector, 0));
PPOINTL points = (dstack_alloc (length * (sizeof (POINTL))));
PPOINTL scan_points = points;
while (scan_x < end_x)
{
SCHEME_OBJECT x = (*scan_x++);
SCHEME_OBJECT y = (*scan_y++);
if (!FIXNUM_P (x))
error_bad_range_arg (x_no);
if (!FIXNUM_P (y))
error_bad_range_arg (y_no);
(scan_points -> x) = (FIXNUM_TO_LONG (x));
(scan_points -> y) = (FIXNUM_TO_LONG (y));
scan_points += 1;
}
(* npoints) = length;
return (points);
}
}
}
DEFINE_PRIMITIVE ("OS2PS-SET-LINE-TYPE", Prim_OS2_ps_set_line_type, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_ps_set_line_type ((psid_argument (1)), (arg_index_integer (2, 10)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-SET-MIX", Prim_OS2_ps_set_mix, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
OS2_ps_set_mix ((psid_argument (1)), (arg_index_integer (2, 18)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-QUERY-CAPABILITIES", Prim_OS2_ps_query_caps, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
{
LONG count = (arg_nonnegative_integer (3));
PLONG values = (OS_malloc (count * (sizeof (LONG))));
OS2_ps_query_caps ((psid_argument (1)),
(arg_nonnegative_integer (2)),
count,
values);
{
SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, count, 1));
LONG index = 0;
while (index < count)
{
VECTOR_SET (v, index, (long_to_integer (values [index])));
index += 1;
}
OS_free (values);
PRIMITIVE_RETURN (v);
}
}
}
DEFINE_PRIMITIVE ("OS2PS-QUERY-CAPABILITY", Prim_OS2_ps_query_cap, 2, 2, 0)
{
LONG values [1];
PRIMITIVE_HEADER (2);
OS2_ps_query_caps ((psid_argument (1)),
(arg_nonnegative_integer (2)),
1,
values);
PRIMITIVE_RETURN (long_to_integer (values [0]));
}
DEFINE_PRIMITIVE ("OS2PS-RESET-CLIP-RECTANGLE", Prim_OS2_ps_reset_clip_rectangle, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_ps_reset_clip_rectangle (psid_argument (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-SET-CLIP-RECTANGLE", Prim_OS2_ps_set_clip_rectangle, 5, 5, 0)
{
PRIMITIVE_HEADER (5);
OS2_ps_set_clip_rectangle ((psid_argument (1)),
(COORDINATE_ARG (2)),
(COORDINATE_ARG (3)),
(COORDINATE_ARG (4)),
(COORDINATE_ARG (5)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP-PARAMETERS", Prim_OS2_ps_get_bitmap_parameters, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
SCHEME_OBJECT s = (allocate_string (sizeof (BITMAPINFOHEADER)));
PBITMAPINFOHEADER params = ((PBITMAPINFOHEADER) (STRING_LOC (s, 0)));
(params -> cbFix) = (sizeof (BITMAPINFOHEADER));
OS2_get_bitmap_parameters ((bid_argument (1)), params);
PRIMITIVE_RETURN (s);
}
}
DEFINE_PRIMITIVE ("OS2PS-GET-BITMAP-BITS", Prim_OS2_ps_get_bitmap_bits, 5, 5, 0)
{
PRIMITIVE_HEADER (5);
PRIMITIVE_RETURN
(ulong_to_integer
(OS2_ps_get_bitmap_bits ((memory_psid_argument (1)),
(arg_ulong_integer (2)),
(arg_ulong_integer (3)),
(STRING_ARG (4)),
((void *) (STRING_ARG (5))))));
}
DEFINE_PRIMITIVE ("OS2PS-SET-BITMAP-BITS", Prim_OS2_ps_set_bitmap_bits, 5, 5, 0)
{
PRIMITIVE_HEADER (5);
PRIMITIVE_RETURN
(ulong_to_integer
(OS2_ps_set_bitmap_bits ((memory_psid_argument (1)),
(arg_ulong_integer (2)),
(arg_ulong_integer (3)),
(STRING_ARG (4)),
((void *) (STRING_ARG (5))))));
}
DEFINE_PRIMITIVE ("OS2-CLIPBOARD-WRITE-TEXT", Prim_OS2_clipboard_write_text, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_clipboard_write_text (pm_qid, (STRING_ARG (1)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2-CLIPBOARD-READ-TEXT", Prim_OS2_clipboard_read_text, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
{
const char * text = (OS2_clipboard_read_text (pm_qid));
SCHEME_OBJECT result;
if (text == 0)
result = SHARP_F;
else
{
result = (char_pointer_to_string ((unsigned char *) text));
OS_free ((void *) text);
}
PRIMITIVE_RETURN (result);
}
}
DEFINE_PRIMITIVE ("OS2MENU-CREATE", Prim_OS2_menu_create, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_menu_create (pm_qid,
(HWND_ARG (1)),
(USHORT_ARG (2)),
(USHORT_ARG (3)))));
}
DEFINE_PRIMITIVE ("OS2MENU-DESTROY", Prim_OS2_menu_destroy, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_menu_destroy (pm_qid, (HWND_ARG (1)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("OS2MENU-INSERT-ITEM", Prim_OS2_menu_insert_item, 7, 7, 0)
{
PRIMITIVE_HEADER (7);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_menu_insert_item (pm_qid,
(HWND_ARG (1)),
(USHORT_ARG (2)),
(USHORT_ARG (3)),
(USHORT_ARG (4)),
(USHORT_ARG (5)),
(HWND_ARG (6)),
(STRING_ARG (7)))));
}
DEFINE_PRIMITIVE ("OS2MENU-REMOVE-ITEM", Prim_OS2_menu_remove_item, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_menu_remove_item (pm_qid,
(HWND_ARG (1)),
(USHORT_ARG (2)),
(BOOLEAN_ARG (3)),
(BOOLEAN_ARG (4)))));
}
DEFINE_PRIMITIVE ("OS2MENU-GET-ITEM", Prim_OS2_menu_get_item, 3, 3, 0)
{
PMENUITEM item;
SCHEME_OBJECT result;
PRIMITIVE_HEADER (3);
item = (OS2_menu_get_item (pm_qid,
(HWND_ARG (1)),
(USHORT_ARG (2)),
(BOOLEAN_ARG (3))));
if (item == 0)
PRIMITIVE_RETURN (SHARP_F);
result = (allocate_marked_vector (TC_VECTOR, 6, 1));
VECTOR_SET (result, 0, (long_to_integer (item -> iPosition)));
VECTOR_SET (result, 1, (ulong_to_integer (item -> afStyle)));
VECTOR_SET (result, 2, (ulong_to_integer (item -> afAttribute)));
VECTOR_SET (result, 3, (ulong_to_integer (item -> id)));
VECTOR_SET (result, 4, (ulong_to_integer (item -> hwndSubMenu)));
VECTOR_SET (result, 5, (ulong_to_integer (item -> hItem)));
OS_free (item);
PRIMITIVE_RETURN (result);
}
DEFINE_PRIMITIVE ("OS2MENU-N-ITEMS", Prim_OS2_menu_n_items, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_menu_n_items (pm_qid, (HWND_ARG (1)))));
}
DEFINE_PRIMITIVE ("OS2MENU-NTH-ITEM-ID", Prim_OS2_menu_nth_item_id, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_menu_nth_item_id (pm_qid,
(HWND_ARG (1)),
(USHORT_ARG (2)))));
}
DEFINE_PRIMITIVE ("OS2MENU-GET-ITEM-ATTRIBUTES", Prim_OS2_menu_get_item_attributes, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_menu_get_item_attributes (pm_qid,
(HWND_ARG (1)),
(USHORT_ARG (2)),
(BOOLEAN_ARG (3)),
(USHORT_ARG (4)))));
}
DEFINE_PRIMITIVE ("OS2MENU-SET-ITEM-ATTRIBUTES", Prim_OS2_menu_set_item_attributes, 5, 5, 0)
{
PRIMITIVE_HEADER (5);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT (OS2_menu_set_item_attributes (pm_qid,
(HWND_ARG (1)),
(USHORT_ARG (2)),
(BOOLEAN_ARG (3)),
(USHORT_ARG (4)),
(USHORT_ARG (5)))));
}
DEFINE_PRIMITIVE ("OS2WIN-LOAD-MENU", Prim_OS2_window_load_menu, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_load_menu ((wid_argument (1)),
(arg_ulong_integer (2)),
(arg_ulong_integer (3)))));
}
DEFINE_PRIMITIVE ("OS2WIN-POPUP-MENU", Prim_OS2_window_popup_menu, 7, 7, 0)
{
PRIMITIVE_HEADER (7);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT
(OS2_window_popup_menu (pm_qid,
(HWND_ARG (1)),
(HWND_ARG (2)),
(HWND_ARG (3)),
(arg_integer (4)),
(arg_integer (5)),
(arg_integer (6)),
(arg_ulong_integer (7)))));
}
DEFINE_PRIMITIVE ("OS2WIN-FONT-DIALOG", Prim_OS2_window_font_dialog, 2, 2, 0)
{
const char * spec;
SCHEME_OBJECT result;
PRIMITIVE_HEADER (2);
spec = (OS2_window_font_dialog ((wid_argument (1)),
(((ARG_REF (2)) == SHARP_F)
? 0
: (STRING_ARG (2)))));
if (spec == 0)
PRIMITIVE_RETURN (SHARP_F);
result = (char_pointer_to_string ((char *) spec));
OS_free ((void *) spec);
PRIMITIVE_RETURN (result);
}
DEFINE_PRIMITIVE ("OS2-QUERY-SYSTEM-POINTER", Prim_OS2_query_system_pointer, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_query_system_pointer (pm_qid,
(HWND_ARG (1)),
(arg_integer (2)),
(BOOLEAN_ARG (3)))));
}
DEFINE_PRIMITIVE ("OS2-SET-POINTER", Prim_OS2_set_pointer, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT (OS2_set_pointer (pm_qid,
(HWND_ARG (1)),
(arg_ulong_integer (2)))));
}
DEFINE_PRIMITIVE ("OS2WIN-LOAD-POINTER", Prim_OS2_window_load_pointer, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
PRIMITIVE_RETURN
(ulong_to_integer (OS2_window_load_pointer (pm_qid,
(HWND_ARG (1)),
(arg_ulong_integer (2)),
(arg_ulong_integer (3)))));
}
DEFINE_PRIMITIVE ("OS2WIN-DESTROY-POINTER", Prim_OS2_window_destroy_pointer, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT (OS2_window_destroy_pointer (pm_qid,
(arg_ulong_integer (1)))));
}
DEFINE_PRIMITIVE ("OS2WIN-SET-ICON", Prim_OS2_window_set_icon, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT
(OS2_window_set_icon ((wid_argument (1)), (arg_ulong_integer (2)))));
}
DEFINE_PRIMITIVE ("OS2WIN-OPEN-EVENT-QID", Prim_OS2_window_open_event_qid, 0, 0, 0)
{
qid_t local;
qid_t remote;
PRIMITIVE_HEADER (0);
OS2_make_qid_pair ((&local), (&remote));
OS2_open_qid (local, OS2_scheme_tqueue);
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (local));
}
DEFINE_PRIMITIVE ("OS2WIN-CLOSE-EVENT-QID", Prim_OS2_window_close_event_qid, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
OS2_close_qid_pair (qid_argument (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
#define ET_BUTTON 0
#define ET_CLOSE 1
#define ET_FOCUS 2
#define ET_KEY 3
#define ET_PAINT 4
#define ET_RESIZE 5
#define ET_VISIBILITY 6
#define ET_COMMAND 7
#define ET_HELP 8
#define ET_MOUSEMOVE 9
#define CVT_USHORT(n, v) \
VECTOR_SET (result, n, (LONG_TO_UNSIGNED_FIXNUM (v)))
#define CVT_SHORT(n, v) \
VECTOR_SET (result, n, (LONG_TO_FIXNUM (v)))
#define CVT_BOOLEAN(n, v) \
VECTOR_SET (result, n, (BOOLEAN_TO_OBJECT (v)))
static SCHEME_OBJECT make_button_event
(wid_t, MPARAM, MPARAM, unsigned short, unsigned short);
DEFINE_PRIMITIVE ("OS2WIN-GET-EVENT", Prim_OS2_window_get_event, 2, 2, 0)
{
qid_t qid;
int blockp;
PRIMITIVE_HEADER (2);
qid = (qid_argument (1));
blockp = (BOOLEAN_ARG (2));
Primitive_GC_If_Needed (8);
while (1)
{
msg_t * message = (OS2_receive_message (qid, blockp, 1));
SCHEME_OBJECT result = SHARP_F;
if (message == 0)
PRIMITIVE_RETURN (result);
switch (MSG_TYPE (message))
{
case mt_pm_event:
{
wid_t wid = (SM_PM_EVENT_WID (message));
ULONG msg = (SM_PM_EVENT_MSG (message));
MPARAM mp1 = (SM_PM_EVENT_MP1 (message));
MPARAM mp2 = (SM_PM_EVENT_MP2 (message));
OS2_destroy_message (message);
switch (msg)
{
case WM_SETFOCUS:
{
result = (allocate_marked_vector (TC_VECTOR, 3, 0));
CVT_USHORT (0, ET_FOCUS);
CVT_USHORT (1, wid);
CVT_BOOLEAN (2, (SHORT1FROMMP (mp2)));
break;
}
case WM_SIZE:
{
result = (allocate_marked_vector (TC_VECTOR, 4, 0));
CVT_USHORT (0, ET_RESIZE);
CVT_USHORT (1, wid);
CVT_USHORT (2, (SHORT1FROMMP (mp2)));
CVT_USHORT (3, (SHORT2FROMMP (mp2)));
break;
}
case WM_CLOSE:
{
result = (allocate_marked_vector (TC_VECTOR, 2, 0));
CVT_USHORT (0, ET_CLOSE);
CVT_USHORT (1, wid);
break;
}
case WM_COMMAND:
case WM_HELP:
{
result = (allocate_marked_vector (TC_VECTOR, 5, 0));
CVT_USHORT (0,
((msg == WM_HELP) ? ET_HELP : ET_COMMAND));
CVT_USHORT (1, wid);
CVT_USHORT (2, (SHORT1FROMMP (mp1)));
CVT_USHORT (3, (SHORT1FROMMP (mp2)));
CVT_BOOLEAN (4, (SHORT2FROMMP (mp2)));
break;
}
case WM_SHOW:
{
result = (allocate_marked_vector (TC_VECTOR, 3, 0));
CVT_USHORT (0, ET_VISIBILITY);
CVT_USHORT (1, wid);
CVT_BOOLEAN (2, (SHORT1FROMMP (mp1)));
break;
}
case WM_CHAR:
{
unsigned short code;
unsigned short flags;
unsigned char repeat;
if (OS2_translate_wm_char (mp1, mp2,
(&code), (&flags), (&repeat)))
{
result = (allocate_marked_vector (TC_VECTOR, 5, 0));
CVT_USHORT (0, ET_KEY);
CVT_USHORT (1, wid);
CVT_USHORT (2, code);
CVT_USHORT (3, flags);
CVT_USHORT (4, repeat);
}
break;
}
case WM_BUTTON1DOWN:
result = (make_button_event (wid, mp1, mp2, 0, 0));
break;
case WM_BUTTON1UP:
result = (make_button_event (wid, mp1, mp2, 0, 1));
break;
case WM_BUTTON1CLICK:
result = (make_button_event (wid, mp1, mp2, 0, 2));
break;
case WM_BUTTON1DBLCLK:
result = (make_button_event (wid, mp1, mp2, 0, 3));
break;
case WM_BUTTON2DOWN:
result = (make_button_event (wid, mp1, mp2, 1, 0));
break;
case WM_BUTTON2UP:
result = (make_button_event (wid, mp1, mp2, 1, 1));
break;
case WM_BUTTON2CLICK:
result = (make_button_event (wid, mp1, mp2, 1, 2));
break;
case WM_BUTTON2DBLCLK:
result = (make_button_event (wid, mp1, mp2, 1, 3));
break;
case WM_BUTTON3DOWN:
result = (make_button_event (wid, mp1, mp2, 2, 0));
break;
case WM_BUTTON3UP:
result = (make_button_event (wid, mp1, mp2, 2, 1));
break;
case WM_BUTTON3CLICK:
result = (make_button_event (wid, mp1, mp2, 2, 2));
break;
case WM_BUTTON3DBLCLK:
result = (make_button_event (wid, mp1, mp2, 2, 3));
break;
case WM_MOUSEMOVE:
result = (allocate_marked_vector (TC_VECTOR, 6, 0));
CVT_USHORT (0, ET_MOUSEMOVE);
CVT_USHORT (1, wid);
CVT_SHORT (2, (SHORT1FROMMP (mp1)));
CVT_SHORT (3, (SHORT2FROMMP (mp1)));
CVT_USHORT (4, (SHORT1FROMMP (mp2)));
CVT_USHORT (5, (SHORT2FROMMP (mp2)));
break;
default:
break;
}
break;
}
case mt_paint_event:
{
result = (allocate_marked_vector (TC_VECTOR, 6, 0));
CVT_USHORT (0, ET_PAINT);
CVT_USHORT (1, (SM_PAINT_EVENT_WID (message)));
CVT_USHORT (2, (SM_PAINT_EVENT_XL (message)));
CVT_USHORT (3, (SM_PAINT_EVENT_XH (message)));
CVT_USHORT (4, (SM_PAINT_EVENT_YL (message)));
CVT_USHORT (5, (SM_PAINT_EVENT_YH (message)));
OS2_destroy_message (message);
break;
}
default:
OS2_destroy_message (message);
OS2_error_anonymous ();
break;
}
if (result != SHARP_F)
PRIMITIVE_RETURN (result);
}
}
static SCHEME_OBJECT
make_button_event (wid_t wid, MPARAM mp1, MPARAM mp2,
unsigned short number, unsigned short type)
{
SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 7, 0));
CVT_USHORT (0, ET_BUTTON);
CVT_USHORT (1, wid);
CVT_USHORT (2, number);
CVT_USHORT (3, type);
CVT_SHORT (4, (SHORT1FROMMP (mp1)));
CVT_SHORT (5, (SHORT2FROMMP (mp1)));
CVT_USHORT (6, ((SHORT2FROMMP (mp2)) & (KC_SHIFT | KC_CTRL | KC_ALT)));
return (result);
}
DEFINE_PRIMITIVE ("OS2WIN-EVENT-READY?", Prim_OS2_window_event_ready, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
switch (OS2_message_availablep ((qid_argument (1)), (BOOLEAN_ARG (2))))
{
case mat_available:
PRIMITIVE_RETURN (SHARP_T);
case mat_not_available:
PRIMITIVE_RETURN (SHARP_F);
case mat_interrupt:
PRIMITIVE_RETURN (FIXNUM_ZERO);
}
}
DEFINE_PRIMITIVE ("OS2WIN-CONSOLE-WID", Prim_OS2_window_console_wid, 0, 0, 0)
{
extern wid_t OS2_console_wid (void);
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN (ulong_to_integer (OS2_console_wid ()));
}
DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-WIDTH", Prim_OS2_window_desktop_width, 0, 0, 0)
{
SWP swp;
PRIMITIVE_HEADER (0);
WinQueryWindowPos (HWND_DESKTOP, (& swp));
PRIMITIVE_RETURN (long_to_integer (swp . cx));
}
DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-HEIGHT", Prim_OS2_window_desktop_height, 0, 0, 0)
{
SWP swp;
PRIMITIVE_HEADER (0);
WinQueryWindowPos (HWND_DESKTOP, (& swp));
PRIMITIVE_RETURN (long_to_integer (swp . cy));
}
syntax highlighted by Code2HTML, v. 0.9.1