/* -*-C-*-
-$Id: ntsig.c,v 1.6 1993/07/27 21:00:54 gjr Exp $
+$Id: ntsig.c,v 1.7 1993/08/21 03:45:54 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
#include "scheme.h"
#include "nt.h"
#include <signal.h>
-/*#include <int.h> SRA*/
#include "ossig.h"
#include "osctty.h"
#include "ostty.h"
#include "critsec.h"
-/*#include <bios.h> SRA*/
#include "ntsys.h"
#include "ntio.h"
-#include "ntexcp.h"
-#include "ntkbd.h"
-#ifdef USE_ZORTECH_CERROR
-#include <cerror.h>
-#endif
#include "extern.h"
#include "ntutil.h"
#include "ntscreen.h"
#include "ntscmlib.h"
-
-#ifndef fileno
-#define fileno(fp) ((fp)->_file)
-#endif
-
-cc_t EXFUN (DOS_interactive_interrupt_handler, (void));
\f
-/* Signal Manipulation */
-
-#ifdef UNUSED
-
-static Tsignal_handler
-DEFUN (current_handler, (signo), int signo)
-{
- Tsignal_handler result = (DOS_signal (signo, SIG_IGN));
- if (result != SIG_IGN)
- DOS_signal (signo, result);
- return (result);
-}
-#endif /* UNUSED */
-
-#define INSTALL_HANDLER DOS_signal
-#define NEED_HANDLER_TRANSACTION
-
-#define ENTER_HANDLER(signo)
-#define ABORT_HANDLER DOS_signal
-#define EXIT_HANDLER DOS_signal
+/* Signal mask manipulation */
-
-/* These could be implemented, at least under DPMI by examining
- and setting the virtual interrupt state.
+/* These could be implemented, at least under Win32s/DPMI
+ by examining and setting the virtual interrupt state.
*/
void
return;
}
\f
-#ifdef UNUSED
-/* Signal Descriptors */
-
-enum dfl_action { dfl_terminate, dfl_ignore, dfl_stop };
-
-struct signal_descriptor
-{
- int signo;
- CONST char * name;
- enum dfl_action action;
- int flags;
-};
-
-/* `flags' bits */
-#define NOIGNORE 1
-#define NOBLOCK 2
-#define NOCATCH 4
-#define CORE_DUMP 8
-
-static struct signal_descriptor * signal_descriptors;
-static unsigned int signal_descriptors_length;
-static unsigned int signal_descriptors_limit;
-
-static void
-DEFUN (defsignal, (signo, name, action, flags),
- int signo AND
- CONST char * name AND
- enum dfl_action action AND
- int flags)
-{
- if (signo == 0)
- return;
- if (signal_descriptors_length == signal_descriptors_limit)
- {
- signal_descriptors_limit += 8;
- signal_descriptors =
- (DOS_realloc (signal_descriptors,
- (signal_descriptors_limit *
- (sizeof (struct signal_descriptor)))));
- if (signal_descriptors == 0)
- {
- outf_fatal ("\nUnable to grow signal definitions table.\n");
- termination_init_error ();
- }
- }
- {
- struct signal_descriptor * sd =
- (signal_descriptors + (signal_descriptors_length++));
- (sd -> signo) = signo;
- (sd -> name) = name;
- (sd -> action) = action;
- (sd -> flags) = flags;
- }
-}
-
-static struct signal_descriptor *
-DEFUN (find_signal_descriptor, (signo), int signo)
-{
- struct signal_descriptor * scan = signal_descriptors;
- struct signal_descriptor * end = (scan + signal_descriptors_length);
- for (; (scan < end); scan += 1)
- if ((scan -> signo) == signo)
- return (scan);
- return (0);
-}
-
-CONST char *
-DEFUN (find_signal_name, (signo), int signo)
-{
- static char buffer [32];
- struct signal_descriptor * descriptor = (find_signal_descriptor (signo));
- if (descriptor != 0)
- return (descriptor -> name);
- sprintf (buffer, "unknown signal %d", signo);
- return ((CONST char *) buffer);
-}
-\f
-#define OS_SPECIFIC_SIGNALS()
-
-#if (SIGABRT == SIGIOT)
-#undef SIGABRT
-#define SIGABRT 0
-#endif
-
-static void
-DEFUN_VOID (initialize_signal_descriptors)
-{
- signal_descriptors_length = 0;
- signal_descriptors_limit = 32;
- signal_descriptors =
- (DOS_malloc (signal_descriptors_limit *
- (sizeof (struct signal_descriptor))));
- if (signal_descriptors == 0)
- {
- outf_error ("\nUnable to allocate signal definitions table.\n");
- termination_init_error ();
- }
-
- defsignal (SIGINT, "SIGINT", dfl_terminate, 0);
- defsignal (SIGILL, "SIGILL", dfl_terminate, CORE_DUMP);
- defsignal (SIGFPE, "SIGFPE", dfl_terminate, CORE_DUMP);
- defsignal (SIGSEGV, "SIGSEGV", dfl_terminate, CORE_DUMP);
- defsignal (SIGTERM, "SIGTERM", dfl_terminate, 0);
- defsignal (SIGABRT, "SIGABRT", dfl_terminate, CORE_DUMP);
-
- OS_SPECIFIC_SIGNALS ();
-}
-#endif
-\f
-/* Signal Handlers */
-
-struct handler_record
-{
- int signo;
- Tsignal_handler handler;
-};
-
-#define DEFUN_STD_HANDLER(name, statement) \
-static Tsignal_handler_result \
-DEFUN (name, (signo), int signo) \
-{ \
- int STD_HANDLER_abortp; \
- ENTER_HANDLER (signo); \
- STD_HANDLER_abortp = (enter_interruption_extent ()); \
- transaction_begin (); \
- { \
- struct handler_record * record = \
- (dstack_alloc (sizeof (struct handler_record))); \
- (record -> signo) = signo; \
- (record -> handler) = 0; \
- transaction_record_action (tat_abort, ta_abort_handler, record); \
- } \
- statement; \
- if (STD_HANDLER_abortp) \
- { \
- transaction_abort (); \
- exit_interruption_extent (); \
- } \
- transaction_commit (); \
- EXIT_HANDLER (signo, name); \
- SIGNAL_HANDLER_RETURN (); \
-}
-
-
-static void
-DEFUN (ta_abort_handler, (ap), PTR ap)
-{
- ABORT_HANDLER ((((struct handler_record *) ap) -> signo),
- (((struct handler_record *) ap) -> handler));
-}
-#ifdef UNUSED
-#endif /* UNUSED */
-\f
#define CONTROL_B_INTERRUPT_CHAR 'B'
#define CONTROL_G_INTERRUPT_CHAR 'G'
#define CONTROL_U_INTERRUPT_CHAR 'U'
#define TERMINATE_INTERRUPT_CHAR '@'
#define NO_INTERRUPT_CHAR '0'
-
static void
DEFUN (echo_keyboard_interrupt, (c, dc), cc_t c AND cc_t dc)
{
outf_console ("^?");
else
outf_console ("%c", c);
- outf_flush_console();
+ outf_flush_console ();
}
-DEFUN_STD_HANDLER (sighnd_control_g,
- {
- tty_set_next_interrupt_char (CONTROL_G_INTERRUPT_CHAR);
- })
-
-DEFUN_STD_HANDLER (sighnd_control_c,
- {
- cc_t int_char;
-
- int_char = (DOS_interactive_interrupt_handler ());
- if (int_char != ((cc_t) 0))
- tty_set_next_interrupt_char (int_char);
- })
-
-
/* Keyboard interrupt */
#define KB_INT_TABLE_SIZE ((256) + 1)
DEFUN (OS_ctty_set_interrupt_enables, (mask), Tinterrupt_enables * mask)
{
/* Kludge: ctl-break always enabled. */
- keyboard_interrupt_enables = (((unsigned char) (*mask))
+ keyboard_interrupt_enables = (((unsigned char) (* mask))
| TERMINATE_INTERRUPT_ENABLE);
return;
}
/* This is a temporary kludge. */
#define NUM_INT_CHANNELS 6
+
static cc_t int_chars[NUM_INT_CHANNELS];
static cc_t int_handlers[NUM_INT_CHANNELS];
#define SCREEN_COMMAND_INTERRUPT_FIRST (SCREEN_COMMAND_CLOSE+10)
-LRESULT master_tty_interrupt (HWND tty, WORD command)
+int EXFUN (signal_keyboard_character_interrupt, (int));
+
+LRESULT
+master_tty_interrupt (HWND tty, WORD command)
{
- int ch = int_chars[command - SCREEN_COMMAND_INTERRUPT_FIRST];
- return (signal_keyboard_character_interrupt (ch));
+ int ch = int_chars[command - SCREEN_COMMAND_INTERRUPT_FIRST];
+ return (signal_keyboard_character_interrupt (ch));
}
static void
extern HANDLE master_tty_window;
int i;
- for (i = 0; i < KB_INT_TABLE_SIZE; i++) {
+ for (i = 0; i < KB_INT_TABLE_SIZE; i++)
+ {
keyboard_interrupt_table[i] = NO_INTERRUPT_CHAR;
SendMessage (master_tty_window, SCREEN_SETBINDING, i, 0);
}
break;
}
keyboard_interrupt_table[(int) (int_chars[i])] = handler;
- SendMessage (master_tty_window, SCREEN_SETCOMMAND,
- SCREEN_COMMAND_INTERRUPT_FIRST+i,
+
+ SendMessage (master_tty_window,
+ SCREEN_SETCOMMAND,
+ (SCREEN_COMMAND_INTERRUPT_FIRST + i),
(LPARAM) master_tty_interrupt);
- SendMessage (master_tty_window, SCREEN_SETBINDING,
- int_chars[i], SCREEN_COMMAND_INTERRUPT_FIRST+i);
+
+ SendMessage (master_tty_window,
+ SCREEN_SETBINDING,
+ int_chars[i],
+ (SCREEN_COMMAND_INTERRUPT_FIRST + i));
}
return;
}
return;
}
-extern long EXFUN (text_write, (int, CONST unsigned char *, size_t));
-
static void
DEFUN (console_write_string, (string), unsigned char * string)
{
outf_console ("%s", string);
- outf_flush_console();
+ outf_flush_console ();
return;
}
-
-static void
-DEFUN (console_write_character, (c), unsigned char c)
-{
- outf_console ("%c", c);
- outf_flush_console();
- return;
-}
-
-static unsigned char
-DEFUN_VOID (console_read_character)
-{
- return userio_read_char();
-}
\f
-void
+static void
DEFUN_VOID (initialize_keyboard_interrupt_table)
{
/* Set up default interrupt characters */
"(exit) to exit Scheme\r\n"
);
-/*
- console_write_string ("\nInterrupt Choices are:\n");
- console_write_string ("C-G interrupt: G, g, ^G (abort to top level)\n");
- console_write_string ("C-X interrupt: X, x, ^x (abort)\n");
- console_write_string ("C-B interrupt: B, b, ^B (break)\n");
- console_write_string ("C-U interrupt: U, u, ^U (up)\n");
- console_write_string ("Ignore interrupt: I, i (dismiss)\n");
- console_write_string ("Reset scheme: R, r (hard reset)\n");
- console_write_string ("Quit scheme: Q, q (exit)\n");
- console_write_string ("Print help: ?");
-*/
return;
}
+extern void EXFUN (tty_set_next_interrupt_char, (cc_t));
+
#define REQUEST_INTERRUPT_IF_ENABLED(mask) do \
{ \
if (keyboard_interrupt_enables & (mask)) \
interrupt_p = 0; \
} while (0)
\f
-int EXFUN (signal_keyboard_character_interrupt, (int));
-
int
DEFUN (signal_keyboard_character_interrupt, (c), int c)
{
}
return (0);
}
+\f
else if ((c >= 0) && (c < KB_INT_TABLE_SIZE))
{
int interrupt_p, interrupt_char;
break;
}
interactive_interrupt:
- {
- cc_t int_char;
-
- /*int_char = (DOS_interactive_interrupt_handler ());*/
- print_interrupt_help();
- int_char = 0;
-
- if (int_char == ((cc_t) 0))
- hard_attn_counter = 0;
- else
- {
- tty_set_next_interrupt_char ((int) int_char);
- interrupt_p = 1;
- }
- }
+ print_interrupt_help ();
+ interrupt_p = 0;
break;
default:
}
return (0);
}
-\f
-cc_t
-DEFUN_VOID (DOS_interactive_interrupt_handler)
-{
- while (1)
- {
- unsigned char response;
-
- console_write_string
- ("\nKeyboard interrupt, type character (? for help): ");
-
- response = (console_read_character ());
- console_write_character (response);
-
- switch (response)
- {
- case 'b':
- case 'B':
- case CONTROL_B:
- return CONTROL_B_INTERRUPT_CHAR;
-
- case 'g':
- case 'G':
- case CONTROL_G:
- return CONTROL_G_INTERRUPT_CHAR;
-
- case 'i':
- case 'I':
- return ((cc_t) 0);
-
- case 'R':
- case 'r':
- {
- extern void EXFUN (soft_reset, (void));
- soft_reset ();
- /*NOTREACHED*/
- }
-
- case 'q':
- case 'Q':
- {
- console_write_string ("\nTerminate scheme (y or n)? ");
- response = (console_read_character ());
- console_write_character (response);
- if ((response == 'y') || (response == 'Y'))
- {
- console_write_string ("\n");
- termination_normal (0);
- }
- print_interrupt_help ();
- break;
- }
-\f
- case 'u':
- case 'U':
- case CONTROL_U:
- return CONTROL_U_INTERRUPT_CHAR;
-
- case 'x':
- case 'X':
- case CONTROL_X:
- return CONTROL_X_INTERRUPT_CHAR;
-
- case '?':
- print_interrupt_help ();
- break;
-
- default:
- {
- unsigned char temp[128];
-
- sprintf (temp, "\nIllegal interrupt character: [%c]", response);
- console_write_string (temp);
- print_interrupt_help ();
- break;
- }
- }
- }
-}
void
DEFUN_VOID (OS_restartable_exit)
static void * timer_state = ((void *) NULL);
+static char *
DEFUN_VOID (install_timer)
{
- switch (win32_install_async_timer (&Registers[REGBLOCK_INT_CODE],
- &Registers[REGBLOCK_INT_MASK],
- &Registers[REGBLOCK_MEMTOP],
+ switch (win32_install_async_timer (&Registers[0],
+ REGBLOCK_MEMTOP,
+ REGBLOCK_INT_CODE,
+ REGBLOCK_INT_MASK,
(INT_Global_1 | INT_Timer),
&timer_state))
{
case WIN32_ASYNC_TIMER_NOMEM:
return ("Not enough memory to install the timer interrupt handler");
+ case WIN32_ASYNC_TIMER_NOLDT:
+ return ("Not enough selectors to fix the timer interrupt handler");
+
default:
return ("Unknown asynchronous timer return code");
}
DEFUN (NT_initialize_fov, (fov), SCHEME_OBJECT fov)
{
int ctr, in;
- SCHEME_OBJECT iv, imv, prim, mask;
+ SCHEME_OBJECT iv, imv, prim;
extern SCHEME_OBJECT EXFUN (make_primitive, (char *));
static int interrupt_numbers[2] =
{
void
DEFUN_VOID (NT_initialize_signals)
{
- char * timer_error = (install_timer ());
+ char * timer_error;
+ initialize_keyboard_interrupt_table ();
+ timer_error = (install_timer ());
if (timer_error)
{
outf_fatal ("install_timer: %s", timer_error);
/* -*-C-*-
-$Id: nttrap.c,v 1.4 1993/07/27 21:27:06 gjr Exp $
+$Id: nttrap.c,v 1.5 1993/08/21 03:48:49 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. */
+#include <stdarg.h>
#include "scheme.h"
#include "os.h"
#include "nt.h"
#include "nttrap.h"
-#include "ntexcp.h"
-#include "ntinsn.h"
-#include "extern.h"
-
-extern void EXFUN (DOS_initialize_trap_recovery, (void));
-CONST char * EXFUN (find_trap_name, (int trapno));
-extern PTR initial_C_stack_pointer;
+#include "gccode.h"
+#include "ntscmlib.h"
+#include <windows.h>
+
+#ifdef W32_TRAP_DEBUG
+extern char * AskUser (char *, int);
+extern int EXFUN (TellUser, (char *, ...));
+extern int EXFUN (TellUserEx, (int, char *, ...));
+#endif /* W32_TRAP_DEBUG */
+
+extern void EXFUN (NT_initialize_traps, (void));
+extern void EXFUN (NT_restore_traps, (void));
+
+extern unsigned short
+ Scheme_Code_Segment_Selector,
+ Scheme_Data_Segment_Selector,
+ Scheme_Stack_Segment_Selector,
+ C_Code_Segment_Selector,
+ C_Data_Segment_Selector,
+ C_Extra_Segment_Selector,
+ C_Stack_Segment_Selector;
+
+extern DWORD
+ C_Stack_Pointer,
+ C_Frame_Pointer;
\f
-static enum trap_state trap_state;
-static enum trap_state user_trap_state;
+#ifdef W32_TRAP_DEBUG
-static enum trap_state saved_trap_state;
-static int saved_trapno;
-static SIGINFO_T saved_info;
-static struct FULL_SIGCONTEXT * saved_scp;
+static BOOL trap_verbose_p = FALSE;
-static unsigned short
- initial_C_ss = 0,
- initial_C_ds = 0,
- initial_C_cs = 0;
+#define IFVERBOSE(command) do \
+{ \
+ if (trap_verbose_p) \
+ { \
+ int result = command; \
+ if (result == IDCANCEL) \
+ trap_verbose_p = FALSE; \
+ } \
+} while (0)
-static void EXFUN (initialize_dos_trap_codes, (void));
-static void EXFUN
- (continue_from_trap,
- (int trapno, SIGINFO_T info, struct FULL_SIGCONTEXT * scp));
+#else /* not W32_TRAP_DEBUG */
-/*SRA
-void
-DEFUN_VOID (DOS_initialize_trap_recovery)
-{
- extern unsigned short getSS (void);
+#define IFVERBOSE(command) do { } while (0)
- initial_C_ss = (getSS ());
- initial_C_ds = (getDS ());
- initial_C_cs = (getCS ());
- trap_state = trap_state_recover;
- user_trap_state = trap_state_recover;
- initialize_dos_trap_codes ();
-} */
+#endif /* W32_TRAP_DEBUG */
-enum trap_state
-DEFUN (OS_set_trap_state, (state), enum trap_state state)
+static char * trap_output = ((char *) NULL);
+static char * trap_output_pointer = ((char *) NULL);
+
+static void
+DEFUN_VOID (trap_noise_start)
{
- enum trap_state old_trap_state = user_trap_state;
- user_trap_state = state;
- trap_state = state;
- return (old_trap_state);
+ trap_output = ((char *) NULL);
+ trap_output_pointer = ((char *) NULL);
+ return;
}
static void
-DEFUN_VOID (trap_normal_termination)
+DEFUN (trap_noise, (format), char * format DOTS)
{
- trap_state = trap_state_exitting_soft;
- termination_trap ();
+ va_list arg_ptr;
+ unsigned long size;
+ char * temp;
+
+ size = (trap_output_pointer - trap_output);
+ temp = ((trap_output == ((char *) NULL))
+ ? ((char *) (malloc (256)))
+ : ((char *) (realloc (trap_output, (256 + size)))));
+ if (temp == ((char *) NULL))
+ return;
+
+ trap_output = temp;
+ trap_output_pointer = (temp + size);
+ va_start (arg_ptr, format);
+ size = (wvsprintf (trap_output_pointer, format, arg_ptr));
+ trap_output_pointer += size;
+ va_end (arg_ptr);
+ return;
}
-static void
-DEFUN_VOID (trap_immediate_termination)
+static int
+DEFUN (trap_noise_end, (style), UINT style)
{
- trap_state = trap_state_exitting_hard;
- OS_restore_external_state ();
- exit (1);
+ int value;
+
+ if (trap_output == ((char *) NULL))
+ return (IDYES);
+
+ value = (MessageBox (NULL,
+ trap_output,
+ "MIT Scheme Exception Information",
+ style));
+ free (trap_output);
+ trap_output = ((char *) NULL);
+ trap_output_pointer = ((char *) NULL);
+ return (value);
}
-static void
-DEFUN_VOID (trap_recover)
+static BOOL
+DEFUN (isvowel, (c), char c)
{
- if (WITHIN_CRITICAL_SECTION_P ())
- {
- CLEAR_CRITICAL_SECTION_HOOK ();
- EXIT_CRITICAL_SECTION ({});
- }
- reset_interruptable_extent ();
- continue_from_trap (saved_trapno, saved_info, saved_scp);
+ switch (c)
+ {
+ case 'a':
+ case 'e':
+ case 'i':
+ case 'o':
+ case 'u':
+ case 'A':
+ case 'E':
+ case 'I':
+ case 'O':
+ case 'U':
+ return (TRUE);
+
+ default:
+ return (FALSE);
+ }
}
\f
-void
-DEFUN (trap_handler, (message, trapno, info, scp),
- CONST char * message AND
- int trapno AND
- SIGINFO_T info AND
- struct FULL_SIGCONTEXT * scp)
+struct exception_name_s
{
- int code = ((SIGINFO_VALID_P (info)) ? (SIGINFO_CODE (info)) : 0);
- Boolean constant_space_broken = (!(CONSTANT_SPACE_SEALED ()));
- enum trap_state old_trap_state = trap_state;
+ DWORD code;
+ char * name;
+};
- if (old_trap_state == trap_state_exitting_hard)
- {
- _exit (1);
- }
- else if (old_trap_state == trap_state_exitting_soft)
- {
- trap_immediate_termination ();
- }
- trap_state = trap_state_trapped;
- if (WITHIN_CRITICAL_SECTION_P ())
- {
- fprintf (stdout,
- "\n>> A %s has occurred within critical section \"%s\".\n",
- message, (CRITICAL_SECTION_NAME ()));
- fprintf (stdout, ">> [exception %d (%s), code %d = 0x%x]\n",
- trapno, (find_trap_name (trapno)), code, code);
- }
- else if (constant_space_broken || (old_trap_state != trap_state_recover))
- {
- fprintf (stdout, "\n>> A %s (%d) has occurred.\n", message, trapno);
- fprintf (stdout, ">> [exception %d (%s), code %d = 0x%x]\n",
- trapno, (find_trap_name (trapno)), code, code);
- }
- if (constant_space_broken)
- {
- fputs (">> Constant space has been overwritten.\n", stdout);
- fputs (">> Probably a runaway recursion has overflowed the stack.\n",
- stdout);
- }
- fflush (stdout);
+static struct exception_name_s exception_names[] =
+{
+ {
+ EXCEPTION_ACCESS_VIOLATION,
+ "ACCESS_VIOLATION",
+ },
+ {
+ EXCEPTION_DATATYPE_MISALIGNMENT,
+ "DATATYPE_MISALIGNMENT",
+ },
+ {
+ EXCEPTION_BREAKPOINT,
+ "BREAKPOINT",
+ },
+ {
+ EXCEPTION_SINGLE_STEP,
+ "SINGLE_STEP",
+ },
+ {
+ EXCEPTION_ARRAY_BOUNDS_EXCEEDED,
+ "ARRAY_BOUNDS_EXCEEDED",
+ },
+ {
+ EXCEPTION_FLT_DENORMAL_OPERAND,
+ "FLT_DENORMAL_OPERAND",
+ },
+ {
+ EXCEPTION_FLT_DIVIDE_BY_ZERO,
+ "FLT_DIVIDE_BY_ZERO",
+ },
+ {
+ EXCEPTION_FLT_INEXACT_RESULT,
+ "FLT_INEXACT_RESULT",
+ },
+ {
+ EXCEPTION_FLT_INVALID_OPERATION,
+ "FLT_INVALID_OPERATION",
+ },
+ {
+ EXCEPTION_FLT_OVERFLOW,
+ "FLT_OVERFLOW",
+ },
+ {
+ EXCEPTION_FLT_STACK_CHECK,
+ "FLT_STACK_CHECK",
+ },
+ {
+ EXCEPTION_FLT_UNDERFLOW,
+ "FLT_UNDERFLOW",
+ },
+ {
+ EXCEPTION_INT_DIVIDE_BY_ZERO,
+ "INT_DIVIDE_BY_ZERO",
+ },
+ {
+ EXCEPTION_INT_OVERFLOW,
+ "INT_OVERFLOW",
+ },
+\f
+ {
+ EXCEPTION_PRIV_INSTRUCTION,
+ "PRIV_INSTRUCTION",
+ },
+ {
+ EXCEPTION_IN_PAGE_ERROR,
+ "IN_PAGE_ERROR",
+ },
+ {
+ EXCEPTION_ILLEGAL_INSTRUCTION,
+ "ILLEGAL_INSTRUCTION",
+ },
+ {
+ EXCEPTION_NONCONTINUABLE_EXCEPTION,
+ "NONCONTINUABLE_EXCEPTION",
+ },
+ {
+ EXCEPTION_STACK_OVERFLOW,
+ "STACK_OVERFLOW",
+ },
+ {
+ EXCEPTION_INVALID_DISPOSITION,
+ "INVALID_DISPOSITION",
+ },
+};
- switch (old_trap_state)
- {
- case trap_state_trapped:
- if ((saved_trap_state == trap_state_recover) ||
- (saved_trap_state == trap_state_query))
- {
- fputs (">> The trap occurred while processing an earlier trap.\n",
- stdout);
- fprintf (stdout,
- ">> [The earlier trap raised exception %d (%s), code %d.]\n",
- saved_trapno,
- (find_trap_name (saved_trapno)),
- ((SIGINFO_VALID_P (saved_info))
- ? (SIGINFO_CODE (saved_info))
- : 0));
- fputs (((WITHIN_CRITICAL_SECTION_P ())
- ? ">> Successful recovery is extremely unlikely.\n"
- : ">> Successful recovery is unlikely.\n"),
- stdout);
- break;
- }
- else
- trap_immediate_termination ();
- case trap_state_recover:
- if ((WITHIN_CRITICAL_SECTION_P ()) || constant_space_broken)
- {
- fputs (">> Successful recovery is unlikely.\n", stdout);
- break;
- }
- else
- {
- saved_trap_state = old_trap_state;
- saved_trapno = trapno;
- saved_info = info;
- saved_scp = scp;
- trap_recover ();
- }
- case trap_state_exit:
- termination_trap ();
- }
+const int excp_name_limit = ((sizeof (exception_names))
+ / (sizeof (struct exception_name_s)));
- fflush (stdout);
- saved_trap_state = old_trap_state;
- saved_trapno = trapno;
- saved_info = info;
- saved_scp = scp;
+static char *
+find_exception_name (DWORD code)
+{
+ int i;
- while (1)
- {
- char option;
- static CONST char * trap_query_choices[] =
- {
- "I = terminate immediately",
- "N = terminate normally",
- "R = attempt recovery",
- "Q = terminate normally",
- 0
- };
- option = (userio_choose_option
- ("Choose one of the following actions:",
- "Action -> ",
- trap_query_choices));
- switch (option)
- {
- case 'I':
- trap_immediate_termination ();
- case '\0':
- /* Error in IO. Assume everything scrod. */
- case 'N':
- case 'Q':
- trap_normal_termination ();
- case 'R':
- trap_recover ();
- }
- }
+ for (i = 0; i < excp_name_limit; i++)
+ if (exception_names[i].code == code)
+ return (exception_names[i].name);
+ return ((char *) NULL);
+}
+
+static void
+DEFUN (describe_trap, (noise, code),
+ char * noise AND DWORD code)
+{
+ char * name;
+
+ name = (find_exception_name (code));
+ if (name == ((char *) NULL))
+ trap_noise (">> The %s an unknown trap [code = %d].\n",
+ noise, code);
+ else
+ trap_noise (">> The %s a%s %s trap.\n",
+ noise,
+ ((isvowel (name[0])) ? "n" : ""),
+ name);
+ return;
}
\f
#define STATE_UNKNOWN (LONG_TO_UNSIGNED_FIXNUM (0))
SHARP_F
};
-struct dos_trap_code_desc
+struct nt_trap_code_desc
{
int trapno;
unsigned long code_mask;
unsigned long code_value;
char *name;
};
+\f
+static enum trap_state trap_state;
+static enum trap_state user_trap_state;
-static struct dos_trap_code_desc dos_trap_codes [64];
+static enum trap_state saved_trap_state;
+static DWORD saved_trap_code;
-#define DECLARE_DOS_TRAP_CODE(s, m, v, n) \
-{ \
- ((dos_trap_codes [i]) . trapno) = (s); \
- ((dos_trap_codes [i]) . code_mask) = (m); \
- ((dos_trap_codes [i]) . code_value) = (v); \
- ((dos_trap_codes [i]) . name) = (n); \
- i += 1; \
+enum trap_state
+DEFUN (OS_set_trap_state, (state), enum trap_state state)
+{
+ enum trap_state old_trap_state = user_trap_state;
+
+ user_trap_state = state;
+ trap_state = state;
+ return (old_trap_state);
}
-static SCHEME_OBJECT
-DEFUN (find_trap_code_name, (trapno, info, scp),
- int trapno AND
- SIGINFO_T info AND
- struct FULL_SIGCONTEXT * scp)
+static void
+DEFUN_VOID (trap_normal_termination)
{
- unsigned long code = 0;
- char * name = 0;
- if (SIGINFO_VALID_P (info))
- {
- code = (SIGINFO_CODE (info));
- {
- struct dos_trap_code_desc * entry = (& (dos_trap_codes [0]));
- while ((entry -> trapno) != DOS_INVALID_TRAP)
- if (((entry -> trapno) == trapno)
- && (((entry -> code_mask) & code) == (entry -> code_value)))
- {
- name = (entry -> name);
- break;
- }
- else
- entry += 1;
- }
- }
- return (cons ((long_to_integer ((long) code)),
- ((name == 0) ? SHARP_F
- : (char_pointer_to_string ((unsigned char *) name)))));
+ trap_state = trap_state_exitting_soft;
+ termination_trap ();
}
-\f
+
static void
-DEFUN_VOID (initialize_dos_trap_codes)
+DEFUN_VOID (trap_immediate_termination)
{
- unsigned int i = 0;
-
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Integer_divide_by_zero,
- 0, 0,
- "Integer divide by zero");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Debug_exception,
- 0, 0,
- "Debug exception");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Non_maskable_interrupt,
- 0, 0,
- "Non-maskable interrupt");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Breakpoint,
- 0, 0,
- "Breakpoint");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Integer_overflow,
- 0, 0,
- "Integer overflow");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Bounds_check,
- 0, 0,
- "Bounds check");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Invalid_opcode,
- 0, 0,
- "Invalid opcode");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Numeric_co_processor_not_available,
- 0, 0,
- "Numeric co-processor not available");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Double_fault,
- 0, 0,
- "Double fault");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Numeric_co_processor_segment_overrun,
- 0, 0,
- "Numeric co-processor segment overrun");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Invalid_TSS,
- 0, 0,
- "Invalid TSS");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Segment_not_present,
- 0, 0,
- "Segment not present");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Stack_exception,
- 0, 0,
- "Stack exception");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_General_protection,
- 0, 0,
- "General protection");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Page_Fault,
- 0, 0,
- "Page Fault");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Floating_point_exception,
- 0, 0,
- "Floating-point exception");
- DECLARE_DOS_TRAP_CODE (DOS_EXCP_Alignment_check,
- 0, 0,
- "Alignment check");
- DECLARE_DOS_TRAP_CODE (DOS_INVALID_TRAP, 0, 0, ((char *) 0));
+ extern void EXFUN (OS_restore_external_state, (void));
+
+ trap_state = trap_state_exitting_hard;
+ OS_restore_external_state ();
+ exit (1);
+}
+
+void
+DEFUN_VOID (NT_initialize_traps)
+{
+ trap_state = trap_state_recover;
+ user_trap_state = trap_state_recover;
return;
}
-static CONST char *
-trap_names[NUM_DOS_EXCP] =
+void
+DEFUN_VOID (NT_restore_traps)
{
- "Integer divide by zero",
- "Debugging trap",
- "NMI interrupt",
- "Breakpoint exception",
- "INTO -- integer overflow",
- "BOUND -- range exceeded",
- "UD -- invalid opcode",
- "NM -- 387 not available",
- "DF -- double fault",
- "387 segment overrun",
- "TS -- invalid TSS",
- "NP -- segment not present",
- "SS -- stack fault",
- "GP -- general protection",
- "PF -- page fault",
- ((CONST char *) NULL),
- "MF -- floating-point error",
- "AC -- alignment check"
-};
+ return;
+}
+\f
+static int
+DEFUN (display_exception_information, (info, context, flags),
+ PEXCEPTION_RECORD info AND PCONTEXT context AND int flags)
+{
+ int value;
+ char msgbuf[4096];
+ char * flag, * name, * bufptr;
+
+ bufptr = &msgbuf[0];
+ name = (find_exception_name (info->ExceptionCode));
+ flag = ((info->ExceptionFlags == 0) ? "Continuable" : "Non-continuable");
+ if (name == ((char *) NULL))
+ bufptr += (sprintf (bufptr, "%s Unknown Exception %d Raised at address 0x%lx",
+ flag, info->ExceptionCode, info->ExceptionAddress));
+ else
+ bufptr += (sprintf (bufptr, "%s %s Exception Raised at address 0x%lx",
+ flag, name, info->ExceptionAddress));
+
+#ifdef W32_TRAP_DEBUG
+ if (context == ((PCONTEXT) NULL))
+ bufptr += (sprintf (bufptr, "\nContext is NULL."));
+ else
+ {
+ if ((context->ContextFlags & CONTEXT_CONTROL) != 0)
+ bufptr += (sprintf (bufptr,
+ "\nContext contains CONTROL information."));
+ if ((context->ContextFlags & CONTEXT_INTEGER) != 0)
+ bufptr += (sprintf (bufptr,
+ "\nContext contains INTEGER registers."));
+ if ((context->ContextFlags & CONTEXT_SEGMENTS) != 0)
+ bufptr += (sprintf (bufptr,
+ "\nContext contains SEGMENT registers."));
+ if ((context->ContextFlags & CONTEXT_FLOATING_POINT) != 0)
+ bufptr += (sprintf (bufptr,
+ "\nContext contains floating-point registers."));
+ bufptr += (sprintf (bufptr, "\ncontext->Eip = 0x%lx.", context->Eip));
+ bufptr += (sprintf (bufptr, "\ncontext->Esp = 0x%lx.", context->Esp));
+ bufptr += (sprintf (bufptr, "\nStack_Pointer = 0x%lx.", Stack_Pointer));
+ bufptr += (sprintf (bufptr, "\nwinnt_address_delta = 0x%lx.", winnt_address_delta));
+ bufptr += (sprintf (bufptr, "\nadj (Stack_Pointer) = 0x%lx.",
+ (ADDR_TO_SCHEME_ADDR (Stack_Pointer))));
+ bufptr += (sprintf (bufptr, "\nCS = 0x%04x;\tC CS = 0x%04x;\tS CS = 0x%04x.",
+ context->SegCs,
+ C_Code_Segment_Selector,
+ Scheme_Code_Segment_Selector));
+
+ bufptr += (sprintf (bufptr, "\nDS = 0x%04x;\tC DS = 0x%04x;\tS DS = 0x%04x.",
+ context->SegDs,
+ C_Data_Segment_Selector,
+ Scheme_Data_Segment_Selector));
+
+ bufptr += (sprintf (bufptr, "\nES = 0x%04x;\tC ES = 0x%04x;\tS ES = 0x%04x.",
+ context->SegEs,
+ C_Extra_Segment_Selector,
+ C_Data_Segment_Selector));
+
+ bufptr += (sprintf (bufptr, "\nSS = 0x%04x;\tC SS = 0x%04x;\tS SS = 0x%04x.",
+ context->SegSs,
+ C_Stack_Segment_Selector,
+ Scheme_Stack_Segment_Selector));
+ }
+#endif /* W32_TRAP_DEBUG */
+
+ info = info->ExceptionRecord;
+ if (info != ((PEXCEPTION_RECORD) NULL))
+ bufptr += (sprintf (bufptr,
+ "\nTrap occurred within an earlier trap."));
+
+#ifdef W32_TRAP_DEBUG
+ if (flags == MB_YESNO)
+ bufptr += (sprintf (bufptr, "\n\nDisplay More Information?"));
+#else /* not W32_TRAP_DEBUG */
+ flags = MB_OK;
+ bufptr +=
+ (sprintf (bufptr,
+ "\n\nScheme cannot find the state necessary to continue."));
+#endif /* W32_TRAP_DEBUG */
+
+ value = (MessageBox (NULL, &msgbuf[0],
+ "MIT Scheme Exception Info",
+ (flags | MB_ICONSTOP)));
+ return (value);
+}
+\f
+#define TEMP_STACK_LEN 2048 /* objects */
+
+static BOOL
+ return_by_aborting,
+ clear_real_stack;
-CONST char *
-DEFUN (find_trap_name, (trapno), int trapno)
+static SCHEME_OBJECT
+ temp_stack_buffer[TEMP_STACK_LEN],
+ * temp_stack = &temp_stack_buffer[0],
+ * temp_stack_end = &temp_stack_buffer[TEMP_STACK_LEN],
+ * temp_stack_limit,
+ * real_stack_guard,
+ * real_stack_pointer;
+
+extern int EXFUN (WinntExceptionTransferHook, (void));
+extern void EXFUN (callWinntExceptionTransferHook, (void));
+
+int
+DEFUN_VOID (WinntExceptionTransferHook)
{
- static char buffer [64], * name;
- if ((trapno >= 0) &&
- (trapno < ((sizeof (trap_names)) / (sizeof (char *)))))
+ /* These must be static because the memcpy below may
+ be overwriting this procedure's locals!
+ */
+
+ static int size;
+ static SCHEME_OBJECT * temp_stack_ptr, * new_sp;
+
+ temp_stack_ptr = Stack_Pointer;
+ size = (temp_stack_limit - temp_stack_ptr);
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "WinntExceptionTransferHook."));
+
+ if (clear_real_stack)
+ Initialize_Stack ();
+ else
{
- name = trap_names[trapno];
- if ((name != ((char *) NULL))
- && (name[0] != '\0'))
- return ((CONST char *) name);
+ Stack_Pointer = real_stack_pointer;
+ Stack_Guard = real_stack_guard;
}
- sprintf (buffer, "unknown exception %d", trapno);
- return ((CONST char *) buffer);
+
+ new_sp = (real_stack_pointer - size);
+ if (new_sp != temp_stack_ptr)
+ memcpy (new_sp, temp_stack_ptr, (size * (sizeof (SCHEME_OBJECT))));
+ Stack_Pointer = new_sp;
+ SET_INTERRUPT_MASK ((FETCH_INTERRUPT_MASK ()));
+ if (return_by_aborting)
+ abort_to_interpreter (PRIM_APPLY);
+ return (PRIM_APPLY);
}
+
+extern unsigned short EXFUN (getCS, (void));
+extern unsigned short EXFUN (getDS, (void));
+extern unsigned short EXFUN (getSS, (void));
\f
+/* Needed because Stack_Check checks for <= instead of < when pushing */
+
+#define MAGIC_BUFFER_SIZE 1
+
static void
-DEFUN (setup_trap_frame, (trapno, info, scp, trinfo, new_stack_pointer),
- int trapno AND
- SIGINFO_T info AND
- struct FULL_SIGCONTEXT * scp AND
- struct trap_recovery_info * trinfo AND
- SCHEME_OBJECT * new_stack_pointer)
+DEFUN (setup_trap_frame, (code, context, trinfo, new_stack_pointer),
+ DWORD code
+ AND PCONTEXT context
+ AND struct trap_recovery_info * trinfo
+ AND SCHEME_OBJECT * new_stack_pointer)
{
- SCHEME_OBJECT handler;
SCHEME_OBJECT trap_name, trap_code;
+ SCHEME_OBJECT handler;
int stack_recovered_p = (new_stack_pointer != 0);
long saved_mask = (FETCH_INTERRUPT_MASK ());
SET_INTERRUPT_MASK (0); /* To prevent GC for now. */
- if ((! (Valid_Fixed_Obj_Vector ())) ||
- ((handler = (Get_Fixed_Obj_Slot (Trap_Handler))) == SHARP_F))
+
+ IFVERBOSE (TellUserEx (MB_OKCANCEL,
+ "setup_trap_frame (%s, 0x%lx, %s, 0x%lx, 0x%lx).",
+ (find_exception_name (code)),
+ context,
+ trinfo,
+ new_stack_pointer));
+
+ if ((! (Valid_Fixed_Obj_Vector ()))
+ || ((handler = (Get_Fixed_Obj_Slot (Trap_Handler))) == SHARP_F))
{
- outf_fatal ("There is no trap handler for recovery!\n");
- outf_fatal ("Trap = %s.\n", (find_trap_name (trapno)));
- outf_fatal ("pc = %04x:%08lx; sp = %04x:%08lx.\n",
- scp->sc_cs, scp->sc_eip, scp->sc_ss, scp->sc_esp);
+ trap_noise_start ();
+ trap_noise ("There is no trap handler for recovery!\n");
+ describe_trap ("trap is", code);
+ (void) trap_noise_end (MB_OK | MB_ICONSTOP);
termination_trap ();
}
if (Free > MemTop)
Request_GC (0);
- trap_name =
- ((trapno <= 0)
- ? SHARP_F
- : (char_pointer_to_string
- ((unsigned char *) (find_trap_name (trapno)))));
- trap_code = (find_trap_code_name (trapno, info, scp));
- if (!stack_recovered_p)
- {
+ trap_name = ((context == ((PCONTEXT) NULL))
+ ? SHARP_F
+ : (char_pointer_to_string (find_exception_name (code))));
+ trap_code = (long_to_integer (0));
+
+ if (win32_under_win32s_p ())
+ {
+ if (! stack_recovered_p)
Initialize_Stack ();
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_END_OF_COMPUTATION);
- Store_Expression (SHARP_F);
- Save_Cont ();
- Pushed ();
- }
+ clear_real_stack = FALSE;
+ real_stack_pointer = Stack_Pointer;
+ real_stack_guard = Stack_Guard;
+ temp_stack_limit = Stack_Pointer;
+ }
else
- Stack_Pointer = new_stack_pointer;
+ {
+ clear_real_stack = (!stack_recovered_p);
+ real_stack_pointer = new_stack_pointer;
+ real_stack_guard = Stack_Guard;
+ temp_stack_limit = temp_stack_end;
+ Stack_Pointer = temp_stack_end;
+ Stack_Guard = temp_stack;
+ }
+\f
Will_Push (7 + CONTINUATION_SIZE);
STACK_PUSH (trinfo -> extra_trap_info);
STACK_PUSH (trinfo -> pc_info_2);
STACK_PUSH (trap_code);
STACK_PUSH (trap_name);
Store_Return (RC_HARDWARE_TRAP);
- Store_Expression (long_to_integer (trapno));
+ Store_Expression (long_to_integer (code));
Save_Cont ();
Pushed ();
if (stack_recovered_p
- /* This may want to do it in other cases, but this may be enough. */
+ /* This may want to be done in other cases, but this may be enough. */
&& (trinfo->state == STATE_COMPILED_CODE))
Stop_History ();
STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed ();
SET_INTERRUPT_MASK (saved_mask);
- abort_to_interpreter (PRIM_APPLY);
-}
-\f
-/* DOS_INVALID_TRAP is an invalid trap, it means a user requested reset. */
-
-void
-DEFUN (hard_reset, (scp), struct FULL_SIGCONTEXT * scp)
-{
- continue_from_trap (DOS_INVALID_TRAP, 0, scp);
-}
-/* Called synchronously. */
-
-void
-DEFUN_VOID (soft_reset)
-{
- struct trap_recovery_info trinfo;
- SCHEME_OBJECT * new_stack_pointer =
- (((Stack_Pointer <= Stack_Top) && (Stack_Pointer > Stack_Guard))
- ? Stack_Pointer
- : 0);
- if ((Regs[REGBLOCK_PRIMITIVE]) != SHARP_F)
- {
- (trinfo . state) = STATE_PRIMITIVE;
- (trinfo . pc_info_1) = (Regs[REGBLOCK_PRIMITIVE]);
- (trinfo . pc_info_2) =
- (LONG_TO_UNSIGNED_FIXNUM (Regs[REGBLOCK_LEXPR_ACTUALS]));
- (trinfo . extra_trap_info) = SHARP_F;
- }
- else
- {
- (trinfo . state) = STATE_UNKNOWN;
- (trinfo . pc_info_1) = SHARP_F;
- (trinfo . pc_info_2) = SHARP_F;
- (trinfo . extra_trap_info) = SHARP_F;
- }
- if ((Free >= Heap_Top) || (Free < Heap_Bottom))
- /* Let's hope this works. */
- Free = MemTop;
- setup_trap_frame (DOS_INVALID_TRAP, 0, 0, (&trinfo), new_stack_pointer);
-}
-
-#if !defined(HAVE_SIGCONTEXT) || !defined(HAS_COMPILER_SUPPORT) || defined(USE_STACKLETS)
-
-static void
-DEFUN (continue_from_trap, (trapno, info, scp),
- int trapno AND
- SIGINFO_T info AND
- struct FULL_SIGCONTEXT * scp)
-{
- if (Free < MemTop)
- Free = MemTop;
- setup_trap_frame (trapno, info, scp, (&dummy_recovery_info), 0);
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "setup_trap_frame done."));
+ return;
}
-
-#else /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS */
\f
/* Heuristic recovery from processor traps/exceptions.
continue_from_trap attempts to:
1) validate the trap information (pc and sp);
- 2) determine whether compiled code was executing, a primitive was
- executing, or execution was in the interpreter;
+ 2) determine whether compiled code was executing,
+ a primitive was executing,
+ or execution was in the interpreter;
3) guess what C global state is still valid; and
4) set up a recovery frame for the interpreter so that debuggers can
- display more information. */
-
-#include "gccode.h"
+ display more information.
+*/
#define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
#define STACK_ALIGNMENT_MASK SCHEME_ALIGNMENT_MASK
/* But they may have bits that can be masked by this. */
#ifndef PC_VALUE_MASK
-#define PC_VALUE_MASK (~0)
+# define PC_VALUE_MASK (~0)
#endif
#define C_STACK_SIZE 0x01000000
#ifdef HAS_COMPILER_SUPPORT
-#define ALLOW_ONLY_C 0
+# define ALLOW_ONLY_C 0
#else
-#define ALLOW_ONLY_C 1
-#define PLAUSIBLE_CC_BLOCK_P(block) 0
+# define ALLOW_ONLY_C 1
+# define PLAUSIBLE_CC_BLOCK_P(block) 0
#endif
static SCHEME_OBJECT * EXFUN
(find_block_address, (char * pc_value, SCHEME_OBJECT * area_start));
-#if 0
-#define get_etext() (&etext)
-#else
+#define I386_NREGS 12
+
/* For now */
-#define get_etext() (Heap_Bottom)
-#endif
+#define GET_ETEXT() (Heap_Bottom)
static void
-DEFUN (continue_from_trap, (trapno, info, scp),
- int trapno AND
- SIGINFO_T info AND
- struct FULL_SIGCONTEXT * scp)
+DEFUN (continue_from_trap, (code, context),
+ DWORD code AND PCONTEXT context)
{
+ int pc_in_builtin;
+ int builtin_index;
int pc_in_C;
int pc_in_heap;
int pc_in_constant_space;
int pc_in_scheme;
int pc_in_hyper_space;
+ int pc_in_utility;
+ int utility_index;
int scheme_sp_valid;
- long C_sp;
long scheme_sp;
long the_pc;
SCHEME_OBJECT * new_stack_pointer;
SCHEME_OBJECT * xtra_info;
struct trap_recovery_info trinfo;
+ extern int EXFUN (pc_to_utility_index, (unsigned long));
+ extern int EXFUN (pc_to_builtin_index, (unsigned long));
- if (scp == ((struct FULL_SIGCONTEXT *) NULL))
+ IFVERBOSE (TellUserEx (MB_OKCANCEL,
+ "continue_from_trap (%s, 0x%lx).",
+ (find_exception_name (code)), context));
+\f
+ if (context == ((PCONTEXT) NULL))
{
if (Free < MemTop)
Free = MemTop;
- setup_trap_frame (trapno, info, scp, (&dummy_recovery_info), 0);
+ setup_trap_frame (code, context, (&dummy_recovery_info), 0);
/*NOTREACHED*/
}
- C_sp = (FULL_SIGCONTEXT_SP (scp));
- scheme_sp = (FULL_SIGCONTEXT_SCHSP (scp));
- the_pc = ((FULL_SIGCONTEXT_PC (scp)) & PC_VALUE_MASK);
+ if (context->SegSs == (getDS ()))
+ {
+ IFVERBOSE
+ (TellUserEx
+ (MB_OKCANCEL,
+ "continue_from_trap: SS = C DS; Stack_Pointer = 0x%lx; Esp = 0x%lx.",
+ Stack_Pointer, context->Esp));
+ scheme_sp = (context->Esp);
+ }
+ else if (context->SegSs == Scheme_Stack_Segment_Selector)
+ {
+ IFVERBOSE (TellUserEx (MB_OKCANCEL,
+ "continue_from_trap: SS = Scheme SS."));
+ scheme_sp = ((long) (SCHEME_ADDR_TO_ADDR (context->Esp)));
+ }
+ else
+ {
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap: SS unknown!"));
+ scheme_sp = 0;
+ }
-#if FALSE
- outf_error ("\ncontinue_from_trap:");
- outf_error ("\tpc = 0x%08lx\n", the_pc);
- outf_error ("\tCsp = 0x%08lx\n", C_sp);
- outf_error ("\tssp = 0x%08lx\n", scheme_sp);
- outf_error ("\tesp = 0x%08lx\n", Ext_Stack_Pointer);
-#endif
+ if (context->SegCs == (getCS ()))
+ {
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap: CS = C CS."));
+ the_pc = (context->Eip & PC_VALUE_MASK);
+ }
+ else if (context->SegCs == Scheme_Code_Segment_Selector)
+ {
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap: CS = Scheme CS"));
+ /* Assume in Scheme. Of course, it could be in a builtin. */
+ the_pc = ((long) (SCHEME_ADDR_TO_ADDR (context->Eip & PC_VALUE_MASK)));
+ }
+ else
+ {
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap: CS unknown"));
+ goto pc_in_hyperspace;
+ }
- if (((the_pc & PC_ALIGNMENT_MASK) != 0)
- || (scp->sc_cs != initial_C_cs))
+ if ((the_pc & PC_ALIGNMENT_MASK) != 0)
{
+pc_in_hyperspace:
+ pc_in_builtin = 0;
+ pc_in_utility = 0;
pc_in_C = 0;
pc_in_heap = 0;
pc_in_constant_space = 0;
}
else
{
- pc_in_C = (the_pc <= ((long) (get_etext ())));
+ builtin_index = (pc_to_builtin_index (the_pc));
+ pc_in_builtin = (builtin_index != -1);
+ utility_index = (pc_to_utility_index (the_pc));
+ pc_in_utility = (utility_index != -1);
+ pc_in_C = ((the_pc <= ((long) (GET_ETEXT ()))) && (! pc_in_builtin));
pc_in_heap =
((the_pc < ((long) Heap_Top)) && (the_pc >= ((long) Heap_Bottom)));
pc_in_constant_space =
((the_pc < ((long) Constant_Top)) &&
(the_pc >= ((long) Constant_Space)));
- pc_in_scheme = (pc_in_heap || pc_in_constant_space);
+ pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
}
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 1"));
+
scheme_sp_valid =
(pc_in_scheme
- && ((scp->sc_ss & 0xffff) == (scp->sc_ds & 0xffff))
- && ((scp->sc_ds & 0xffff) == (initial_C_ds & 0xffff))
&& ((scheme_sp < ((long) Stack_Top)) &&
(scheme_sp >= ((long) Absolute_Stack_Base)) &&
((scheme_sp & STACK_ALIGNMENT_MASK) == 0)));
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 2"));
+
new_stack_pointer =
(scheme_sp_valid
? ((SCHEME_OBJECT *) scheme_sp)
: ((pc_in_C
- && ((scp->sc_ss & 0xffff) == (initial_C_ss & 0xffff))
&& (Stack_Pointer < Stack_Top)
&& (Stack_Pointer > Absolute_Stack_Base))
? Stack_Pointer
: ((SCHEME_OBJECT *) 0)));
+\f
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 3"));
if (pc_in_hyper_space || (pc_in_scheme && ALLOW_ONLY_C))
{
SCHEME_OBJECT * block_addr;
SCHEME_OBJECT * maybe_free;
block_addr =
- (find_block_address (((PTR) the_pc),
- (pc_in_heap ? Heap_Bottom : Constant_Space)));
- if (block_addr == 0)
+ (pc_in_builtin
+ ? ((SCHEME_OBJECT *) NULL)
+ : (find_block_address (((PTR) the_pc),
+ (pc_in_heap ? Heap_Bottom : Constant_Space))));
+
+ if (block_addr != ((SCHEME_OBJECT *) NULL))
+ {
+ (trinfo . state) = STATE_COMPILED_CODE;
+ (trinfo . pc_info_1) =
+ (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
+ (trinfo . pc_info_2) =
+ (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
+ }
+ else if (pc_in_builtin)
+ {
+ (trinfo . state) = STATE_PROBABLY_COMPILED;
+ (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (builtin_index));
+ (trinfo . pc_info_2) = SHARP_T;
+ }
+ else
{
(trinfo . state) = STATE_PROBABLY_COMPILED;
(trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (the_pc));
(trinfo . pc_info_2) = SHARP_F;
+ }
+
+ if ((block_addr == ((SCHEME_OBJECT *) NULL)) && (! pc_in_builtin))
+ {
if ((Free < MemTop) ||
(Free >= Heap_Top) ||
((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
}
else
{
- (trinfo . state) = STATE_COMPILED_CODE;
- (trinfo . pc_info_1) =
- (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
- (trinfo . pc_info_2) =
- (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
-#ifdef HAVE_FULL_SIGCONTEXT
- maybe_free = ((SCHEME_OBJECT *) (FULL_SIGCONTEXT_RFREE (scp)));
+ maybe_free = ((SCHEME_OBJECT *) context->Edi);
if (((((unsigned long) maybe_free) & SCHEME_ALIGNMENT_MASK) == 0)
&& (maybe_free >= Heap_Bottom) && (maybe_free < Heap_Top))
Free = (maybe_free + FREE_PARANOIA_MARGIN);
else
-#endif
- {
if ((Free < MemTop) || (Free >= Heap_Top)
|| ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
Free = MemTop;
- }
}
}
- else
+\f
+ else /* pc_in_C */
{
/* In the interpreter, a primitive, or a compiled code utility. */
SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
- if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
+ if (pc_in_utility)
+ {
+ (trinfo . state) = STATE_PROBABLY_COMPILED;
+ (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (utility_index));
+ (trinfo . pc_info_2) = UNSPECIFIC;
+ }
+ else if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
{
(trinfo . state) = STATE_UNKNOWN;
(trinfo . pc_info_1) = SHARP_F;
else if ((Free + FREE_PARANOIA_MARGIN) < MemTop)
Free += FREE_PARANOIA_MARGIN;
}
- xtra_info = Free;
- Free += (1 + 2 + PROCESSOR_NREGS);
- (trinfo . extra_trap_info) =
- (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, xtra_info));
- (*xtra_info++) =
- (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (2 + PROCESSOR_NREGS)));
- (*xtra_info++) = ((SCHEME_OBJECT) the_pc);
- (*xtra_info++) = ((SCHEME_OBJECT) C_sp);
+
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 4"));
+
+ if (win32_under_win32s_p ())
+ (trinfo . extra_trap_info) = SHARP_F;
+ else
{
- int counter = FULL_SIGCONTEXT_NREGS;
- int * regs = (FULL_SIGCONTEXT_FIRST_REG (scp));
- while ((counter--) > 0)
- (*xtra_info++) = ((SCHEME_OBJECT) (*regs++));
- }
- /* We assume that regs,sp,pc is the order in the processor.
- Scheme can always fix this. */
- if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 0)
- (*xtra_info++) = ((SCHEME_OBJECT) C_sp);
- if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 1)
+ xtra_info = Free;
+ Free += (1 + (I386_NREGS + 2));
+ (trinfo . extra_trap_info) =
+ (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, xtra_info));
+ (*xtra_info++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (I386_NREGS + 2)));
(*xtra_info++) = ((SCHEME_OBJECT) the_pc);
- setup_trap_frame (trapno, info, scp, (&trinfo), new_stack_pointer);
+ (*xtra_info++) = ((SCHEME_OBJECT) scheme_sp);
+ {
+ int counter = I386_NREGS;
+ int * regs = ((int *) context->Edi);
+ while ((counter--) > 0)
+ (*xtra_info++) = ((SCHEME_OBJECT) (*regs++));
+ }
+ }
+
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 5"));
+
+ /* Handshake with try+except. */
+
+ context->Eip = ((DWORD) callWinntExceptionTransferHook);
+ context->SegCs = (getCS ());
+ return_by_aborting = TRUE;
+
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 6"));
+
+ if (pc_in_scheme && (! (win32_under_win32s_p ())))
+ {
+ context->SegCs = C_Code_Segment_Selector;
+ context->SegDs = C_Data_Segment_Selector;
+ context->SegEs = C_Extra_Segment_Selector;
+ context->SegSs = C_Stack_Segment_Selector;
+ context->Esp = C_Stack_Pointer;
+ context->Ebp = C_Frame_Pointer;
+ if (pc_in_scheme)
+ return_by_aborting = FALSE;
+ }
+
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 7"));
+
+ setup_trap_frame (code, context, (&trinfo), new_stack_pointer);
+
+ IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 8"));
}
\f
/* Find the compiled code block in area which contains `pc_value'.
{
SCHEME_OBJECT * block = (area - 1);
return
- (((area == first_valid) ||
- ((OBJECT_TYPE (*block)) != TC_MANIFEST_VECTOR) ||
- ((OBJECT_DATUM (*block)) < (count + 1)) ||
- (! (PLAUSIBLE_CC_BLOCK_P (block))))
+ (((area == first_valid)
+ || ((OBJECT_TYPE (* block)) != TC_MANIFEST_VECTOR)
+ || ((OBJECT_DATUM (* block)) < ((unsigned long) (count + 1)))
+ || (! (PLAUSIBLE_CC_BLOCK_P (block))))
? 0
: block);
}
}
return (0);
}
+\f
+static void
+DEFUN (trap_recover, (code, context),
+ DWORD code AND PCONTEXT context)
+{
+ IFVERBOSE (TellUserEx (MB_OKCANCEL,
+ "trap_recover (%s, 0x%lx).",
+ (find_exception_name (code)), context));
+
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ CLEAR_CRITICAL_SECTION_HOOK ();
+ EXIT_CRITICAL_SECTION ({});
+ }
+ reset_interruptable_extent ();
+ continue_from_trap (code, context);
+}
+
+static void
+DEFUN (nt_trap_handler, (code, context),
+ DWORD code AND PCONTEXT context)
+{
+ Boolean constant_space_broken = (! (CONSTANT_SPACE_SEALED ()));
+ enum trap_state old_trap_state = trap_state;
+ int flags;
+
+ IFVERBOSE (TellUserEx (MB_OKCANCEL,
+ "nt_trap_handler (%s, 0x%lx).",
+ (find_exception_name (code)), context));
+
+ if (old_trap_state == trap_state_exitting_hard)
+ _exit (1);
+ else if (old_trap_state == trap_state_exitting_soft)
+ trap_immediate_termination ();
+
+ trap_state = trap_state_trapped;
+
+ trap_noise_start ();
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ trap_noise (">> The system has trapped within critical section \"%s\".\n",
+ (CRITICAL_SECTION_NAME ()));
+ describe_trap ("trap is", code);
+ }
+ else if (constant_space_broken || (old_trap_state != trap_state_recover))
+ {
+ trap_noise (">> The system has trapped.\n");
+ describe_trap ("trap is", code);
+ }
+ if (constant_space_broken)
+ {
+ trap_noise (">> Constant space has been overwritten.\n");
+ trap_noise (">> Probably a runaway recursion has overflowed the stack.\n");
+ }
+\f
+ switch (old_trap_state)
+ {
+ case trap_state_trapped:
+ if ((saved_trap_state == trap_state_recover)
+ || (saved_trap_state == trap_state_query))
+ {
+ trap_noise (">> The trap occurred while processing an earlier trap.\n");
+ describe_trap ("earlier trap was", saved_trap_code);
+ trap_noise ((WITHIN_CRITICAL_SECTION_P ())
+ ? ">> Successful recovery is extremely unlikely.\n"
+ : ">> Successful recovery is unlikely.\n");
+ break;
+ }
+ else
+ {
+ (void) trap_noise_end (MB_OK | MB_ICONSTOP);
+ trap_immediate_termination ();
+ }
+
+ case trap_state_recover:
+ if ((WITHIN_CRITICAL_SECTION_P ()) || constant_space_broken)
+ {
+ trap_noise (">> Successful recovery is unlikely.\n");
+ break;
+ }
+ else
+ {
+ saved_trap_state = old_trap_state;
+ saved_trap_code = code;
+ (void) trap_noise_end (MB_OK | MB_ICONSTOP);
+ trap_recover (code, context);
+ return;
+ }
+ case trap_state_exit:
+ (void) trap_noise_end (MB_OK | MB_ICONSTOP);
+ termination_trap ();
+ }
+
+ trap_noise ("\n");
+ saved_trap_state = old_trap_state;
+ saved_trap_code = code;
+ flags = MB_ICONSTOP;
+
+ while (1)
+ {
+ trap_noise ("Attempt recovery?");
+ if ((trap_noise_end (MB_YESNO | flags)) == IDYES)
+ {
+ trap_recover (code, context);
+ return;
+ }
+ flags = 0;
+
+ trap_noise ("Terminate Scheme normally?");
+ switch (trap_noise_end (MB_YESNOCANCEL))
+ {
+ case IDYES:
+ trap_normal_termination ();
+
+ case IDNO:
+ trap_immediate_termination ();
+ _exit (1);
+
+ default:
+ break;
+ }
+ }
+}
+\f
+#ifdef W32_TRAP_DEBUG
+
+static void
+DEFUN (parse_response, (buf, addr, len),
+ char * buf AND unsigned long * addr AND int * len)
+{
+ const char * separators = " ,\t;";
+ char * token;
+
+ token = (strtok (buf, separators));
+ if (token == ((char *) NULL))
+ return;
+ * addr = (strtoul (token, ((char **) NULL), 0));
+ token = (strtok (((char *) NULL), separators));
+ if (token == ((char *) NULL))
+ return;
+ * len = ((int) (strtoul (token, ((char **) NULL), 0)));
+ return;
+}
+
+static void
+DEFUN (tinyexcpdebug, (code, info),
+ DWORD code AND LPEXCEPTION_POINTERS info)
+{
+ int count, len;
+ char * message;
+ unsigned long * addr;
+ char responsebuf[256], * response;
+
+ if ((MessageBox (NULL, "Debug?", "MIT Scheme Exception Debugger", MB_YESNO))
+ != IDYES)
+ return;
+
+ message = "&info =";
+ addr = ((unsigned long *) (& info));
+ len = 1;
+
+ while (1)
+ {
+ trap_noise_start ();
+ trap_noise ("%s 0x%lx.\n", message, ((unsigned long) addr));
+ for (count = 0; count < len; count++)
+ trap_noise ("\n*0x%08x\t= 0x%08x\t= %d.",
+ (addr + count),
+ addr[count],
+ addr[count]);
+ trap_noise ("\n\nMore?");
+ if ((trap_noise_end (MB_YESNO)) != IDYES)
+ break;
+ response = (AskUser (&responsebuf[0], (sizeof (responsebuf))));
+ if (response == ((char *) NULL))
+ continue;
+ message = "Contents of";
+ parse_response (&responsebuf[0], &addr, &len);
+ }
+ return;
+}
+#endif /* W32_TRAP_DEBUG */
+\f
+static int
+DEFUN (WinntException, (code, info),
+ DWORD code AND LPEXCEPTION_POINTERS info)
+{
+ PCONTEXT context;
+
+ context = info->ContextRecord;
+ if ((info->ExceptionRecord->ExceptionFlags != 0)
+ || (context == ((PCONTEXT) NULL))
+ || ((context->ContextFlags & CONTEXT_CONTROL) == 0)
+ || ((context->ContextFlags & CONTEXT_INTEGER) == 0)
+ || ((context->ContextFlags & CONTEXT_SEGMENTS) == 0))
+ {
+ (void)
+ display_exception_information (info->ExceptionRecord,
+ info->ContextRecord,
+ MB_OK);
+ trap_immediate_termination ();
+ }
+ else
+ {
+#ifdef W32_TRAP_DEBUG
+ trap_verbose_p = ((display_exception_information
+ (info->ExceptionRecord,
+ info->ContextRecord,
+ MB_YESNO))
+ == IDYES);
+ tinyexcpdebug (code, info);
+#endif /* W32_TRAP_DEBUG */
+ nt_trap_handler (code, context);
+ return (EXCEPTION_CONTINUE_EXECUTION);
+ }
+}
-#endif /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS */
+extern void EXFUN (WinntEnterHook, (void (*) (void)));
+void
+DEFUN (WinntEnterHook, (enter_interpreter),
+ void EXFUN ((* enter_interpreter), (void)))
+{
+ do
+ {
+ try
+ {
+ (* enter_interpreter) ();
+ }
+ except (WinntException ((GetExceptionCode ()),
+ (GetExceptionInformation ())))
+ {
+ outf_fatal ("Exception!\n");
+ termination_trap ();
+ }
+ } while (1);
+}
/* -*-C-*-
-$Id: scheme16.c,v 1.1 1993/07/27 20:53:27 gjr Exp $
+$Id: scheme16.c,v 1.2 1993/08/21 03:51:47 gjr Exp $
Copyright (c) 1993 Massachusetts Institute of Technology
Win16 side of the Win32s version.
*/
+#define _WINDLL
#define W32SUT_16
-#include <stdarg.h>
-#include <windows.h>
-#include <w32sut.h>
-#include "ntw32lib.h"
+#include "ntscmlib.h"
+#include <dos.h>
\f
-#ifndef STD_MSGBOX_STYLE
-# define STD_MSGBOX_STYLE MB_OK
-#endif
+struct seg_desc_s
+{
+ unsigned long low;
+ unsigned long high;
+};
-static void
-TellUser (char * format, unsigned long value)
-{
- char buffer[128];
-
- wsprintf (&buffer[0],
- ((LPCSTR) format),
- value);
-
- MessageBox (NULL,
- ((LPCSTR) &buffer[0]),
- ((LPCSTR) "MIT Scheme Win16 Notification"),
- STD_MSGBOX_STYLE);
- return;
+static BOOL
+DPMI_get_descriptor (UINT selector, struct seg_desc_s far * desc)
+{
+ UINT saved_es;
+
+ _asm
+ {
+ _emit 066h
+ push di
+ _emit 066h
+ push bx
+ _emit 066h
+ xor di,di
+ mov ax,es
+ mov word ptr [bp-2],ax
+ les di, dword ptr 6[bp]
+ mov bx, word ptr 4[bp]
+ mov ax, 000bh
+ int 31h
+ jc fail
+ mov ax, word ptr [bp-2]
+ mov es,ax
+ _emit 066h
+ pop bx
+ _emit 066h
+ pop di
+ mov ax,0
+ leave
+ ret
+ fail:
+ mov ax, word ptr [bp-2]
+ mov es,ax
+ _emit 066h
+ pop bx
+ _emit 066h
+ pop di
+ mov ax,1
+ leave
+ ret
+ }
}
+\f
+static BOOL
+DPMI_set_descriptor (UINT selector, struct seg_desc_s far * desc)
+{
+ UINT saved_es;
+ _asm
+ {
+ _emit 066h
+ push di
+ _emit 066h
+ push bx
+ _emit 066h
+ xor di,di
+ mov ax,es
+ mov word ptr [bp-2],ax
+ les di, dword ptr 6[bp]
+ mov bx, word ptr 4[bp]
+ mov ax, 000ch
+ int 31h
+ jc fail
+ mov ax, word ptr [bp-2]
+ mov es,ax
+ _emit 066h
+ pop bx
+ _emit 066h
+ pop di
+ mov ax,0
+ leave
+ ret
+ fail:
+ mov ax, word ptr [bp-2]
+ mov es,ax
+ _emit 066h
+ pop bx
+ _emit 066h
+ pop di
+ mov ax,1
+ leave
+ ret
+ }
+}
+\f
static DWORD
-win16_allocate_heap (struct ntw32lib_malloc_s FAR * buf)
+win16_alloc_scheme_selectors (struct ntw32lib_selalloc_s FAR * buf)
{
- DWORD linear_address = 0L;
- DWORD handle = 0L;
- UINT lose = 0;
- UINT code = 0;
-
+ UINT cs_sel, ds_sel;
+ struct seg_desc_s desc;
+ unsigned long nbase, nlimit;
+
+ ds_sel = (AllocSelector (0));
+ if (ds_sel == 0)
+ return (0L);
+ nbase = (GetSelectorBase (buf->ds32));
+
+ nbase = (nbase + buf->base);
+ (void) DPMI_get_descriptor (buf->ds32, & desc);
+
+ desc.low &= 0xffffUL;
+ desc.low |= (nbase << 16);
+ desc.high &= 0x00ffff00UL;
+ desc.high |= (nbase & 0xff000000UL);
+ desc.high |= ((nbase >> 16) & 0xff);
+ (void) DPMI_set_descriptor (ds_sel, & desc);
+
+ cs_sel = (AllocDStoCSAlias (ds_sel));
+ if (cs_sel == 0)
+ {
#if 0
- union _REGS regs;
+ FreeSelector (ds_sel);
+#endif
+ return (0L);
+ }
+ buf->cs = cs_sel;
+ buf->ds = ds_sel;
+ buf->ss = ds_sel;
- regs.x.ax = 0x0501;
- regs.x.bx = (HIWORD (buf->size));
- regs.x.cx = (LOWORD (buf->size));
- (void) _int86 (0x31, ®s, ®s);
+ nbase = (GetSelectorBase (cs_sel));
+ nlimit = (GetSelectorLimit (cs_sel));
- if (regs.x.cflag)
+ if ((nbase != 0) && (nlimit != 0))
+ return (1L);
+ else
{
- TellUser ("DPMI failed.", 0L);
+#if 0
+ FreeSelector (cs_sel);
+ FreeSelector (ds_sel);
+#endif
return (0L);
}
- linear_address = (MAKELONG (regs.x.cx, regs.x.bx));
+}
-#elif 0
- TellUser ("Trying to allocate %ld bytes.", buf->size);
-
- _asm les bx,DWORD PTR [bp+4]
- _asm mov bx,WORD PTR es:[bx+2]
- _asm mov cx,WORD PTR es:[bx]
- _asm mov ax,0501H
- _asm int 031h
+static DWORD
+win16_release_scheme_selectors (struct ntw32lib_selfree_s FAR * buf)
+{
+#if 0
+ if ((buf->ds != 0) && (buf->ds != buf->ds32))
+ FreeSelector (buf->ds);
+ if ((buf->cs != 0) && (buf->cs != buf->cs32))
+ FreeSelector (buf->cs);
+#endif
+ return (1L);
+}
+\f
+static BOOL
+DPMI_lock_unlock (UINT fun, unsigned long lin, unsigned long nbytes)
+{
+ _asm
+ {
+ push si
+ push di
+ push bx
+
+ mov ax, 4[bp]
+ mov cx, 6[bp]
+ mov bx, 8[bp]
+ mov di, 10[bp]
+ mov si, 12[bp]
+
+ int 31h
+ jc fail
+ mov ax,1
+ jmp join
+
+ fail:
+ xor ax,ax
+ join:
+ pop bx
+ pop di
+ pop si
+ leave
+ ret
+ }
+}
- _asm jnc dpmi_wins
- _asm mov WORD PTR [bp-10],1
- _asm jmp dpmi_merge
+static BOOL
+pagelockunlock (unsigned int dpmi_fun, void FAR * low, unsigned long nbytes)
+{
+ unsigned int seg, off;
+ unsigned long base, lin;
- _asm dpmi_wins:
- _asm mov WORD PTR [bp-4],cx
- _asm mov WORD PTR [bp-2],bx
- _asm dpmi_merge:
+ seg = (FP_SEG (low));
+ off = (FP_OFF (low));
+ base = (GetSelectorBase (seg));
+ lin = (base + ((unsigned long) off));
-#else
+ return (DPMI_lock_unlock (dpmi_fun, lin, nbytes));
+}
- TellUser ("Trying to allocate %ld bytes.", buf->size);
-
- _asm les bx,DWORD PTR [bp+4]
- _asm mov ecx,DWORD PTR es:[bx]
- _asm mov ebx,00200000H
- _asm mov edx,1
- _asm mov ax,0504H
- _asm int 031H
-
- _asm jnc dpmi_wins
- _asm mov WORD PTR [bp-10],1
- _asm mov WORD PTR [bp-12],ax
- _asm jmp dpmi_merge
-
- _asm dpmi_wins:
- _asm mov DWORD PTR [bp-4],ebx
- _asm mov DWORD PTR [bp-8],esi
- _asm dpmi_merge:
+static BOOL
+pagelock (void FAR * low, unsigned long nbytes)
+{
+ return (pagelockunlock (0x0600, low, nbytes));
+}
-#endif
+static BOOL
+pageunlock (void FAR * low, unsigned long nbytes)
+{
+ return (pagelockunlock (0x0601, low, nbytes));
+}
+
+static DWORD
+win16_lock_area (struct ntw32lib_vlock_s FAR * buf)
+{
+ return ((DWORD) (pagelock (buf->area, buf->size)));
+}
- if (lose)
+static DWORD
+win16_unlock_area (struct ntw32lib_vulock_s FAR * buf)
+{
+ return ((DWORD) (pageunlock (buf->area, buf->size)));
+}
+\f
+#ifndef MK_FP
+static void FAR *
+MK_FP (unsigned short seg, unsigned short off)
+{
+ union
{
- TellUser ("DPMI call failed 0x%x", ((unsigned long) code));
- return (0L);
+ struct
+ {
+ unsigned short off;
+ unsigned short seg;
+ } split;
+ void FAR * result;
+ } views;
+
+ views.split.seg = seg;
+ views.split.off = off;
+ return (views.result);
+}
+#endif /* MK_FP */
+
+static WORD htimer = 0;
+static unsigned long timer_index = 0;
+
+static WORD (FAR PASCAL * KillSystemTimer) (WORD htimer);
+
+static struct ntw16lib_itimer_s
+{
+ struct ntw16lib_itimer_s FAR * next;
+ unsigned long FAR * base;
+ unsigned long memtop_off;
+ unsigned long int_code_off;
+ unsigned long int_mask_off;
+ unsigned long bit_mask;
+ unsigned long index;
+ UINT selector;
+ HGLOBAL ghan;
+} FAR * async_timers = ((struct ntw16lib_itimer_s FAR *) NULL);
+
+void FAR _export
+scheme_asynctimer (void)
+{
+ struct ntw16lib_itimer_s FAR * scm_timer = async_timers;
+
+ while (scm_timer != ((struct ntw16lib_itimer_s FAR *) NULL))
+ {
+ scm_timer->base[scm_timer->int_code_off] |= scm_timer->bit_mask;
+ if ((scm_timer->base[scm_timer->int_mask_off]
+ & scm_timer->bit_mask)
+ != 0)
+ scm_timer->base[scm_timer->memtop_off] = ((unsigned long) -1L);
+ scm_timer = scm_timer->next;
}
-
- TellUser ("Linear address = 0x%lx.", linear_address);
- TellUser ("Handle = 0x%lx.", handle);
- buf->area = linear_address;
- buf->handle = handle;
- return (linear_address);
+ return;
}
-static DWORD
-win16_release_heap (struct ntw32lib_malloc_s FAR * buf)
+static void
+scheme_asynctimer_end (void)
{
- TellUser ("Freeing arena with handle 0x%lx", buf->handle);
+ return;
+}
+\f
+static void
+possibly_uninstall_async_handler (void)
+{
+ if (async_timers != ((struct ntw16lib_itimer_s FAR *) NULL))
+ return;
+ if (htimer != 0)
+ {
+ KillSystemTimer (htimer);
+ htimer = 0;
+ }
+ pageunlock (&async_timers,
+ (sizeof (struct ntw16lib_itimer_s FAR *)));
+ pageunlock (((void FAR *) scheme_asynctimer),
+ ((unsigned long) scheme_asynctimer_end)
+ - ((unsigned long) scheme_asynctimer));
+ return;
+}
- _asm les bx,DWORD PTR [bp+4]
- _asm mov si,WORD PTR es:[bx+6]
- _asm mov di,WORD PTR es:[bx+4]
- _asm mov ax,0502H
- _asm int 031H
+static DWORD
+win16_flush_timer (struct ntw32lib_ftimer_s FAR * buf)
+{
+ unsigned long index = buf->handle;
+ struct ntw16lib_itimer_s FAR * FAR * ptr = & async_timers;
+ while ((* ptr) != ((struct ntw16lib_itimer_s FAR *) NULL))
+ {
+ if (((* ptr) -> index) == index)
+ {
+ struct ntw16lib_itimer_s FAR * current = (* ptr);
+
+ (* ptr) = current->next;
+ if (index == (timer_index - 1))
+ timer_index = index;
+ FreeSelector (current->selector);
+ GlobalPageUnlock (current->ghan);
+ GlobalUnlock (current->ghan);
+ GlobalFree (current->ghan);
+ possibly_uninstall_async_handler ();
+ return (1L);
+ }
+ ptr = & ((* ptr) -> next);
+ }
return (0L);
}
\f
+static DWORD
+do_install_async_handler (void)
+{
+ WORD (FAR PASCAL * CreateSystemTimer) (WORD rate, FARPROC callback);
+ HINSTANCE hsystem;
+
+ if (! (pagelock (((void FAR *) scheme_asynctimer),
+ ((unsigned long) scheme_asynctimer_end)
+ - ((unsigned long) scheme_asynctimer))))
+ return (WIN32_ASYNC_TIMER_NOLOCK);
+ else if (! (pagelock (&async_timers,
+ (sizeof (struct ntw16lib_itimer_s FAR *)))))
+ {
+ pageunlock (((void FAR *) scheme_asynctimer),
+ ((unsigned long) scheme_asynctimer_end)
+ - ((unsigned long) scheme_asynctimer));
+ return (WIN32_ASYNC_TIMER_NOLOCK);
+ }
+
+ hsystem = (GetModuleHandle ("SYSTEM"));
+ CreateSystemTimer = (GetProcAddress (hsystem, "CREATESYSTEMTIMER"));
+ KillSystemTimer = (GetProcAddress (hsystem, "KILLSYSTEMTIMER"));
+
+ if ((CreateSystemTimer == ((WORD (FAR PASCAL *) (WORD, FARPROC)) NULL))
+ || (KillSystemTimer == ((WORD (FAR PASCAL *) (WORD)) NULL)))
+ {
+ possibly_uninstall_async_handler ();
+ return (WIN32_ASYNC_TIMER_NONE);
+ }
+
+ htimer = (CreateSystemTimer (55, ((FARPROC) scheme_asynctimer)));
+ if (htimer == 0)
+ {
+ possibly_uninstall_async_handler ();
+ return (WIN32_ASYNC_TIMER_EXHAUSTED);
+ }
+ return (WIN32_ASYNC_TIMER_OK);
+}
+\f
+static DWORD
+win16_install_timer (struct ntw32lib_itimer_s FAR * buf)
+{
+ struct ntw16lib_itimer_s FAR * scm_timer;
+ DWORD result;
+ HGLOBAL ghan;
+
+ if (htimer == 0)
+ {
+ result = (do_install_async_handler ());
+ if (result != WIN32_ASYNC_TIMER_OK)
+ return (result);
+ }
+
+ ghan = (GlobalAlloc (GMEM_FIXED, (sizeof (struct ntw16lib_itimer_s))));
+ if (ghan == ((HGLOBAL) NULL))
+ {
+ possibly_uninstall_async_handler ();
+ return (WIN32_ASYNC_TIMER_NOMEM);
+ }
+ scm_timer = ((struct ntw16lib_itimer_s FAR *) (GlobalLock (ghan)));
+ if (scm_timer == ((struct ntw16lib_itimer_s FAR *) NULL))
+ {
+ GlobalFree (ghan);
+ possibly_uninstall_async_handler ();
+ return (WIN32_ASYNC_TIMER_NOLOCK);
+ }
+ if ((GlobalPageLock (ghan)) == 0)
+ {
+ GlobalUnlock (ghan);
+ GlobalFree (ghan);
+ possibly_uninstall_async_handler ();
+ return (WIN32_ASYNC_TIMER_NOLOCK);
+ }
+
+ scm_timer->selector = (AllocSelector (FP_SEG (buf->base)));
+ if (scm_timer->selector == 0)
+ {
+ GlobalPageUnlock (ghan);
+ GlobalUnlock (ghan);
+ GlobalFree (ghan);
+ possibly_uninstall_async_handler ();
+ return (WIN32_ASYNC_TIMER_NOLDT);
+ }
+
+ scm_timer->ghan = ghan;
+ scm_timer->base = (MK_FP (scm_timer->selector, (FP_OFF (buf->base))));
+ scm_timer->memtop_off = buf->memtop_off;
+ scm_timer->int_code_off = buf->int_code_off;
+ scm_timer->int_mask_off = buf->int_mask_off;
+ scm_timer->bit_mask = buf->bit_mask;
+ scm_timer->index = timer_index++;
+ scm_timer->next = async_timers;
+
+ buf->handle = scm_timer->index;
+ async_timers = scm_timer;
+
+ return (WIN32_ASYNC_TIMER_OK);
+}
+\f
/* The 32-bit call-back thunk is not really needed right now, but ... */
static UT16CBPROC call_32_bit_code = NULL;
return (win16_release_heap (buf));
case NTW32LIB_VIRTUAL_LOCK:
- return (1L);
+ return (win16_lock_area (buf));
case NTW32LIB_VIRTUAL_UNLOCK:
- return (1L);
+ return (win16_unlock_area (buf));
case NTW32LIB_INSTALL_TIMER:
- return (0L);
+ return (win16_install_timer (buf));
case NTW32LIB_FLUSH_TIMER:
- return (0L);
+ return (win16_flush_timer (buf));
+
+ case NTW32LIB_ALLOC_SELECTORS:
+ return (win16_alloc_scheme_selectors (buf));
+
+ case NTW32LIB_FREE_SELECTORS:
+ return (win16_release_scheme_selectors (buf));
default:
return (0L);
projects / mit-scheme.git / commitdiff