/* -*-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
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 ();
/* -*-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
#include <ctype.h>
#include "ansidecl.h"
#include "obstack.h"
+#include "outf.h"
#include "config.h"
#include "osenv.h"
#include "osfs.h"
/* -*-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
#include "os2.h"
\f
+/* 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);
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);
-}
\f
HMTX
OS2_create_mutex_semaphore (PSZ name, int sharedp)
(dos_query_sys_info, (index, index, (&result), (sizeof (result))));
return (result);
}
+\f
+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 ();
+ }
}
/* -*-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
static channel_context_t * console_context;
static readahead_buffer_t * line_buffer;
+TID OS2_console_tid;
+
void
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;
}
\f
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 ((®istration), console_writer_qid);
while (1)
{
int c = (getch ());
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);
}
\f
void
/* -*-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
#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);
\f
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
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;
}
}
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)
{
}
}
-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);
}
\f
readahead_buffer_t *
/* -*-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
#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
/* -*-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
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 ((®istration), QID_NONE);
while (1)
{
ULONG count = (OS2_reset_event_semaphore (timer_event));
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]) == ':'))
{
(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));
}
/* -*-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
};
#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)
/* -*-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
#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 *);
/* 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)
/* -*-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
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;
}
}
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 ((®istration), 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;
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));
/* -*-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
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;
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. */
static void
pm_thread_procedure (void * arg)
{
+ EXCEPTIONREGISTRATIONRECORD registration;
QMSG qmsg;
- if ((OS2_thread_initialize (QID_NONE)) != 0)
+ if ((OS2_thread_initialize_1 ((®istration), QID_NONE)) != 0)
OS2_logic_error ("Error signalled within PM thread.");
pm_hab = (WinInitialize (0));
if (pm_hab == NULLHANDLE)
/* -*-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
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;
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));
}
\f
Tprocess
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,
((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;
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;
}
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);
static void
child_wait_thread (void * arg)
{
- (void) OS2_thread_initialize (QID_NONE);
+ EXCEPTIONREGISTRATIONRECORD registration;
+ (void) OS2_thread_initialize ((®istration), QID_NONE);
main_loop:
(void) OS2_wait_event_semaphore (start_child_event, 1);
(void) OS2_reset_event_semaphore (start_child_event);
/* -*-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
#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);
\f
TID
OS2_beginthread (thread_procedure_t procedure,
void
OS2_endthread (void)
{
+ DosUnsetExceptionHandler (THREAD_EXCEPTION_HANDLER ());
#ifdef __IBMC__
_endthread ();
#else
{
PTIB ptib;
PPIB ppib;
- TID tid;
STD_API_CALL (dos_get_info_blocks, ((&ptib), (&ppib)));
return (ptib -> tib_ptib2 -> tib2_ultid);
}
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 *);
}
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
{
(* (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 ()));
}
\f
int
/* -*-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
{
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
{
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);
/* -*-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
#define SCM_OS2TOP_C
#include "scheme.h"
+#define INCL_WIN
#include "os2.h"
#include "ostop.h"
#include "option.h"
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);
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;
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;
\f
int
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 ();
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";
{
#endif
\f
+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);
}
{
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)
(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);
}
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,
/* -*-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
|| ((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);
return (rc);
}
}
+\f
+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 ();
+ }
+}
/* -*-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
#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
projects / mit-scheme.git / commitdiff