/* -*-C-*-
$Id: ntgui.c,v 1.28 2000/12/05 21:23:45 cph Exp $
Copyright (c) 1993-2000 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 <string.h>
#include <stdarg.h>
#include "scheme.h"
#include "prims.h"
#include "os.h"
#include "nt.h"
#include "ntdialog.h"
#include "ntgui.h"
#include "ntscreen.h"
extern /*static*/ HANDLE ghInstance = 0;
extern void scheme_main (int argc, const char ** argv);
extern void NT_preallocate_heap (void);
BOOL InitApplication(HANDLE);
BOOL InitInstance(HANDLE, int);
static SCHEME_OBJECT parse_event (SCREEN_EVENT *);
int WINAPI
WinMain (HANDLE hInst, HANDLE hPrevInst, LPSTR lpCmdLine, int nCmdShow)
{
int argc;
char **argv;
extern int main (int, char **);
NT_preallocate_heap ();
ghInstance = hInst;
{
int cmdlen = strlen(lpCmdLine);
int maxargs = cmdlen/2+2;
char *cmdline = malloc(cmdlen+1);
char *s;
argv = malloc(sizeof(char*) * maxargs);
if (cmdline==0 || argv==0) {
outf_fatal ("WinMain cant malloc");
outf_flush_fatal ();
return FALSE;
}
argc = 1;
argv[0] = "scheme";
s = strcpy (cmdline, lpCmdLine);
while ((*s) != '\0')
{
while ((*s) == ' ')
s += 1;
if ((*s) == '"')
{
s += 1;
(argv[argc++]) = s;
while (1)
{
if ((*s) == '"')
{
(*s++) = '\0';
break;
}
if ((*s) == '\0')
{
outf_fatal ("WinMain: unterminated quoted argument.");
outf_flush_fatal ();
return (FALSE);
}
s += 1;
}
}
else
{
(argv[argc++]) = s;
while (1)
{
if ((*s) == ' ')
{
(*s++) = '\0';
break;
}
if ((*s) == '\0')
break;
s += 1;
}
}
}
argv[argc] = 0;
}
if (!hPrevInst)
if (!InitApplication(ghInstance))
return FALSE;
if (!InitInstance(ghInstance, nCmdShow))
return FALSE;
scheme_main (argc, ((const char **) argv));
return (0);
}
BOOL
DEFUN (InitApplication, (hInstance), HANDLE hInstance)
{
static BOOL done = FALSE;
if (done) return (TRUE);
done = TRUE;
return (Screen_InitApplication (hInstance));
}
static BOOL instance_initialized = FALSE;
BOOL
DEFUN (InitInstance, (hInstance, nCmdShow), HANDLE hInstance AND int nCmdShow)
{
instance_initialized = TRUE;
return (Screen_InitInstance (hInstance, nCmdShow));
}
void
DEFUN_VOID (nt_gui_default_poll)
{
MSG msg;
int events_processed = 0;
while (PeekMessage ((&msg), 0, 0, 0, PM_REMOVE))
{
DispatchMessage (&msg);
events_processed += 1;
}
}
extern HANDLE master_tty_window;
extern void catatonia_trigger (void);
extern unsigned long * win32_catatonia_block;
void
catatonia_trigger (void)
{
int mes_result;
static BOOL already_exitting = FALSE;
SCHEME_OBJECT saved = win32_catatonia_block[CATATONIA_BLOCK_LIMIT];
win32_catatonia_block[CATATONIA_BLOCK_LIMIT] = 0;
mes_result = (MessageBox (master_tty_window,
"Scheme appears to have become catatonic.\n"
"OK to kill it?",
"MIT Scheme",
(MB_ICONSTOP | MB_OKCANCEL)));
win32_catatonia_block[CATATONIA_BLOCK_COUNTER] = 0;
win32_catatonia_block[CATATONIA_BLOCK_LIMIT] = saved;
if (mes_result != IDOK)
return;
else if (already_exitting)
exit (1);
else
{
already_exitting = TRUE;
termination_normal (0);
}
}
static void
nt_gui_high_priority_poll (void)
{
MSG close_msg;
if (PeekMessage (&close_msg, master_tty_window,
WM_CATATONIC, (WM_CATATONIC + 1),
PM_REMOVE))
DispatchMessage (&close_msg);
}
DEFINE_PRIMITIVE ("MICROCODE-POLL-INTERRUPT-HANDLER", Prim_microcode_poll_interrupt_handler, 2, 2,
"NT High-priority timer interrupt handler for Windows I/O.")
{
#ifndef USE_WM_TIMER
extern void low_level_timer_tick (void);
#endif
PRIMITIVE_HEADER (2);
if (((ARG_REF (1)) & (ARG_REF (2)) & INT_Global_GC) != 0)
{
nt_gui_high_priority_poll ();
CLEAR_INTERRUPT (INT_Global_GC);
}
else
{
win32_catatonia_block[CATATONIA_BLOCK_COUNTER] = 0;
nt_gui_default_poll ();
#ifndef USE_WM_TIMER
low_level_timer_tick ();
#endif
CLEAR_INTERRUPT (INT_Global_1);
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("NT-DEFAULT-POLL-GUI", Prim_nt_default_poll_gui, 2, 2, 0)
{
PRIMITIVE_HEADER(2)
{
nt_gui_default_poll ();
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
extern void EXFUN (NT_gui_init, (void));
void
DEFUN_VOID (NT_gui_init)
{
if (!instance_initialized)
{
if (!InitApplication (ghInstance))
outf_console ("InitApplication failed\n");
if (!InitInstance (ghInstance, SW_SHOWNORMAL))
outf_console ("InitInstance failed\n");
}
}
static long
scheme_object_to_windows_object (SCHEME_OBJECT thing)
{
if (INTEGER_P (thing))
return integer_to_long (thing);
if (STRING_P (thing))
return (long) STRING_LOC (thing, 0);
if (thing==SHARP_F)
return 0;
if (thing==SHARP_T)
return 1;
if (OBJECT_TYPE (thing) == TC_VECTOR_1B ||
OBJECT_TYPE (thing) == TC_VECTOR_16B)
return (long) VECTOR_LOC (thing, 0);
return (long)thing;
}
/****************************************************************************/
/* first scheme window procedure requires every procedure to be purified */
/****************************************************************************/
extern SCHEME_OBJECT C_call_scheme (SCHEME_OBJECT, long, SCHEME_OBJECT *);
static SCHEME_OBJECT
apply4 (SCHEME_OBJECT procedure, SCHEME_OBJECT arg1, SCHEME_OBJECT arg2,
SCHEME_OBJECT arg3, SCHEME_OBJECT arg4)
{
SCHEME_OBJECT argvec [4];
(argvec[0]) = arg1;
(argvec[1]) = arg2;
(argvec[2]) = arg3;
(argvec[3]) = arg4;
return (C_call_scheme (procedure, 4, argvec));
}
LRESULT CALLBACK
C_to_Scheme_WndProc (HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)
{
SCHEME_OBJECT thunk;
SCHEME_OBJECT result;
if (message==WM_CREATE || message==WM_NCCREATE) {
/*install thunk*/
LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
SetWindowLong(hwnd, 0, (LONG)lpcs->lpCreateParams);
}
thunk = GetWindowLong (hwnd, 0);
if (thunk==0)
return DefWindowProc (hwnd, message, wParam, lParam);
result
= (apply4 (thunk,
(ulong_to_integer ((unsigned long) hwnd)),
(ulong_to_integer (message)),
(ulong_to_integer (wParam)),
(ulong_to_integer (lParam))));
return scheme_object_to_windows_object (result);
}
DEFINE_PRIMITIVE ("GET-SCHEME-WINDOW-PROCEDURE", Prim_get_scheme_window_procedure, 1, 1, 0)
{
PRIMITIVE_HEADER(1);
{
HWND hWnd = (HWND)arg_integer (1);
SCHEME_OBJECT result;
if (GetWindowLong(hWnd, GWL_WNDPROC) != (LONG) C_to_Scheme_WndProc)
result = SHARP_F;
else
result = (SCHEME_OBJECT) GetWindowLong(hWnd, 0);
PRIMITIVE_RETURN (result);
}
}
/****************************************************************************/
/*
Second version: There is only one scheme wndproc, which is called
to re-dispatch to the correct wndproc, indexing of the hwnd argument.
The one scheme procedure is set with SET-GENERAL-SCHEME-WNDPROC.
The procedure must be a purified first.
*/
static SCHEME_OBJECT general_scheme_wndproc = SHARP_F;
DEFINE_PRIMITIVE ("GET-GENERAL-SCHEME-WNDPROC", Prim_get_general_scheme_wndproc, 0, 0, 0)
{
PRIMITIVE_HEADER(0);
{
PRIMITIVE_RETURN (general_scheme_wndproc);
}
}
DEFINE_PRIMITIVE ("SET-GENERAL-SCHEME-WNDPROC", Prim_set_general_scheme_wndproc, 1, 1, 0)
{
PRIMITIVE_HEADER(1);
{
SCHEME_OBJECT wndproc = ARG_REF(1);
if (! (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (wndproc))))
signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
general_scheme_wndproc = wndproc;
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
LRESULT CALLBACK
C_to_Scheme_WndProc_2 (HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)
{
SCHEME_OBJECT result;
if (general_scheme_wndproc == SHARP_F)
return DefWindowProc (hwnd, message, wParam, lParam);
result
= (apply4 (general_scheme_wndproc,
(ulong_to_integer ((unsigned long) hwnd)),
(ulong_to_integer (message)),
(ulong_to_integer (wParam)),
(ulong_to_integer (lParam))));
return scheme_object_to_windows_object (result);
}
/***************************************************************************/
void
failed_foreign_function (void)
{
PRIMITIVE_ABORT (ERR_INAPPLICABLE_OBJECT);
}
DEFINE_PRIMITIVE ("GET-HANDLE", Prim_get_handle, 1, 1,
"(id)\n"
"Returns an otherwise hard to get global C variable\n"
"id entity\n"
"0 instance handle\n"
"1 master tty handle\n"
"2 C to Scheme windows procedure address\n"
"3 C to Scheme windows procedure address (eta version)\n"
"4 failed-foreign-function address\n")
{
PRIMITIVE_HEADER(1);
{
long arg = arg_integer (1);
long result = 0;
switch (arg) {
case 0: result = (long) ghInstance; break;
case 1: result = (long) master_tty_window; break;
case 2: result = (long) C_to_Scheme_WndProc; break;
case 3: result = (long) C_to_Scheme_WndProc_2; break;
case 4: result = (long) failed_foreign_function; break;
default: error_bad_range_arg (1);
}
PRIMITIVE_RETURN (long_to_integer (result));
}
}
static unsigned long
DEFUN (arg_ulong_default, (arg_number, def),
int arg_number AND unsigned long def)
{
fast SCHEME_OBJECT object = (ARG_REF (arg_number));
if (object == SHARP_F)
return def;
if (! (INTEGER_P (object)))
error_wrong_type_arg (arg_number);
return integer_to_ulong (object);
}
DEFINE_PRIMITIVE ("WIN:CREATE-WINDOW", Prim_create_window, 10, 10,
"class-name\n"
"window-name\n"
"style\n"
"X\n"
"Y\n"
"width\n"
"height\n"
"parent\n"
"menu\n"
"(instance omitted)\n"
"lpParam: (lambda (hwnd message wparam lparam)). [think about MDI later]\n")
{
LPSTR class_name;
LPSTR window_name;
DWORD style;
int x, y, w, h;
HWND hWndParent;
HMENU hMenu;
LPVOID lpvParam;
HWND result;
CHECK_ARG (1, STRING_P);
CHECK_ARG (2, STRING_P);
class_name = STRING_LOC (ARG_REF (1), 0);
window_name = STRING_LOC (ARG_REF (2), 0);
style = integer_to_ulong (ARG_REF (3));
x = (int) arg_ulong_default (4, ((unsigned long) CW_USEDEFAULT));
y = (int) arg_ulong_default (5, ((unsigned long) CW_USEDEFAULT));
w = (int) arg_ulong_default (6, ((unsigned long) CW_USEDEFAULT));
h = (int) arg_ulong_default (7, ((unsigned long) CW_USEDEFAULT));
hWndParent = (HWND) arg_ulong_default (8, 0);
hMenu = (HMENU) arg_ulong_default (9, 0);
lpvParam = (LPVOID) ARG_REF (10);
result = CreateWindowEx (0, class_name, window_name, style, x, y, w, h,
hWndParent, hMenu, ghInstance, lpvParam);
return ulong_to_integer ((unsigned long) result);
}
DEFINE_PRIMITIVE ("WIN:DEF-WINDOW-PROC", Prim_def_window_proc, 4, 4, 0)
{
#if 0
outf_console ("\001");
#endif
return
long_to_integer
(DefWindowProc
(((HWND) (scheme_object_to_windows_object (ARG_REF (1)))),
((UINT) (scheme_object_to_windows_object (ARG_REF (2)))),
((WPARAM) (scheme_object_to_windows_object (ARG_REF (3)))),
((LPARAM) (scheme_object_to_windows_object (ARG_REF (4))))));
}
DEFINE_PRIMITIVE ("REGISTER-CLASS", Prim__register_class, 10, 10,
"(style wndproc clsExtra wndExtra hInstance hIcon hCursor\n"
" hBackground menu-name class-name)\n"
"\n"
"cursor = 32512(arrow), 32513(ibeam), 32514(hourglass),\n"
" 32515(cross), 32516(uparrow)\n"
"background = 0 (white_brush)\n")
{
/* should lift background and cursor */
WNDCLASS wc;
BOOL rc;
PRIMITIVE_HEADER (10);
CHECK_ARG (10, STRING_P);
wc.style = arg_integer (1);
wc.lpfnWndProc = ((WNDPROC) (arg_integer (2)));
wc.cbClsExtra = scheme_object_to_windows_object (ARG_REF(3));
wc.cbWndExtra = scheme_object_to_windows_object (ARG_REF(4));
wc.hInstance = (HANDLE)scheme_object_to_windows_object (ARG_REF(5));
wc.hIcon = (HANDLE)scheme_object_to_windows_object (ARG_REF(6));
wc.hCursor = LoadCursor (NULL, MAKEINTRESOURCE(arg_integer(7)));
wc.hbrBackground = GetStockObject (arg_integer(8));
wc.lpszMenuName = (char*)scheme_object_to_windows_object (ARG_REF(9));
wc.lpszClassName = (char*)scheme_object_to_windows_object (ARG_REF(10));
rc = RegisterClass (&wc);
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT(rc));
}
DEFINE_PRIMITIVE ("APPLY_1", Prim_apply_1_xyz, 2, 2, 0)
{
SCHEME_OBJECT proc, arg, result;
PRIMITIVE_HEADER (2);
proc = ARG_REF (1);
arg = ARG_REF (2);
result = C_call_scheme (proc, 1, &arg);
PRIMITIVE_RETURN (result);
}
/************************************************************************/
/* Primitive versions of library stuff */
/************************************************************************/
DEFINE_PRIMITIVE ("NT:GET-MODULE-HANDLE", Prim_get_module_handle, 1, 1,
"(string) -> handle")
{
HANDLE it;
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
it = GetModuleHandle (STRING_LOC (ARG_REF (1), 0));
PRIMITIVE_RETURN (long_to_integer ((long) it));
}
DEFINE_PRIMITIVE ("NT:LOAD-LIBRARY", Prim_nt_load_library, 1, 1,
"(string) -> handle")
{
HANDLE it;
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
it = LoadLibrary ((LPSTR)STRING_LOC (ARG_REF (1), 0));
PRIMITIVE_RETURN (long_to_integer ((long) it));
}
DEFINE_PRIMITIVE ("NT:FREE-LIBRARY", Prim_nt_free_library, 1, 1,
"(library-module-handle) -> bool")
{
HANDLE handle;
BOOL result;
PRIMITIVE_HEADER (1);
handle = ((HANDLE) (arg_integer (1)));
result = FreeLibrary (handle);
PRIMITIVE_RETURN (result ? SHARP_T : SHARP_F);
}
DEFINE_PRIMITIVE ("NT:GET-PROC-ADDRESS", Prim_nt_get_proc_address, 2, 2,
"(handle string/integer) -> address")
{
HMODULE module;
LPSTR function_name;
FARPROC it;
SCHEME_OBJECT function;
PRIMITIVE_HEADER (2);
module = (HMODULE) arg_integer (1);
function = ARG_REF (2);
if (STRING_P (function))
function_name = STRING_LOC (function, 0);
else
function_name = (LPSTR) arg_integer (2);
it = GetProcAddress (module, function_name);
PRIMITIVE_RETURN (it==NULL ? SHARP_F : long_to_integer ((long) it));
}
DEFINE_PRIMITIVE ("NT:SEND-MESSAGE", Prim_send_message, 4, 4,
"(handle message wparam lparam)")
{
HWND hwnd;
UINT message;
WPARAM wParam;
LPARAM lParam;
SCHEME_OBJECT thing;
PRIMITIVE_HEADER (4);
hwnd = (HWND) arg_integer (1);
message = arg_integer (2);
wParam = arg_integer (3);
thing = ARG_REF (4);
if (STRING_P (thing))
lParam = (LPARAM) STRING_LOC (thing, 0);
else
lParam = arg_integer (4);
PRIMITIVE_RETURN (
long_to_integer (SendMessage (hwnd, message, wParam, lParam)));
}
static SCHEME_OBJECT call_ff_really (void);
DEFINE_PRIMITIVE ("CALL-FF", Prim_call_ff, 0, LEXPR, 0)
{
/* This indirection saves registers correctly in this stack frame
rather than in a bad position in relation to the bogus C argument
stack. */
PRIMITIVE_HEADER (LEXPR);
PRIMITIVE_RETURN (call_ff_really ());
}
static SCHEME_OBJECT
call_ff_really (void)
{
long function_address;
SCHEME_OBJECT * argument_scan;
SCHEME_OBJECT * argument_limit;
long result = UNSPECIFIC;
long nargs = (LEXPR_N_ARGUMENTS ());
if (nargs < 1)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
if (nargs > 30)
signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
function_address = (arg_integer (1));
argument_scan = (ARG_LOC (nargs + 1));
argument_limit = (ARG_LOC (2));
while (argument_scan > argument_limit)
{
long arg
= (scheme_object_to_windows_object
(STACK_LOCATIVE_PUSH (argument_scan)));
#ifdef CL386
__asm push arg
#else /* not CL386 */
#ifdef __WATCOMC__
{
extern void call_ff_really_1 (void);
#pragma aux call_ff_really_1 = "push arg";
call_ff_really_1 ();
}
#endif /* __WATCOMC__ */
#endif /* not CL386 */
}
#ifdef CL386
__asm
{
mov eax, function_address
call eax
mov result, eax
}
#else /* not CL386 */
#ifdef __WATCOMC__
{
extern void call_ff_really_2 (void);
#pragma aux call_ff_really_2 = \
"mov eax,function_address" \
"call eax" \
"mov result,eax" \
modify [eax edx ecx];
call_ff_really_2 ();
}
#endif /* __WATCOMC__ */
#endif /* not CL386 */
return (long_to_integer (result));
}
/* Primitives for hacking strings, to fetch and set signed and
unsigned 32 and 16 bit values at byte offsets. */
DEFINE_PRIMITIVE ("INT32-OFFSET-REF", Prim_int32_offset_ref, 2, 2,
"(mem-addr byte-offset)\n"
"Fetch 32 bit signed long from memory (a string)")
{
PRIMITIVE_HEADER (2);
{
long *base;
int offset;
CHECK_ARG (1, STRING_P);
base = (long*) STRING_LOC (ARG_REF(1), 0);
offset = arg_integer (2);
PRIMITIVE_RETURN ( long_to_integer(* (long*) (((char*)base)+offset) ) );
}
}
DEFINE_PRIMITIVE ("INT32-OFFSET-SET!", Prim_int32_offset_set, 3, 3,
"(mem-addr byte-offset 32-bit-value)\n"
"Set 32 bit signed long from memory (integer address or vector data)")
{
PRIMITIVE_HEADER (3);
{
long *base;
int offset;
long value;
CHECK_ARG (1, STRING_P);
base = (long*) STRING_LOC (ARG_REF(1), 0);
offset = arg_integer (2);
value = scheme_object_to_windows_object (ARG_REF (3));
* (long*) (((char*)base)+offset) = value;
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("UINT32-OFFSET-REF", Prim_uint32_offset_ref, 2, 2,
"(mem-addr byte-offset)\n"
"Fetch 32 bit unsigned long from memory (a string)")
{
PRIMITIVE_HEADER (2);
{
unsigned long *base;
int offset;
CHECK_ARG (1, STRING_P);
base = (unsigned long*) STRING_LOC (ARG_REF(1), 0);
offset = arg_integer (2);
PRIMITIVE_RETURN
(ulong_to_integer(* (unsigned long*) (((char*)base)+offset)));
}
}
DEFINE_PRIMITIVE ("UINT32-OFFSET-SET!", Prim_uint32_offset_set, 3, 3,
"(mem-addr byte-offset 32-bit-value)\n"
"Set 32 bit unsigned long at offset from memory")
{
PRIMITIVE_HEADER (3);
{
unsigned long *base;
int offset;
unsigned long value;
CHECK_ARG (1, STRING_P);
base = (unsigned long*) STRING_LOC (ARG_REF(1), 0);
offset = arg_integer (2);
value = scheme_object_to_windows_object (ARG_REF (3));
* (unsigned long*) (((char*)base)+offset) = value;
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
/* GUI utilities for debuggging .*/
#ifdef W32_TRAP_DEBUG
extern HANDLE ghInstance;
extern int TellUser (char *, ...);
extern int TellUserEx (int, char *, ...);
extern char * AskUser (char *, int);
int
TellUser (char * format, ...)
{
va_list arg_ptr;
char buffer[1024];
va_start (arg_ptr, format);
wvsprintf (&buffer[0], format, arg_ptr);
va_end (arg_ptr);
return (MessageBox (master_tty_window,
((LPCSTR) &buffer[0]),
((LPCSTR) "MIT Scheme Win32 Notification"),
(MB_TASKMODAL | MB_ICONINFORMATION
| MB_SETFOREGROUND | MB_OK)));
}
int
TellUserEx (int flags, char * format, ...)
{
va_list arg_ptr;
char buffer[1024];
va_start (arg_ptr, format);
wvsprintf (&buffer[0], format, arg_ptr);
va_end (arg_ptr);
return (MessageBox (master_tty_window,
((LPCSTR) &buffer[0]),
((LPCSTR) "MIT Scheme Win32 Notification"),
(MB_TASKMODAL | MB_ICONINFORMATION
| MB_SETFOREGROUND | flags)));
}
static char * askuserbuffer = ((char *) NULL);
static int askuserbufferlength = 0;
static BOOL APIENTRY
DEFUN (askuserdlgproc, (hwnddlg, message, wparam, lparam),
HWND hwnddlg AND UINT message
AND WPARAM wparam AND LPARAM lparam)
{
switch (message)
{
case WM_CLOSE:
done:
GetDlgItemText (hwnddlg, SCHEME_INPUT_TEXT,
askuserbuffer,
askuserbufferlength);
EndDialog (hwnddlg, 0);
return (TRUE);
case WM_COMMAND:
switch (wparam)
{
case IDOK:
goto done;
case IDCANCEL:
EndDialog (hwnddlg, -1);
return (TRUE);
default:
return (FALSE);
}
case WM_INITDIALOG:
return (TRUE);
default:
return (FALSE);
}
}
char *
DEFUN (AskUser, (buf, len), char * buf AND int len)
{
char * result;
askuserbuffer = buf;
askuserbufferlength = len;
result = (DialogBox (ghInstance,
SCHEME_INPUT,
master_tty_window,
askuserdlgproc));
if (result == -1)
return ((char *) NULL);
askuserbuffer = ((char *) NULL);
askuserbufferlength = 0;
return (buf);
}
#endif /* W32_TRAP_DEBUG */
/* Events */
/* Worst case consing for longs.
This should really be available elsewhere. */
#define LONG_TO_INTEGER_WORDS (4)
#define MAX_EVENT_STORAGE ((9 * (LONG_TO_INTEGER_WORDS + 1)) + 1)
DEFINE_PRIMITIVE ("WIN32-READ-EVENT", Prim_win32_read_event, 0, 0,
"()\n\
Returns the next event from the event queue.\n\
The event is deleted from the queue.\n\
Returns #f if there are no events in the queue.")
{
PRIMITIVE_HEADER (0);
/* Ensure that the primitive is not restarted due to GC: */
Primitive_GC_If_Needed (MAX_EVENT_STORAGE);
{
SCREEN_EVENT event;
SCHEME_OBJECT sevent;
while (1)
{
if (!Screen_read_event (&event))
PRIMITIVE_RETURN (SHARP_F);
sevent = (parse_event (&event));
if (sevent != SHARP_F)
PRIMITIVE_RETURN (sevent);
}
}
}
#define INIT_RESULT(n) \
{ \
result = (allocate_marked_vector (TC_VECTOR, ((n) + 2), 1)); \
WRITE_UNSIGNED (event -> type); \
WRITE_UNSIGNED ((unsigned long) (event -> handle)); \
}
#define WRITE_RESULT(object) VECTOR_SET (result, (index++), (object))
#define WRITE_UNSIGNED(n) WRITE_RESULT (ulong_to_integer (n))
#define WRITE_SIGNED(n) WRITE_RESULT (long_to_integer (n))
#define WRITE_FLAG(n) WRITE_RESULT (((n) == 0) ? SHARP_F : SHARP_T)
static SCHEME_OBJECT
parse_event (SCREEN_EVENT * event)
{
unsigned int index = 0;
SCHEME_OBJECT result;
switch (event -> type)
{
case SCREEN_EVENT_TYPE_RESIZE:
INIT_RESULT (2);
WRITE_UNSIGNED (event->event.resize.rows);
WRITE_UNSIGNED (event->event.resize.columns);
break;
case SCREEN_EVENT_TYPE_KEY:
INIT_RESULT (6);
WRITE_UNSIGNED (event->event.key.repeat_count);
WRITE_SIGNED (event->event.key.virtual_keycode);
WRITE_UNSIGNED (event->event.key.virtual_scancode);
WRITE_UNSIGNED (event->event.key.control_key_state);
WRITE_SIGNED (event->event.key.ch);
WRITE_FLAG (event->event.key.key_down);
break;
case SCREEN_EVENT_TYPE_MOUSE:
INIT_RESULT (7);
WRITE_UNSIGNED (event->event.mouse.row);
WRITE_UNSIGNED (event->event.mouse.column);
WRITE_UNSIGNED (event->event.mouse.control_key_state);
WRITE_UNSIGNED (event->event.mouse.button_state);
WRITE_FLAG (event->event.mouse.up);
WRITE_FLAG (event->event.mouse.mouse_moved);
WRITE_FLAG (event->event.mouse.double_click);
break;
case SCREEN_EVENT_TYPE_CLOSE:
INIT_RESULT (0);
break;
case SCREEN_EVENT_TYPE_FOCUS:
INIT_RESULT (1);
WRITE_FLAG (event->event.focus.gained_p);
break;
case SCREEN_EVENT_TYPE_VISIBILITY:
INIT_RESULT (1);
WRITE_FLAG (event->event.visibility.show_p);
break;
default:
result = SHARP_F;
break;
}
return (result);
}
/* Primitives for Edwin Screens */
#define GETSCREEN(x) ((SCREEN) (GetWindowLong (x, 0)))
DEFINE_PRIMITIVE ("WIN32-SCREEN-CLEAR-RECTANGLE!", Prim_win32_screen_clear_rectangle, 6, 6,
"(hwnd xl xh yl yh attribute)")
{
PRIMITIVE_HEADER (6);
{
HWND hwnd = (HWND) arg_integer (1);
SCREEN screen = GETSCREEN ((HWND) hwnd);
Screen_SetAttributeDirect (screen, (SCREEN_ATTRIBUTE) arg_integer (6));
clear_screen_rectangle (screen,
arg_integer(4), arg_integer(2),
arg_integer(5), arg_integer(3));
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-INVALIDATE-RECT!", Prim_win32_screen_invalidate_rect, 5, 5, 0)
{
PRIMITIVE_HEADER (5);
{
RECT rect;
HWND handle = (HWND) arg_integer (1);
SCREEN screen = GETSCREEN (handle);
Screen_CR_to_RECT (&rect, screen, arg_integer (4), arg_integer (2),
arg_integer (5), arg_integer (3));
InvalidateRect (handle, &rect, FALSE);
PRIMITIVE_RETURN(UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-VERTICAL-SCROLL!", Prim_win32_screen_vertical_scroll, 6, 6,
"(handle xl xu yl yu amount)")
{
PRIMITIVE_HEADER (6);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
int position = arg_integer (6);
scroll_screen_vertically (screen, arg_integer (4), arg_integer (2),
arg_integer (5), arg_integer (3), position);
PRIMITIVE_RETURN(UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-WRITE-CHAR!", Prim_win32_screen_write_char, 5, 5,
"(handle x y char attribute)")
{
PRIMITIVE_HEADER (5);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
if (!screen)
error_bad_range_arg (1);
Screen_SetAttributeDirect (screen, (SCREEN_ATTRIBUTE) arg_integer (5));
Screen_SetPosition (screen, arg_integer (3), arg_integer (2));
Screen_WriteCharUninterpreted (screen, (char) arg_integer (4), 0);
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-WRITE-SUBSTRING!", Prim_win32_screen_write_substring, 7, 7,
"(handle x y string start end attribute)")
{
PRIMITIVE_HEADER (7);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
int start = arg_nonnegative_integer (5);
int end = arg_nonnegative_integer (6);
if (!screen)
error_bad_range_arg (1);
CHECK_ARG (4, STRING_P);
if (start > STRING_LENGTH (ARG_REF (4)))
error_bad_range_arg (5);
if (end > STRING_LENGTH (ARG_REF (4)))
error_bad_range_arg (6);
Screen_SetAttributeDirect (screen, (SCREEN_ATTRIBUTE) arg_integer (7));
WriteScreenBlock_NoInvalidRect (screen,
arg_integer (3), arg_integer (2),
((LPSTR) STRING_ARG (4))+start,
end-start);
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-MOVE-CURSOR!", Prim_win32_screen_move_cursor, 3, 3,
"(handle x y)")
{
PRIMITIVE_HEADER (3);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
Screen_SetPosition (screen, arg_integer (3), arg_integer (2));
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-CHAR-DIMENSIONS", Prim_win32_screen_char_dimensions, 1, 1,
"(handle)\n\
Returns pair (width . height).")
{
PRIMITIVE_HEADER (1);
{
HWND handle = ((HWND) (arg_integer (1)));
int xchar;
int ychar;
screen_char_dimensions (handle, (&xchar), (&ychar));
PRIMITIVE_RETURN
(cons ((long_to_integer (xchar)), (long_to_integer (ychar))));
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-SIZE", Prim_win32_screen_size, 1, 1,
"(handle)\n\
Returns pair (width . height).")
{
PRIMITIVE_HEADER (1);
{
HWND handle = (HWND) arg_integer (1);
int width=0, height=0;
Screen_GetSize (handle, &height, &width);
PRIMITIVE_RETURN
(cons (long_to_integer (width), long_to_integer (height)));
}
}
DEFINE_PRIMITIVE ("WIN32-SET-SCREEN-SIZE", Prim_win32_set_screen_size, 3, 3,
"(handle width height)")
{
PRIMITIVE_HEADER (3);
{
HWND handle = ((HWND) (arg_integer (1)));
int xchar;
int ychar;
screen_char_dimensions (handle, (&xchar), (&ychar));
PRIMITIVE_RETURN
(cons ((long_to_integer (xchar)), (long_to_integer (ychar))));
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-CREATE!", Prim_win32_screen_create, 2, 2,
"(parent-handle modes)")
{
PRIMITIVE_HEADER (2);
{
HWND hwnd = Screen_Create ((HANDLE) arg_integer (1),
"Scheme Screen",
(int) SW_SHOWNA);
if (hwnd != 0)
SendMessage (hwnd, SCREEN_SETMODES,
(WPARAM) arg_integer (2), (LPARAM) 0);
PRIMITIVE_RETURN (hwnd ? long_to_integer ((long) hwnd) : SHARP_F);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-SHOW-CURSOR!", Prim_win32_screen_show_cursor, 2, 2,
"(handle show?)")
{
PRIMITIVE_HEADER (2);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
Enable_Cursor (screen, (ARG_REF (2) == SHARP_F) ? FALSE : TRUE);
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-ICON!", Prim_win32_screen_set_icon, 2, 2,
"(screen-handle icon-handle)")
{
PRIMITIVE_HEADER (2);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
HICON result = ScreenSetIcon (screen, (HICON) arg_integer (2));
PRIMITIVE_RETURN (ulong_to_integer((unsigned long) result));
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-CURRENT-FOCUS", Prim_win32_screen_current_focus, 0, 0,
"() -> hwnd")
{
PRIMITIVE_HEADER (0);
{
PRIMITIVE_RETURN (ulong_to_integer((unsigned long) ScreenCurrentFocus()));
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-DEFAULT-FONT!", Prim_win32_screen_set_default_font, 1, 1,
"(font-name)")
{
PRIMITIVE_HEADER (1);
{
BOOL rc = ScreenSetDefaultFont (STRING_ARG (1));
PRIMITIVE_RETURN ( rc ? SHARP_T : SHARP_F);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-FONT!", Prim_win32_screen_set_font, 2, 2,
"(screen-handle font-name)")
{
PRIMITIVE_HEADER (2);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
if (!screen) error_bad_range_arg (1);
PRIMITIVE_RETURN ( ScreenSetFont (screen, STRING_ARG (2))
? SHARP_T : SHARP_F);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-FOREGROUND-COLOR!", Prim_win32_screen_set_foreground_color, 2, 2,
"(screen-handle rgb)")
{
PRIMITIVE_HEADER (2);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
if (!screen) error_bad_range_arg (1);
PRIMITIVE_RETURN ( ScreenSetForegroundColour (screen, arg_integer (2))
? SHARP_T : SHARP_F);
}
}
DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-BACKGROUND-COLOR!", Prim_win32_screen_set_background_color, 2, 2,
"(screen-handle rgb)")
{
PRIMITIVE_HEADER (2);
{
SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
if (!screen) error_bad_range_arg (1);
PRIMITIVE_RETURN ( ScreenSetBackgroundColour (screen, arg_integer (2))
? SHARP_T : SHARP_F);
}
}
syntax highlighted by Code2HTML, v. 0.9.1