From 000fc155c733f65fe7091babbae38329a6aac581 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 28 Apr 1995 07:05:10 +0000
Subject: [PATCH] * The procedure OS_set_working_dir_pathname in "os2env.c" had
 a   serious bug: passing it a string like "d:\\" caused it to signal a  
 Scheme error.  What was serious was that this could occur while   spawning a
 subprocess, which for some as-yet unexplained reason   would crash Scheme
 with no error message.  To compound matters, the   bug appeared to be
 unreproduceable under a debugger (not true).  The   remaining changes were
 side effects of the blind debugging process:

* Added OS2_initialize_early to "boot.c" and "os2top.c".  This allows
  the microcode to do the initialization necessary to put up dialog
  boxes.  Which in turn is needed to report boot-time errors, such as
  non-existent band file names.

* "option.c" calls outf but did not include "outf.h".  Under ANSI C,
  since outf takes a variable number of arguments, this results in
  unspecified behavior.  Under OS/2 with IBM's compiler, this causes a
  mismatch in calling conventions, which can result in bizarre errors.

* Modified "os2.c" to have an alternate implementation of OS_malloc
  and related procedures.  This was generated while attempting to
  track down a nasty bug that appeared to be a memory-allocation
  error.  The alternate implementation is #ifdef'ed out, but left in
  place should it be useful in the future.

* Improved the definition of OS2_logic_error_1 so that it treats
  errors in non-essential subthreads as non-fatal.  Also improved the
  wording of the error messages produced, and included more
  information for future reference.

* All subthreads now have exception handlers and PM message queues, so
  they can catch and report any exceptions that occur in them.
  Previously, an exception occurring in a subthread would crash Scheme
  with no explanation.

* Enhanced the acknowledgement messages sent to a channel readahead
  thread to carry a flag indicating whether the thread is being asked
  to read some more or to kill itself.  This eliminates a race
  condition associated with closing of the channel.

* Changed the input-pipe readahead thread to accept its arguments in a
  freshly malloc'ed structure that the thread is responsible for
  freeing.  Previously, the arguments were accepted in a channel,
  which contained a context structure which in turn contained the
  arguments.  The previous implementation had a race condition in that
  the argument data structures were owned by the Scheme thread, and
  could be deallocated before the readahead thread had a chance to
  dereference them.

* In "os2proc.c", moved the allocation of the structure representing
  the child process into the locked region of the process
  initialization.  This is necessary because the child-wait thread
  accesses the same structures as the allocator.

* In "os2proc.c", the working directory was being saved and later
  restored.  But this was a static string, and there weren't good
  guarantees as to it retaining its value -- so now it is copied
  before being stored.

* When putting up a message box for a fatal error, the buffer used to
  compose the message was static.  This caused garbling when the two
  threads attempted to produce fatal errors at the same time (this was
  occurring regularly during the debugging process).  Now the message
  box uses a per-thread static buffer.
---
 v7/src/microcode/boot.c     |   8 +-
 v7/src/microcode/option.c   |   5 +-
 v7/src/microcode/os2.c      | 179 +++++++++++++++++++++++++++++++++---
 v7/src/microcode/os2conio.c |  13 ++-
 v7/src/microcode/os2cthrd.c |  43 ++++++---
 v7/src/microcode/os2cthrd.h |  13 ++-
 v7/src/microcode/os2env.c   |  20 ++--
 v7/src/microcode/os2io.h    |   5 +-
 v7/src/microcode/os2msg.c   |   7 +-
 v7/src/microcode/os2pipe.c  |  33 ++++---
 v7/src/microcode/os2pm.c    |   9 +-
 v7/src/microcode/os2proc.c  |  27 ++++--
 v7/src/microcode/os2thrd.c  |  46 +++++++--
 v7/src/microcode/os2thrd.h  |  11 ++-
 v7/src/microcode/os2top.c   |  77 +++++++++++-----
 v7/src/microcode/os2xcpt.c  |  75 ++++++++++++++-
 v7/src/microcode/outf.c     |  22 ++---
 17 files changed, 463 insertions(+), 130 deletions(-)

diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c
index ce87deedf..647078b3c 100644
--- a/v7/src/microcode/boot.c
+++ b/v7/src/microcode/boot.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: boot.c,v 9.94 1995/01/06 17:42:11 cph Exp $
+$Id: boot.c,v 9.95 1995/04/28 07:04:50 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -119,6 +119,12 @@ DEFUN (main_name, (argc, argv),
   initial_C_stack_pointer = ((PTR) (&argc));
 #ifdef PREALLOCATE_HEAP_MEMORY
   PREALLOCATE_HEAP_MEMORY ();
+#endif
+#ifdef _OS2
+  {
+    extern void OS2_initialize_early (void);
+    OS2_initialize_early ();
+  }
 #endif
   obstack_init (&scratch_obstack);
   dstack_initialize ();
diff --git a/v7/src/microcode/option.c b/v7/src/microcode/option.c
index 5a805621a..0541f112f 100644
--- a/v7/src/microcode/option.c
+++ b/v7/src/microcode/option.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: option.c,v 1.40 1994/11/28 04:28:41 cph Exp $
+$Id: option.c,v 1.41 1995/04/28 07:04:52 cph Exp $
 
-Copyright (c) 1990-94 Massachusetts Institute of Technology
+Copyright (c) 1990-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -37,6 +37,7 @@ MIT in each case. */
 #include <ctype.h>
 #include "ansidecl.h"
 #include "obstack.h"
+#include "outf.h"
 #include "config.h"
 #include "osenv.h"
 #include "osfs.h"
diff --git a/v7/src/microcode/os2.c b/v7/src/microcode/os2.c
index 1d582f00c..77ad2028a 100644
--- a/v7/src/microcode/os2.c
+++ b/v7/src/microcode/os2.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2.c,v 1.3 1995/01/05 23:36:07 cph Exp $
+$Id: os2.c,v 1.4 1995/04/28 07:04:53 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -34,10 +34,140 @@ MIT in each case. */
 
 #include "os2.h"
 
+/* Define OS2_USE_SUBHEAP_MALLOC to use this custom malloc
+   implementation for most of Scheme's memory.  This implementation,
+   by virtue of being separate from the system's malloc, and also by
+   having specific redundancy checks, offers some features that can be
+   valuable during debugging of memory problems.  */
+
+/* #define OS2_USE_SUBHEAP_MALLOC */
+#ifdef OS2_USE_SUBHEAP_MALLOC
+
+static PVOID malloc_object;
+static ULONG malloc_object_size = 0x200000; /* two megabytes */
+
+typedef struct
+{
+  char * check;
+  unsigned int size;
+} malloc_header_t;
+
+void
+OS2_initialize_malloc (void)
+{
+  if (((DosAllocMem ((&malloc_object),
+		     malloc_object_size,
+		     (PAG_EXECUTE | PAG_READ | PAG_WRITE)))
+       != NO_ERROR)
+      || ((DosSubSetMem (malloc_object,
+			 (DOSSUB_INIT | DOSSUB_SPARSE_OBJ | DOSSUB_SERIALIZE),
+			 malloc_object_size))
+	  != NO_ERROR))
+    termination_init_error ();
+}
+
+static malloc_header_t *
+guarantee_valid_malloc_pointer (void * ptr)
+{
+  malloc_header_t * header = (((malloc_header_t *) ptr) - 1);
+  if ((((char *) header) < ((char *) malloc_object))
+      || (((char *) header) > (((char *) malloc_object) + malloc_object_size))
+      || ((((ULONG) header) & 7) != 0)
+      || ((header -> check) != (((char *) header) - 47)))
+    OS2_logic_error ("Bad pointer passed to OS_free.");
+  return (header);
+}
+
+void *
+OS2_malloc_noerror (unsigned int size)
+{
+  PVOID result;
+  APIRET rc
+    = (DosSubAllocMem (malloc_object,
+		       (&result),
+		       (size + (sizeof (malloc_header_t)))));
+  if (rc == ERROR_DOSSUB_NOMEM)
+    return (0);
+  if (rc != NO_ERROR)
+    {
+      char buffer [1024];
+      sprintf (buffer, "DosSubAllocMem error: %d.", rc);
+      OS2_logic_error (buffer);
+    }
+  (((malloc_header_t *) result) -> check) = (((char *) result) - 47);
+  (((malloc_header_t *) result) -> size) = size;
+  return (((malloc_header_t *) result) + 1);
+}
+
+void
+OS_free (void * ptr)
+{
+  malloc_header_t * header = (guarantee_valid_malloc_pointer (ptr));
+  APIRET rc;
+  (header -> check) = 0;
+  rc = (DosSubFreeMem (malloc_object, header, (header -> size)));
+  if (rc != NO_ERROR)
+    {
+      char buffer [1024];
+      sprintf (buffer, "DosSubFreeMem error: %d.", rc);
+      OS2_logic_error (buffer);
+    }
+}
+
+void *
+OS2_realloc_noerror (void * ptr, unsigned int size)
+{
+  unsigned int osize = ((guarantee_valid_malloc_pointer (ptr)) -> size);
+  if (osize == size)
+    return (ptr);
+  {
+    void * result = (OS2_malloc_noerror (size));
+    if (result != 0)
+      {
+	char * scan1 = ptr;
+	char * end1 = (scan1 + ((osize < size) ? osize : size));
+	char * scan2 = result;
+	while (scan1 < end1)
+	  (*scan2++) = (*scan1++);
+	OS_free (ptr);
+      }
+    return (result);
+  }
+}
+
+#else /* not OS2_USE_SUBHEAP_MALLOC */
+
+/* Use malloc.  */
+
+void
+OS2_initialize_malloc (void)
+{
+}
+
+void *
+OS2_malloc_noerror (unsigned int size)
+{
+  return (malloc (size));
+}
+
+void *
+OS2_realloc_noerror (void * ptr, unsigned int size)
+{
+  return (realloc (ptr, size));
+}
+
+void
+OS_free (void * ptr)
+{
+  free (ptr);
+}
+
+#endif /* not OS2_USE_SUBHEAP_MALLOC */
+
 void *
 OS_malloc (unsigned int size)
 {
-  void * result = (malloc (size));
+  void * result = (OS2_malloc_noerror (size));
   if (result == 0)
     OS2_error_system_call (ERROR_NOT_ENOUGH_MEMORY, syscall_malloc);
   return (result);
@@ -46,17 +176,11 @@ OS_malloc (unsigned int size)
 void *
 OS_realloc (void * ptr, unsigned int size)
 {
-  void * result = (realloc (ptr, size));
+  void * result = (OS2_realloc_noerror (ptr, size));
   if (result == 0)
     OS2_error_system_call (ERROR_NOT_ENOUGH_MEMORY, syscall_realloc);
   return (result);
 }
-
-void
-OS_free (void * ptr)
-{
-  free (ptr);
-}
 
 HMTX
 OS2_create_mutex_semaphore (PSZ name, int sharedp)
@@ -197,13 +321,44 @@ OS2_system_variable (ULONG index)
     (dos_query_sys_info, (index, index, (&result), (sizeof (result))));
   return (result);
 }
+
+int
+OS2_essential_thread_p (TID tid)
+{
+  extern TID OS2_pm_tid;
+  extern TID OS2_timer_tid;
+  extern TID OS2_console_tid;
+  return ((tid == OS2_scheme_tid)
+	  || (tid == OS2_pm_tid)
+	  || (tid == OS2_timer_tid)
+	  || (tid == OS2_console_tid));
+}
 
 void
 OS2_logic_error_1 (const char * description,
 		   const char * file,
 		   unsigned int line)
 {
-  outf_fatal ("\nFatal error in file \"%s\", line %d:\n%s\nGet a wizard.\n",
-	      file, line, description);
-  termination_init_error ();
+  extern TID OS2_child_wait_tid;
+  char * format = "%s error in thread %d, file \"%s\", line %d: %s%s\
+  This indicates a bug in the Scheme implementation.\
+  Please report this information to a Scheme wizard.";
+  TID tid = (OS2_current_tid ());
+  if (OS2_essential_thread_p (tid))
+    {
+      outf_fatal (format, "Fatal", tid, file, line, description, "");
+      termination_init_error ();
+    }
+  else
+    {
+      extern void OS2_message_box (const char *, const char *, int);
+      char buffer [1024];
+      sprintf (buffer, format, "Non-fatal", tid, file, line, description,
+	       ((tid == OS2_child_wait_tid)
+		? "  The thread will be killed.\
+  Afterwards, Scheme will not be able to manage subprocesses properly."
+		: "  The thread will be killed."));
+      OS2_message_box ("Scheme Error", buffer, 0);
+      OS2_endthread ();
+    }
 }
diff --git a/v7/src/microcode/os2conio.c b/v7/src/microcode/os2conio.c
index 1ca959dfd..18e32ec04 100644
--- a/v7/src/microcode/os2conio.c
+++ b/v7/src/microcode/os2conio.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2conio.c,v 1.6 1995/04/22 21:06:57 cph Exp $
+$Id: os2conio.c,v 1.7 1995/04/28 07:04:54 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -93,6 +93,8 @@ static qid_t console_writer_qid;
 static channel_context_t * console_context;
 static readahead_buffer_t * line_buffer;
 
+TID OS2_console_tid;
+
 void
 OS2_initialize_console (void)
 {
@@ -115,17 +117,18 @@ OS2_initialize_console (void)
   console_writer_qid = (CHANNEL_CONTEXT_WRITER_QID (console_context));
   OS2_open_qid (console_writer_qid, (OS2_make_std_tqueue ()));
   (CHANNEL_CONTEXT_FIRST_READ_P (console_context)) = 0;
-  (CHANNEL_CONTEXT_TID (console_context))
-    = (OS2_beginthread (console_thread, 0, 0x4000));
+  OS2_console_tid = (OS2_beginthread (console_thread, 0, 0x4000));
+  (CHANNEL_CONTEXT_TID (console_context)) = OS2_console_tid;
 }
 
 static void
 console_thread (void * arg)
 {
+  EXCEPTIONREGISTRATIONRECORD registration;
   grab_console_lock ();
   line_buffer = (OS2_make_readahead_buffer ());
   release_console_lock ();
-  (void) OS2_thread_initialize (console_writer_qid);
+  (void) OS2_thread_initialize ((&registration), console_writer_qid);
   while (1)
     {
       int c = (getch ());
@@ -290,7 +293,7 @@ static void
 send_readahead (msg_t * message)
 {
   OS2_send_message (console_writer_qid, message);
-  OS2_wait_for_readahead_ack (console_writer_qid);
+  (void) OS2_wait_for_readahead_ack (console_writer_qid);
 }
 
 void
diff --git a/v7/src/microcode/os2cthrd.c b/v7/src/microcode/os2cthrd.c
index 7cb446488..553c3964c 100644
--- a/v7/src/microcode/os2cthrd.c
+++ b/v7/src/microcode/os2cthrd.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2cthrd.c,v 1.5 1995/04/21 00:54:49 cph Exp $
+$Id: os2cthrd.c,v 1.6 1995/04/28 07:04:56 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -37,6 +37,7 @@ MIT in each case. */
 #include "os2.h"
 
 static void start_readahead_thread (channel_context_t *);
+static void send_readahead_ack (qid_t, enum readahead_ack_action);
 static msg_list_t * new_list (void);
 static msg_t * new_message (void);
 
@@ -62,16 +63,18 @@ void
 OS2_channel_thread_close (Tchannel channel)
 {
   channel_context_t * context = (CHANNEL_OPERATOR_CONTEXT (channel));
-  /* Closing handle forces input thread to kill itself.  */
-  STD_API_CALL (dos_close, (CHANNEL_HANDLE (channel)));
-  /* Send a readahead ACK, because the thread might be waiting for
-     one, and otherwise it would hang forever.  We could try to
-     determine if it was necessary to send the ACK, but it does no
-     harm to send the ACK when it isn't needed.  */
-  OS2_send_message ((CHANNEL_CONTEXT_READER_QID (context)),
-		    (OS2_make_readahead_ack ()));
+  /* Send a readahead ACK informing the channel thread to kill itself.
+     Then, close our end of the connection -- it's no longer needed.  */
+  send_readahead_ack ((CHANNEL_CONTEXT_READER_QID (context)), raa_close);
   OS2_close_qid (CHANNEL_CONTEXT_READER_QID (context));
   OS_free (context);
+  /* Finally, close the channel handle.  If the channel thread is
+     blocked in dos_read, this will break it out and get it to kill
+     itself.  There's no race, because the channel thread won't try to
+     close the handle, and if it breaks out of dos_read before we do
+     the close, it will see the readahead ACK we just sent and that
+     will kill it.  */
+  STD_API_CALL (dos_close, (CHANNEL_HANDLE (channel)));
 }
 
 qid_t
@@ -95,8 +98,7 @@ start_readahead_thread (channel_context_t * context)
      child process.  */
   if (CHANNEL_CONTEXT_FIRST_READ_P (context))
     {
-      OS2_send_message ((CHANNEL_CONTEXT_READER_QID (context)),
-			(OS2_make_readahead_ack ()));
+      send_readahead_ack ((CHANNEL_CONTEXT_READER_QID (context)), raa_read);
       (CHANNEL_CONTEXT_FIRST_READ_P (context)) = 0;
     }
 }
@@ -125,14 +127,14 @@ OS2_channel_thread_read (Tchannel channel, char * buffer, size_t size)
     return (-1);
   if (OS2_error_message_p (message))
     {
-      OS2_send_message (qid, (OS2_make_readahead_ack ()));
+      send_readahead_ack (qid, raa_read);
       OS2_handle_error_message (message);
     }
   if ((MSG_TYPE (message)) != mt_readahead)
     OS2_logic_error ("Illegal message from channel thread.");
   index = (SM_READAHEAD_INDEX (message));
   if (index == 0)
-    OS2_send_message (qid, (OS2_make_readahead_ack ()));
+    send_readahead_ack (qid, raa_read);
   navail = ((SM_READAHEAD_SIZE (message)) - index);
   if (navail == 0)
     {
@@ -155,12 +157,23 @@ OS2_channel_thread_read (Tchannel channel, char * buffer, size_t size)
     }
 }
 
-void
+static void
+send_readahead_ack (qid_t qid, enum readahead_ack_action action)
+{
+  msg_t * message = (OS2_create_message (mt_readahead_ack));
+  (SM_READAHEAD_ACK_ACTION (message)) = action;
+  OS2_send_message (qid, message);
+}
+
+enum readahead_ack_action
 OS2_wait_for_readahead_ack (qid_t qid)
 {
   /* Wait for an acknowledgement before starting another read.
      This regulates the amount of data in the queue.  */
-  OS2_destroy_message (OS2_wait_for_message (qid, mt_readahead_ack));
+  msg_t * message = (OS2_wait_for_message (qid, mt_readahead_ack));
+  enum readahead_ack_action action = (SM_READAHEAD_ACK_ACTION (message));
+  OS2_destroy_message (message);
+  return (action);
 }
 
 readahead_buffer_t *
diff --git a/v7/src/microcode/os2cthrd.h b/v7/src/microcode/os2cthrd.h
index f59ef09a5..b99048d58 100644
--- a/v7/src/microcode/os2cthrd.h
+++ b/v7/src/microcode/os2cthrd.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2cthrd.h,v 1.3 1995/01/05 23:42:50 cph Exp $
+$Id: os2cthrd.h,v 1.4 1995/04/28 07:04:57 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -64,13 +64,18 @@ typedef struct
 #define SM_READAHEAD_INDEX(m) (((sm_readahead_t *) (m)) -> index)
 #define SM_READAHEAD_DATA(m) (((sm_readahead_t *) (m)) -> data)
 
-#define OS2_make_readahead_ack() OS2_create_message (mt_readahead_ack)
+enum readahead_ack_action { raa_read, raa_close };
 
-typedef msg_t sm_readahead_ack_t;
+typedef struct
+{
+  DECLARE_MSG_HEADER_FIELDS;
+  enum readahead_ack_action action;
+} sm_readahead_ack_t;
+#define SM_READAHEAD_ACK_ACTION(m) (((sm_readahead_ack_t *) (m)) -> action)
 
 extern channel_context_t * OS2_make_channel_context (void);
 extern long OS2_channel_thread_read (Tchannel, char *, size_t);
-extern void OS2_wait_for_readahead_ack (qid_t);
+extern enum readahead_ack_action OS2_wait_for_readahead_ack (qid_t);
 extern void OS2_channel_thread_close (Tchannel);
 
 typedef struct
diff --git a/v7/src/microcode/os2env.c b/v7/src/microcode/os2env.c
index 83e3f65e0..b91308ac3 100644
--- a/v7/src/microcode/os2env.c
+++ b/v7/src/microcode/os2env.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2env.c,v 1.5 1995/04/23 03:16:49 cph Exp $
+$Id: os2env.c,v 1.6 1995/04/28 07:04:58 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -165,26 +165,21 @@ OS_process_clock (void)
 static HEV timer_event;
 static int timer_handle_valid;
 static HTIMER timer_handle;
-static TID timer_tid;
+TID OS2_timer_tid;
 
 static void
 initialize_timer (void)
 {
   timer_event = (OS2_create_event_semaphore (0, 1));
   timer_handle_valid = 0;
-  timer_tid = (OS2_beginthread (timer_thread, 0, 0));
-}
-
-void
-OS2_kill_timer_thread (void)
-{
-  OS2_kill_thread (timer_tid);
+  OS2_timer_tid = (OS2_beginthread (timer_thread, 0, 0));
 }
 
 static void
 timer_thread (void * arg)
 {
-  (void) OS2_thread_initialize (QID_NONE);
+  EXCEPTIONREGISTRATIONRECORD registration;
+  (void) OS2_thread_initialize ((&registration), QID_NONE);
   while (1)
     {
       ULONG count = (OS2_reset_event_semaphore (timer_event));
@@ -299,8 +294,6 @@ OS_set_working_dir_pathname (const char * name)
   extern char * OS2_remove_trailing_backslash (const char *);
   unsigned int length;
   name = (OS2_remove_trailing_backslash (name));
-  /* **** Documentation doesn't clarify whether DosSetCurrentDir will
-     handle the drive prefix correctly or not.  */
   length = (strlen (name));
   if ((length >= 2) && ((name[1]) == ':'))
     {
@@ -308,6 +301,7 @@ OS_set_working_dir_pathname (const char * name)
 	(dos_set_default_disk,
 	 ((name[0]) - ((islower (name[0])) ? 'a' : 'A') + 1));
       name += 2;
+      length -= 2;
     }
-  STD_API_CALL (dos_set_current_dir, ((char *) name));
+  STD_API_CALL (dos_set_current_dir, ((length == 0) ? "\\" : name));
 }
diff --git a/v7/src/microcode/os2io.h b/v7/src/microcode/os2io.h
index 8e39d163a..dd4e71441 100644
--- a/v7/src/microcode/os2io.h
+++ b/v7/src/microcode/os2io.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: os2io.h,v 1.1 1994/11/28 03:42:58 cph Exp $
+$Id: os2io.h,v 1.2 1995/04/28 07:04:59 cph Exp $
 
-Copyright (c) 1994 Massachusetts Institute of Technology
+Copyright (c) 1994-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -67,7 +67,6 @@ struct channel
 };
 
 #define _CHANNEL(c) (OS2_channel_table [(c)])
-#define CHANNEL_POINTER(c) (& (OS2_channel_pointer_table [(c)]))
 #define CHANNEL_HANDLE(c) ((_CHANNEL (c)) . handle)
 #define CHANNEL_OPERATOR(c) ((_CHANNEL (c)) . operator)
 #define CHANNEL_OPERATOR_CONTEXT(c) ((_CHANNEL (c)) . operator_context)
diff --git a/v7/src/microcode/os2msg.c b/v7/src/microcode/os2msg.c
index 9edfdd4d3..95dcdfa12 100644
--- a/v7/src/microcode/os2msg.c
+++ b/v7/src/microcode/os2msg.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2msg.c,v 1.8 1995/04/22 21:48:53 cph Exp $
+$Id: os2msg.c,v 1.9 1995/04/28 07:04:59 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -36,6 +36,8 @@ MIT in each case. */
 
 #include "os2.h"
 
+extern void * OS2_malloc_noerror (unsigned int);
+
 static qid_t allocate_qid (void);
 static void OS2_initialize_message_lengths (void);
 static void write_subqueue (msg_t *);
@@ -294,7 +296,8 @@ OS2_create_message_1 (msg_type_t type, msg_length_t extra)
   /* Do allocation carefully to prevent infinite loop when signalling
      "out of memory" condition.  */
   msg_t * message =
-    (malloc (((unsigned long) (OS2_message_type_length (type))) + extra));
+    (OS2_malloc_noerror (((unsigned long) (OS2_message_type_length (type)))
+			 + extra));
   if (message == 0)
     if ((type == mt_syscall_error)
 	&& ((SM_SYSCALL_ERROR_CODE (message)) == ERROR_NOT_ENOUGH_MEMORY)
diff --git a/v7/src/microcode/os2pipe.c b/v7/src/microcode/os2pipe.c
index 14219f466..9933b3c71 100644
--- a/v7/src/microcode/os2pipe.c
+++ b/v7/src/microcode/os2pipe.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2pipe.c,v 1.5 1995/04/22 21:13:55 cph Exp $
+$Id: os2pipe.c,v 1.6 1995/04/28 07:05:00 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -54,20 +54,27 @@ OS_make_pipe (Tchannel * readerp, Tchannel * writerp)
   transaction_commit ();
 }
 
+typedef struct
+{
+  LHANDLE handle;
+  qid_t qid;
+} thread_arg_t;
+
 void
 OS2_initialize_pipe_channel (Tchannel channel)
 {
   if (CHANNEL_INPUTP (channel))
     {
       channel_context_t * context = (OS2_make_channel_context ());
+      thread_arg_t * arg = (OS_malloc (sizeof (thread_arg_t)));
       (CHANNEL_OPERATOR_CONTEXT (channel)) = context;
       OS2_open_qid ((CHANNEL_CONTEXT_READER_QID (context)), OS2_scheme_tqueue);
       OS2_open_qid
 	((CHANNEL_CONTEXT_WRITER_QID (context)), (OS2_make_std_tqueue ()));
+      (arg -> handle) = (CHANNEL_HANDLE (channel));
+      (arg -> qid) = (CHANNEL_CONTEXT_WRITER_QID (context));
       (CHANNEL_CONTEXT_TID (context))
-	= (OS2_beginthread (input_pipe_thread,
-			    (CHANNEL_POINTER (channel)),
-			    0));
+	= (OS2_beginthread (input_pipe_thread, arg, 0));
       (CHANNEL_OPERATOR (channel)) = input_pipe_operator;
     }
 }
@@ -95,14 +102,13 @@ input_pipe_operator (Tchannel channel, chop_t operation,
 static void
 input_pipe_thread (void * arg)
 {
-  Tchannel channel = (* ((Tchannel *) arg));
-  LHANDLE handle = (CHANNEL_HANDLE (channel));
-  channel_context_t * context = (CHANNEL_OPERATOR_CONTEXT (channel));
-  qid_t qid = (CHANNEL_CONTEXT_WRITER_QID (context));
-  (void) OS2_thread_initialize (qid);
+  LHANDLE handle = (((thread_arg_t *) arg) -> handle);
+  qid_t qid = (((thread_arg_t *) arg) -> qid);
+  EXCEPTIONREGISTRATIONRECORD registration;
+  OS_free (arg);
+  (void) OS2_thread_initialize ((&registration), qid);
   /* Wait for first read request before doing anything.  */
-  OS2_wait_for_readahead_ack (qid);
-  while (1)
+  while ((OS2_wait_for_readahead_ack (qid)) == raa_read)
     {
       msg_t * message = (OS2_make_readahead ());
       ULONG nread;
@@ -120,16 +126,15 @@ input_pipe_thread (void * arg)
       else
 	{
 	  OS2_destroy_message (message);
-	  if ((rc == ERROR_INVALID_HANDLE) || (rc == ERROR_BROKEN_PIPE))
+	  if (rc == ERROR_INVALID_HANDLE)
 	    /* Handle was closed on us -- no need to do anything else.  */
 	    break;
 	  message = (OS2_make_syscall_error (rc, syscall_dos_read));
-	  eofp = 0;
+	  eofp = (rc == ERROR_BROKEN_PIPE);
 	}
       OS2_send_message (qid, message);
       if (eofp)
 	break;
-      OS2_wait_for_readahead_ack (qid);
     }
   {
     tqueue_t * tqueue = (OS2_qid_tqueue (qid));
diff --git a/v7/src/microcode/os2pm.c b/v7/src/microcode/os2pm.c
index edcf3403f..acced5637 100644
--- a/v7/src/microcode/os2pm.c
+++ b/v7/src/microcode/os2pm.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2pm.c,v 1.7 1995/02/21 22:54:15 cph Exp $
+$Id: os2pm.c,v 1.8 1995/04/28 07:05:01 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -793,7 +793,7 @@ static id_table_t psid_table;
 static id_table_t wid_table;
 static id_table_t bid_table;
 static qid_t pm_init_qid;
-static TID pm_tid;
+TID OS2_pm_tid;
 static HAB pm_hab;
 static HMQ pm_hmq;
 static HWND pm_object_window;
@@ -914,7 +914,7 @@ OS2_initialize_pm_thread (void)
     qid_t qid;
     OS2_make_qid_pair ((&pm_init_qid), (&qid));
     OS2_open_qid (qid, OS2_scheme_tqueue);
-    pm_tid = (OS2_beginthread (pm_thread_procedure, 0, 0x4000));
+    OS2_pm_tid = (OS2_beginthread (pm_thread_procedure, 0, 0x4000));
     /* Wait for init message from PM thread.  This message tells us
        that the other end of the connection is established and that it
        is safe to send messages on the connection.  */
@@ -958,9 +958,10 @@ sync_reply (qid_t qid)
 static void
 pm_thread_procedure (void * arg)
 {
+  EXCEPTIONREGISTRATIONRECORD registration;
   QMSG qmsg;
 
-  if ((OS2_thread_initialize (QID_NONE)) != 0)
+  if ((OS2_thread_initialize_1 ((&registration), QID_NONE)) != 0)
     OS2_logic_error ("Error signalled within PM thread.");
   pm_hab = (WinInitialize (0));
   if (pm_hab == NULLHANDLE)
diff --git a/v7/src/microcode/os2proc.c b/v7/src/microcode/os2proc.c
index c02b7e517..b122092b5 100644
--- a/v7/src/microcode/os2proc.c
+++ b/v7/src/microcode/os2proc.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2proc.c,v 1.1 1995/01/06 00:02:45 cph Exp $
+$Id: os2proc.c,v 1.2 1995/04/28 07:05:03 cph Exp $
 
 Copyright (c) 1995 Massachusetts Institute of Technology
 
@@ -86,7 +86,7 @@ static process_t * process_table;
 static unsigned long process_tick;
 static unsigned long sync_tick;
 static HEV start_child_event;
-static TID child_wait_tid;
+TID OS2_child_wait_tid;
 static qid_t child_wait_qid_reader;
 static qid_t child_wait_qid_writer;
 
@@ -128,7 +128,7 @@ OS2_initialize_processes (void)
   start_child_event = (OS2_create_event_semaphore (0, 0));
   OS2_make_qid_pair ((& child_wait_qid_reader), (& child_wait_qid_writer));
   OS2_open_qid (child_wait_qid_reader, OS2_scheme_tqueue);
-  child_wait_tid = (OS2_beginthread (child_wait_thread, 0, 0));
+  OS2_child_wait_tid = (OS2_beginthread (child_wait_thread, 0, 0));
 }
 
 Tprocess
@@ -158,9 +158,12 @@ OS_make_subprocess (const char * filename,
   if (working_directory != 0)
     OS_set_working_dir_pathname (working_directory);
   {
-    Tprocess child = (allocate_process ());
+    Tprocess child;
     char error_object [100];
     RESULTCODES result_codes;
+
+    lock_process_status ();
+    child = (allocate_process ());
     STD_API_CALL
       (dos_exec_pgm,
        (error_object,
@@ -170,7 +173,6 @@ OS_make_subprocess (const char * filename,
 	((envp == 0) ? 0 : (rewrite_environment (envp))),
 	(& result_codes),
 	((PSZ) filename)));
-    lock_process_status ();
     (PROCESS_ID (child)) = (result_codes . codeTerminate);
     (PROCESS_RAW_STATUS (child)) = process_status_running;
     (PROCESS_RAW_REASON (child)) = 0;
@@ -210,7 +212,12 @@ save_process_state (int save_working_dir_p)
   if (valid_handle_p (2))
     (state -> stderr) = (copy_handle (2));
   if (save_working_dir_p)
-    (state -> working_directory) = (OS_working_dir_pathname ());
+    {
+      const char * dir = (OS_working_dir_pathname ());
+      char * copy = (OS_malloc (strlen (dir)));
+      strcpy (copy, dir);
+      (state -> working_directory) = copy;
+    }
   (state -> copied_p) = 1;
 }
 
@@ -239,7 +246,10 @@ restore_process_state (void * env)
       restore_stdio (1, (state -> stdout));
       restore_stdio (2, (state -> stderr));
       if ((state -> working_directory) != 0)
-	OS_set_working_dir_pathname (state -> working_directory);
+	{
+	  OS_set_working_dir_pathname (state -> working_directory);
+	  OS_free ((void *) (state -> working_directory));
+	}
     }
   if ((state -> stdin) != NULLHANDLE)
     (void) dos_close (state -> stdin);
@@ -552,7 +562,8 @@ OS_process_wait (Tprocess process)
 static void
 child_wait_thread (void * arg)
 {
-  (void) OS2_thread_initialize (QID_NONE);
+  EXCEPTIONREGISTRATIONRECORD registration;
+  (void) OS2_thread_initialize ((&registration), QID_NONE);
  main_loop:
   (void) OS2_wait_event_semaphore (start_child_event, 1);
   (void) OS2_reset_event_semaphore (start_child_event);
diff --git a/v7/src/microcode/os2thrd.c b/v7/src/microcode/os2thrd.c
index 157acb8f0..6721904c1 100644
--- a/v7/src/microcode/os2thrd.c
+++ b/v7/src/microcode/os2thrd.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2thrd.c,v 1.2 1995/04/11 05:17:03 cph Exp $
+$Id: os2thrd.c,v 1.3 1995/04/28 07:05:04 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -35,6 +35,11 @@ MIT in each case. */
 #include "os2.h"
 #include "prims.h"
 #include "errors.h"
+
+extern void OS2_create_msg_queue (void);
+extern ULONG APIENTRY OS2_subthread_exception_handler
+  (PEXCEPTIONREPORTRECORD, PEXCEPTIONREGISTRATIONRECORD, PCONTEXTRECORD,
+   PVOID);
 
 TID
 OS2_beginthread (thread_procedure_t procedure,
@@ -61,6 +66,7 @@ OS2_beginthread (thread_procedure_t procedure,
 void
 OS2_endthread (void)
 {
+  DosUnsetExceptionHandler (THREAD_EXCEPTION_HANDLER ());
 #ifdef __IBMC__
   _endthread ();
 #else
@@ -79,7 +85,6 @@ OS2_current_tid (void)
 {
   PTIB ptib;
   PPIB ppib;
-  TID tid;
   STD_API_CALL (dos_get_info_blocks, ((&ptib), (&ppib)));
   return (ptib -> tib_ptib2 -> tib2_ultid);
 }
@@ -102,7 +107,6 @@ PID OS2_scheme_pid;
 TID OS2_scheme_tid;
 
 static void thread_initialize_1 (qid_t);
-static int  thread_initialize_error_hook (void);
 static void restore_errors (void *);
 static void signal_error (msg_t *);
 static void ignore_error (msg_t *);
@@ -126,10 +130,26 @@ OS2_initialize_scheme_thread (void)
 }
 
 int
-OS2_thread_initialize (qid_t error_qid)
+OS2_thread_initialize (PEXCEPTIONREGISTRATIONRECORD registration,
+		       qid_t error_qid)
+{
+  /* Every thread has a message queue, so that we can use message
+     dialogs to report fatal errors to the user.  Otherwise, Scheme
+     will just die with no explanation.  */
+  OS2_create_msg_queue ();
+  return (OS2_thread_initialize_1 (registration, error_qid));
+}
+
+int
+OS2_thread_initialize_1 (PEXCEPTIONREGISTRATIONRECORD registration,
+			 qid_t error_qid)
 {
   thread_initialize_1 (error_qid);
-  return (thread_initialize_error_hook ());
+  (registration -> ExceptionHandler) = OS2_subthread_exception_handler;
+  DosSetExceptionHandler (registration);
+  (THREAD_EXCEPTION_HANDLER ()) = registration;
+  (THREAD_ERROR_HOOK ()) = send_error;
+  return (setjmp (THREAD_ERROR_RESTART ()));
 }
 
 static void
@@ -137,13 +157,21 @@ thread_initialize_1 (qid_t error_qid)
 {
   (* (OS2_threadstore ())) = (OS_malloc (sizeof (thread_store_t)));
   (THREAD_ERROR_QUEUE ()) = error_qid;
+  ((THREAD_FATAL_ERROR_BUFFER ()) [0]) = '\0';
 }
 
-static int
-thread_initialize_error_hook (void)
+char *
+OS2_thread_fatal_error_buffer (void)
 {
-  (THREAD_ERROR_HOOK ()) = send_error;
-  return (setjmp (THREAD_ERROR_RESTART ()));
+  /* The default buffer may get used if an error occurs very early in
+     a thread, before the regular error buffer is allocated.  This can
+     easily happen in the Scheme thread, but shouldn't happen in the
+     other threads.  */
+  static char default_buffer [1024] = "";
+  return
+    (((* (OS2_threadstore ())) == 0)
+     ? default_buffer
+     : (THREAD_FATAL_ERROR_BUFFER ()));
 }
 
 int
diff --git a/v7/src/microcode/os2thrd.h b/v7/src/microcode/os2thrd.h
index 8d9638bfa..5521318cb 100644
--- a/v7/src/microcode/os2thrd.h
+++ b/v7/src/microcode/os2thrd.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2thrd.h,v 1.2 1995/04/11 05:17:11 cph Exp $
+$Id: os2thrd.h,v 1.3 1995/04/28 07:05:05 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -42,11 +42,17 @@ typedef struct
 {
   error_hook_t error_hook;
   jmp_buf error_restart;
+  PEXCEPTIONREGISTRATIONRECORD exception_handler;
   qid_t error_queue;
+  char fatal_error_buffer [1024];
 } thread_store_t;
 #define THREAD_ERROR_HOOK() ((* (OS2_threadstore ())) -> error_hook)
 #define THREAD_ERROR_RESTART() ((* (OS2_threadstore ())) -> error_restart)
 #define THREAD_ERROR_QUEUE() ((* (OS2_threadstore ())) -> error_queue)
+#define THREAD_FATAL_ERROR_BUFFER()					\
+  ((* (OS2_threadstore ())) -> fatal_error_buffer)
+#define THREAD_EXCEPTION_HANDLER()					\
+  ((* (OS2_threadstore ())) -> exception_handler)
 
 typedef struct
 {
@@ -81,7 +87,8 @@ extern thread_store_t ** OS2_threadstore (void);
 extern PID OS2_scheme_pid;
 extern TID OS2_scheme_tid;
 
-extern int  OS2_thread_initialize (qid_t);
+extern int  OS2_thread_initialize (PEXCEPTIONREGISTRATIONRECORD, qid_t);
+extern int  OS2_thread_initialize_1 (PEXCEPTIONREGISTRATIONRECORD, qid_t);
 extern int  OS2_error_message_p (msg_t *);
 extern void OS2_handle_error_message (msg_t *);
 extern void OS2_ignore_errors (void);
diff --git a/v7/src/microcode/os2top.c b/v7/src/microcode/os2top.c
index 21136f560..5bc636095 100644
--- a/v7/src/microcode/os2top.c
+++ b/v7/src/microcode/os2top.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2top.c,v 1.12 1995/03/08 21:37:54 cph Exp $
+$Id: os2top.c,v 1.13 1995/04/28 07:05:06 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -34,6 +34,7 @@ MIT in each case. */
 
 #define SCM_OS2TOP_C
 #include "scheme.h"
+#define INCL_WIN
 #include "os2.h"
 #include "ostop.h"
 #include "option.h"
@@ -45,6 +46,7 @@ extern void OS2_initialize_directory_reader (void);
 extern void OS2_initialize_environment (void);
 extern void OS2_initialize_exception_handling (void);
 extern void OS2_initialize_keyboard_interrupts (void);
+extern void OS2_initialize_malloc (void);
 extern void OS2_initialize_message_queues (void);
 extern void OS2_initialize_pm_thread (void);
 extern void OS2_initialize_processes (void);
@@ -53,6 +55,10 @@ extern void OS2_initialize_tty (void);
 extern void OS2_initialize_window_primitives (void);
 
 extern void OS2_check_message_length_initializations (void);
+extern void * OS2_malloc_noerror (unsigned int);
+extern void * OS2_realloc_noerror (void *, unsigned int);
+
+extern void OS2_create_msg_queue (void); /* forward reference */
 
 extern const char * OS_Name;
 extern const char * OS_Variant;
@@ -60,8 +66,8 @@ extern HMTX OS2_create_queue_lock;
 
 static const char * OS2_version_string (void);
 static void initialize_locks (void);
-static HAB scheme_hab;
-static HMQ scheme_hmq;
+
+static int initialization_completed = 0;
 
 int
 OS_under_emacs_p (void)
@@ -69,19 +75,19 @@ OS_under_emacs_p (void)
   return (option_emacs_subprocess);
 }
 
+void
+OS2_initialize_early (void)
+{
+  initialization_completed = 0;
+  OS2_initialize_malloc ();
+  initialize_locks ();
+  OS2_create_msg_queue ();
+}
+
 void
 OS_initialize (void)
 {
   (void) DosError (FERR_DISABLEEXCEPTION | FERR_DISABLEHARDERR);
-  initialize_locks ();
-  /* Create a PM message queue.  This allows us to use message boxes
-     to report fatal errors.  */
-  scheme_hab = (WinInitialize (0));
-  if (scheme_hab == NULLHANDLE)
-    OS2_logic_error ("Unable to initialize anchor block.");
-  scheme_hmq = (WinCreateMsgQueue (scheme_hab, 0));
-  if (scheme_hmq == NULLHANDLE)
-    OS2_logic_error ("Unable to create PM message queue.");
   OS2_initialize_exception_handling ();
   OS2_initialize_message_queues ();
   OS2_initialize_scheme_thread ();
@@ -95,8 +101,9 @@ OS_initialize (void)
   OS2_initialize_tty ();
   OS2_initialize_window_primitives ();
   OS2_initialize_processes ();
-  /* This must be after all of initializations that can set message
-     lengths.  */
+  initialization_completed = 1;
+  /* This must be after all of the initializations that can set
+     message lengths.  */
   OS2_check_message_length_initializations ();
   OS_Name = "OS/2";
   {
@@ -320,12 +327,38 @@ OS2_commit_heap (unsigned long size)
 
 #endif
 
+void
+OS2_create_msg_queue (void)
+{
+  /* Create a PM message queue.  This allows us to use message boxes
+     to report fatal errors.  */
+  HAB hab = (WinInitialize (0));
+  if (hab == NULLHANDLE)
+    OS2_logic_error ("Unable to initialize anchor block.");
+  if ((WinCreateMsgQueue (hab, 0)) == NULLHANDLE)
+    OS2_logic_error ("Unable to create PM message queue.");
+}
+
+void
+OS2_message_box (const char * title, const char * message, int errorp)
+{
+  (void) WinMessageBox (HWND_DESKTOP,
+			NULLHANDLE,
+			((PSZ) message),
+			((PSZ) title),
+			0,
+			(MB_OK | (errorp ? MB_ERROR : MB_WARNING)));
+}
+
 void
 OS2_exit_scheme (int value)
 {
-  extern void OS2_kill_timer_thread (void);
-  OS2_kill_timer_thread ();
-  OS2_channel_close_all_noerror ();
+  if (initialization_completed)
+    {
+#if 0
+      OS2_channel_close_all_noerror ();
+#endif
+    }
   exit (value);
 }
 
@@ -1651,7 +1684,7 @@ dos_error_message (APIRET rc)
 {
   unsigned int blength_increment = 64;
   unsigned int blength = blength_increment;
-  char * buffer = (malloc (blength));
+  char * buffer = (OS2_malloc_noerror (blength));
   ULONG mlength;
 
   if (buffer == 0)
@@ -1662,20 +1695,20 @@ dos_error_message (APIRET rc)
 	   (0, 0, buffer, blength, rc, "OSO001.MSG", (&mlength)))
 	  != NO_ERROR)
 	{
-	  free (buffer);
+	  OS_free (buffer);
 	  return (0);
 	}
       if (mlength < blength)
 	{
 	  while ((mlength > 0) && (isspace (buffer [mlength - 1])))
 	    mlength -= 1;
-	  buffer = (realloc (buffer, (mlength + 1)));
+	  buffer = (OS2_realloc_noerror (buffer, (mlength + 1)));
 	  if (buffer != 0)
 	    (buffer[mlength]) = '\0';
 	  return (buffer);
 	}
       blength += blength_increment;
-      buffer = (realloc (buffer, (blength)));
+      buffer = (OS2_realloc_noerror (buffer, (blength)));
       if (buffer == 0)
 	return (0);
     }
@@ -1691,7 +1724,7 @@ OS_error_code_to_message (unsigned int syserr)
   if (code == NO_ERROR)
     return (0);
   if (last_message != 0)
-    free ((void *) last_message);
+    OS_free ((void *) last_message);
   last_message = (dos_error_message (code));
   /* Many of OS/2's error messages are terminated with a period, but
      the runtime system is assuming that the messages have no period,
diff --git a/v7/src/microcode/os2xcpt.c b/v7/src/microcode/os2xcpt.c
index 21c2db93b..63ebbc636 100644
--- a/v7/src/microcode/os2xcpt.c
+++ b/v7/src/microcode/os2xcpt.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2xcpt.c,v 1.2 1995/03/08 21:38:49 cph Exp $
+$Id: os2xcpt.c,v 1.3 1995/04/28 07:05:08 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -217,6 +217,7 @@ OS2_exception_handler (PEXCEPTIONREPORTRECORD report,
 	     || ((report -> ExceptionNum) == XCPT_ILLEGAL_INSTRUCTION)
 	     || ((report -> ExceptionNum) == XCPT_INTEGER_DIVIDE_BY_ZERO)
 	     || ((report -> ExceptionNum) == XCPT_INTEGER_OVERFLOW)
+	     || ((report -> ExceptionNum) == XCPT_INVALID_LOCK_SEQUENCE)
 	     || ((report -> ExceptionNum) == XCPT_PRIVILEGED_INSTRUCTION))))
     return (XCPT_CONTINUE_SEARCH);
   exception_number = (report -> ExceptionNum);
@@ -936,3 +937,75 @@ noise_end (const char * title, ULONG style)
     return (rc);
   }
 }
+
+ULONG APIENTRY
+OS2_subthread_exception_handler (PEXCEPTIONREPORTRECORD report,
+				 PEXCEPTIONREGISTRATIONRECORD registration,
+				 PCONTEXTRECORD context,
+				 PVOID dispatcher_context)
+{
+  ULONG exception_number;
+  PTIB ptib;
+  PPIB ppib;
+  TID tid;
+  char * format
+    = "Scheme has detected exception number 0x%08x within thread %d.%s%s\
+  This indicates a bug in the Scheme implementation.\
+  Please report this information to a Scheme wizard.";
+  char backtrace [1024];
+
+  if (((report -> fHandlerFlags)
+       & (EH_UNWINDING | EH_EXIT_UNWIND | EH_STACK_INVALID | EH_NESTED_CALL))
+      != 0)
+    return (XCPT_CONTINUE_SEARCH);
+  exception_number = (report -> ExceptionNum);
+  if (! ((exception_number == XCPT_ACCESS_VIOLATION)
+	 || (exception_number == XCPT_ARRAY_BOUNDS_EXCEEDED)
+	 || (exception_number == XCPT_DATATYPE_MISALIGNMENT)
+	 || (exception_number == XCPT_FLOAT_DENORMAL_OPERAND)
+	 || (exception_number == XCPT_FLOAT_DIVIDE_BY_ZERO)
+	 || (exception_number == XCPT_FLOAT_INEXACT_RESULT)
+	 || (exception_number == XCPT_FLOAT_INVALID_OPERATION)
+	 || (exception_number == XCPT_FLOAT_OVERFLOW)
+	 || (exception_number == XCPT_FLOAT_STACK_CHECK)
+	 || (exception_number == XCPT_FLOAT_UNDERFLOW)
+	 || (exception_number == XCPT_ILLEGAL_INSTRUCTION)
+	 || (exception_number == XCPT_INTEGER_DIVIDE_BY_ZERO)
+	 || (exception_number == XCPT_INTEGER_OVERFLOW)
+	 || (exception_number == XCPT_INVALID_LOCK_SEQUENCE)
+	 || (exception_number == XCPT_PRIVILEGED_INSTRUCTION)))
+    return (XCPT_CONTINUE_SEARCH);
+  (void) dos_get_info_blocks ((&ptib), (&ppib));
+  if (((context -> ContextFlags) & CONTEXT_CONTROL) == 0)
+    (backtrace[0]) = '\0';
+  else
+    {
+      ULONG * ebp = ((ULONG *) (context -> ctx_RegEbp));
+      unsigned int count = 0;
+      sprintf (backtrace, "  (Backtrace:");
+      sprintf ((backtrace + (strlen (backtrace))), " 0x%08x",
+	       (context -> ctx_RegEip));
+      while ((ebp > (ptib -> tib_pstack))
+	     && (ebp < (ptib -> tib_pstacklimit))
+	     && (count < 10))
+	{
+	  sprintf ((backtrace + (strlen (backtrace))), " 0x%08x", (ebp[1]));
+	  ebp = (ebp[0]);
+	}
+      sprintf ((backtrace + (strlen (backtrace))), ")");
+    }
+  tid = (ptib -> tib_ptib2 -> tib2_ultid);
+  if (OS2_essential_thread_p (tid))
+    {
+      outf_fatal (format, exception_number, tid, backtrace, "");
+      termination_init_error ();
+    }
+  else
+    {
+      char buffer [1024];
+      sprintf (buffer, format, exception_number, tid, backtrace,
+	       "  The thread will be killed.");
+      OS2_message_box ("Scheme Error", buffer, 0);
+      OS2_endthread ();
+    }
+}
diff --git a/v7/src/microcode/outf.c b/v7/src/microcode/outf.c
index 80a475733..6c4b3bb1b 100644
--- a/v7/src/microcode/outf.c
+++ b/v7/src/microcode/outf.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: outf.c,v 1.6 1994/12/19 22:26:11 cph Exp $
+$Id: outf.c,v 1.7 1995/04/28 07:05:10 cph Exp $
 
 Copyright (c) 1993-94 Massachusetts Institute of Technology
 
@@ -154,29 +154,25 @@ DEFUN (voutf_master_tty, (chan, format, args),
 #else /* not WINNT */
 #ifdef _OS2
 
-#define INCL_WIN
-#include <os2.h>
+extern char * OS2_thread_fatal_error_buffer (void);
+extern void OS2_message_box (const char *, const char *, int);
 
 #define USE_WINDOWED_OUTPUT
-static char fatal_buffer [1024] = "";
 
 static void
 voutf_fatal (const char * format, va_list args)
 {
-  unsigned int end = (strlen (fatal_buffer));
-  vsprintf ((& (fatal_buffer [end])), format, args);
+  char * buffer = (OS2_thread_fatal_error_buffer ());
+  unsigned int end = (strlen (buffer));
+  vsprintf ((& (buffer [end])), format, args);
 }
 
 static void
 popup_outf_flush_fatal (void)
 {
-  (void) WinMessageBox (HWND_DESKTOP,
-			NULLHANDLE,
-			fatal_buffer,
-			"Scheme Terminating",
-			0,
-			(MB_OK | MB_ERROR));
-  (fatal_buffer[0]) = '\0';
+  char * buffer = (OS2_thread_fatal_error_buffer ());
+  OS2_message_box ("Scheme Terminating", buffer, 1);
+  (buffer[0]) = '\0';
 }
 
 static void
-- 
2.25.1