--- /dev/null
+/* -*-C-*-
+
+$Id: os2xcpt.c,v 1.1 1994/12/19 22:23:24 cph Exp $
+
+Copyright (c) 1994 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include <stdarg.h>
+#include "scheme.h"
+#include "gccode.h"
+#include "os2.h"
+
+extern int pc_to_utility_index (unsigned long);
+extern int pc_to_builtin_index (unsigned long);
+extern SCHEME_OBJECT * find_constant_space_block (SCHEME_OBJECT *);
+
+extern ULONG C_Stack_Pointer;
+extern ULONG C_Frame_Pointer;
+\f
+typedef enum
+{
+ trap_state_trapped,
+ trap_state_exit,
+ trap_state_suspend,
+ trap_state_recover,
+ trap_state_exitting_soft,
+ trap_state_exitting_hard
+} trap_state_t;
+
+#define STATE_UNKNOWN (LONG_TO_UNSIGNED_FIXNUM (0))
+#define STATE_PRIMITIVE (LONG_TO_UNSIGNED_FIXNUM (1))
+#define STATE_COMPILED_CODE (LONG_TO_UNSIGNED_FIXNUM (2))
+#define STATE_PROBABLY_COMPILED (LONG_TO_UNSIGNED_FIXNUM (3))
+
+typedef struct
+{
+ SCHEME_OBJECT state;
+ SCHEME_OBJECT pc_info_1;
+ SCHEME_OBJECT pc_info_2;
+ SCHEME_OBJECT extra_trap_info;
+} trap_recovery_info_t;
+
+typedef struct
+{
+ ULONG number;
+ const char * name;
+ const char * description;
+} exception_entry_t;
+
+#define PC_ALIGNMENT_MASK ((1 << PC_ZERO_BITS) - 1)
+#define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
+#define FREE_PARANOIA_MARGIN 0x100
+
+#ifdef HAS_COMPILER_SUPPORT
+#define ALLOW_ONLY_C 0
+#else
+#define ALLOW_ONLY_C 1
+#define PLAUSIBLE_CC_BLOCK_P(block) 0
+#endif
+
+static ULONG find_program_end_address (void);
+extern ULONG APIENTRY OS2_exception_handler
+ (PEXCEPTIONREPORTRECORD, PEXCEPTIONREGISTRATIONRECORD, PCONTEXTRECORD,
+ PVOID);
+static void trap_immediate_termination (void);
+static void trap_normal_termination (void);
+static void trap_recover (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD);
+static void continue_from_trap (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD);
+static void do_abort_to_interpreter (void);
+static SCHEME_OBJECT * compiled_code_free (PCONTEXTRECORD);
+static SCHEME_OBJECT * interpreter_free (int force_gc);
+static SCHEME_OBJECT * find_block_address (char *, SCHEME_OBJECT *);
+static SCHEME_OBJECT * find_block_address_in_area (char *, SCHEME_OBJECT *);
+static void setup_trap_frame
+ (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD, trap_recovery_info_t *,
+ SCHEME_OBJECT *);
+static exception_entry_t * find_exception_entry (ULONG);
+static const char * find_exception_name (ULONG);
+static void describe_exception (ULONG, int);
+static int isvowel (char);
+static void noise_start (void);
+static void noise (const char *, ...);
+static USHORT noise_end (const char *, ULONG);
+\f
+static trap_state_t trap_state;
+static trap_state_t user_trap_state;
+static trap_state_t saved_trap_state;
+static ULONG saved_exception_number;
+static ULONG program_end_address;
+
+void
+OS2_initialize_exception_handling (void)
+{
+ trap_state = trap_state_recover;
+ user_trap_state = trap_state_recover;
+ program_end_address = (find_program_end_address ());
+}
+
+static ULONG
+find_program_end_address (void)
+{
+ /* The normal configuration for a C program is for the program text
+ to start at 0x10000 and go up contiguously from there. */
+ ULONG start = 0x10000; /* First 16 pages reserved for OS. */
+ ULONG step = 0x1000; /* 4k page size. */
+ ULONG end = 0x20000000; /* 512M maximum process address space. */
+ ULONG flag_mask
+ = (PAG_FREE | PAG_READ | PAG_WRITE | PAG_EXECUTE | PAG_GUARD
+ | PAG_DEFAULT | PAG_SHARED | PAG_COMMIT);
+ ULONG program_flags /* Permissions for program text pages. */
+ = (PAG_READ | PAG_EXECUTE | PAG_COMMIT);
+ ULONG length = (end - start);
+ ULONG flags;
+ APIRET rc;
+
+ rc = (DosQueryMem (((PVOID) start), (& length), (& flags)));
+ if (! ((rc == NO_ERROR) && ((flags & flag_mask) == program_flags)))
+ OS2_logic_error ("Error reading program text start address.");
+ while (1)
+ {
+ start += length;
+ length = (end - start);
+ rc = (DosQueryMem (((PVOID) start), (& length), (& flags)));
+ if (rc == NO_ERROR)
+ {
+ if ((flags & flag_mask) != program_flags)
+ return (start);
+ }
+ else if (rc == ERROR_INVALID_ADDRESS)
+ return (start);
+ else
+ OS2_logic_error ("Error from DosQueryMem.");
+ }
+}
+
+void
+OS2_enter_interpreter (void (* enter_interpreter) (void))
+{
+ /* This registration record is required to be allocated on the C
+ stack, so we have to use this unusual mechanism to install the
+ trap-handling code. */
+ EXCEPTIONREGISTRATIONRECORD registration;
+ (registration . ExceptionHandler) = OS2_exception_handler;
+ DosSetExceptionHandler (& registration);
+ (* enter_interpreter) ();
+ outf_fatal ("Exception!\n");
+ termination_trap ();
+}
+
+trap_state_t
+OS_set_trap_state (trap_state_t state)
+{
+ trap_state_t old_trap_state = user_trap_state;
+ user_trap_state = state;
+ trap_state = state;
+ return (old_trap_state);
+}
+\f
+ULONG APIENTRY
+OS2_exception_handler (PEXCEPTIONREPORTRECORD report,
+ PEXCEPTIONREGISTRATIONRECORD registration,
+ PCONTEXTRECORD context,
+ PVOID dispatcher_context)
+{
+ trap_state_t old_trap_state;
+ int stack_overflowed_p;
+ ULONG exception_number;
+ int recovery_unlikely_p = 0;
+
+ /* We must ignore EH_NONCONTINUABLE exceptions because in order to
+ do the throw, the registers must be correctly configured for C,
+ and we accomplish this by bashing the context and returning with
+ XCPT_CONTINUE_EXECUTION from here. */
+ if ((((report -> fHandlerFlags)
+ & (EH_UNWINDING | EH_EXIT_UNWIND | EH_STACK_INVALID | EH_NESTED_CALL
+ | EH_NONCONTINUABLE))
+ != 0)
+ || (! (((report -> ExceptionNum) == XCPT_ACCESS_VIOLATION)
+ || ((report -> ExceptionNum) == XCPT_ARRAY_BOUNDS_EXCEEDED)
+ || ((report -> ExceptionNum) == XCPT_DATATYPE_MISALIGNMENT)
+ || ((report -> ExceptionNum) == XCPT_FLOAT_DENORMAL_OPERAND)
+ || ((report -> ExceptionNum) == XCPT_FLOAT_DIVIDE_BY_ZERO)
+ || ((report -> ExceptionNum) == XCPT_FLOAT_INEXACT_RESULT)
+ || ((report -> ExceptionNum) == XCPT_FLOAT_INVALID_OPERATION)
+ || ((report -> ExceptionNum) == XCPT_FLOAT_OVERFLOW)
+ || ((report -> ExceptionNum) == XCPT_FLOAT_STACK_CHECK)
+ || ((report -> ExceptionNum) == XCPT_FLOAT_UNDERFLOW)
+ || ((report -> ExceptionNum) == XCPT_ILLEGAL_INSTRUCTION)
+ || ((report -> ExceptionNum) == XCPT_INTEGER_DIVIDE_BY_ZERO)
+ || ((report -> ExceptionNum) == XCPT_INTEGER_OVERFLOW)
+ || ((report -> ExceptionNum) == XCPT_PRIVILEGED_INSTRUCTION))))
+ return (XCPT_CONTINUE_SEARCH);
+
+ old_trap_state = trap_state;
+ stack_overflowed_p = (STACK_OVERFLOWED_P ());
+
+ if (old_trap_state == trap_state_exitting_hard)
+ _exit (1);
+ if (old_trap_state == trap_state_exitting_soft)
+ trap_immediate_termination ();
+ trap_state = trap_state_trapped;
+
+ exception_number = (report -> ExceptionNum);
+ noise_start ();
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ noise ("Scheme has detected ");
+ describe_exception (exception_number, 0);
+ noise (" within critical section \"%s\". ", (CRITICAL_SECTION_NAME ()));
+ }
+ else if (stack_overflowed_p || (old_trap_state != trap_state_recover))
+ {
+ noise ("Scheme has detected ");
+ describe_exception (exception_number, 0);
+ noise (". ");
+ }
+ if (stack_overflowed_p)
+ {
+ noise ("The stack has overflowed overwriting adjacent memory. ");
+ noise ("This was probably caused by a runaway recursion. ");
+ }
+
+ switch (old_trap_state)
+ {
+ case trap_state_recover:
+ if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p)
+ {
+ noise ("Successful recovery is unlikely. ");
+ recovery_unlikely_p = 1;
+ break;
+ }
+ saved_trap_state = old_trap_state;
+ saved_exception_number = exception_number;
+ (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
+ trap_recover (report, context);
+ return (XCPT_CONTINUE_EXECUTION);
+
+ case trap_state_trapped:
+ if (saved_trap_state == trap_state_recover)
+ {
+ noise ("This occurred while attempting to recover from ");
+ describe_exception (saved_exception_number, 1);
+ noise (". Successful recovery is ");
+ if (WITHIN_CRITICAL_SECTION_P ())
+ noise ("extremely ");
+ noise ("unlikely. ");
+ recovery_unlikely_p = 1;
+ break;
+ }
+ (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
+ trap_immediate_termination ();
+ break;
+
+ case trap_state_exit:
+ (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
+ termination_trap ();
+ break;
+ }
+
+ noise ("\n\n");
+ saved_trap_state = old_trap_state;
+ saved_exception_number = exception_number;
+ {
+ int first_query = 1;
+ while (1)
+ {
+ noise ("Attempt recovery?");
+ if ((noise_end
+ ("Recovery Choice",
+ (MB_YESNO
+ | (first_query ? MB_ERROR : 0)
+ | (recovery_unlikely_p ? MB_DEFBUTTON2 : MB_DEFBUTTON1))))
+ == MBID_YES)
+ {
+ trap_recover (report, context);
+ return (XCPT_CONTINUE_EXECUTION);
+ }
+ else
+ {
+ first_query = 0;
+ noise ("Terminate Scheme normally? ");
+ noise ("Selecting \"No\" terminates Scheme immediately ");
+ noise ("(without cleanup). Selecting \"Cancel\" returns to ");
+ noise ("Recovery Choice dialog.");
+ switch (noise_end ("Termination Choices", (MB_YESNOCANCEL)))
+ {
+ case MBID_YES:
+ trap_normal_termination ();
+ break;
+ case MBID_NO:
+ trap_immediate_termination ();
+ _exit (1);
+ break;
+ }
+ }
+ }
+ }
+ return (XCPT_CONTINUE_SEARCH);
+}
+
+static void
+trap_immediate_termination (void)
+{
+ extern void EXFUN (OS_restore_external_state, (void));
+ trap_state = trap_state_exitting_hard;
+ OS_restore_external_state ();
+ exit (1);
+}
+
+static void
+trap_normal_termination (void)
+{
+ trap_state = trap_state_exitting_soft;
+ termination_trap ();
+}
+\f
+static void
+trap_recover (PEXCEPTIONREPORTRECORD report, PCONTEXTRECORD context)
+{
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ CLEAR_CRITICAL_SECTION_HOOK ();
+ EXIT_CRITICAL_SECTION ({});
+ }
+ continue_from_trap (report, context);
+}
+\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;
+ 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. */
+
+static void
+continue_from_trap (PEXCEPTIONREPORTRECORD report, PCONTEXTRECORD context)
+{
+ ULONG pc;
+ enum
+ {
+ pc_in_hyperspace,
+ pc_in_c,
+ pc_in_primitive,
+ pc_in_utility,
+ pc_in_builtin,
+ pc_in_heap
+ } pc_location;
+
+ SCHEME_OBJECT * block_address;
+ trap_recovery_info_t trinfo;
+ SCHEME_OBJECT * new_sp;
+
+ /* Punt if the context doesn't contain the registers we need to see. */
+ if (((context -> ContextFlags) & CONTEXT_CONTROL) == 0)
+ {
+ (trinfo . state) = STATE_UNKNOWN;
+ (trinfo . pc_info_1) = SHARP_F;
+ (trinfo . pc_info_2) = SHARP_F;
+ (trinfo . extra_trap_info) = SHARP_F;
+ Free = (interpreter_free (1));
+ new_sp = 0;
+ goto done;
+ }
+
+ /* Classify the PC location. */
+ pc = (context -> ctx_RegEip);
+ if ((pc & PC_ALIGNMENT_MASK) != 0)
+ pc_location = pc_in_hyperspace;
+ else if (pc <= program_end_address)
+ {
+ if ((pc_to_builtin_index (pc)) != (-1))
+ pc_location = pc_in_builtin;
+ else if ((pc_to_utility_index (pc)) != (-1))
+ pc_location = pc_in_utility;
+ else if (PRIMITIVE_P (Regs [REGBLOCK_PRIMITIVE]))
+ pc_location = pc_in_primitive;
+ else
+ pc_location = pc_in_c;
+ }
+ else if (ALLOW_ONLY_C)
+ pc_location = pc_in_hyperspace;
+ else if ((((ULONG) Heap_Bottom) <= pc) && (pc < ((ULONG) Heap_Top)))
+ {
+ pc_location = pc_in_heap;
+ block_address = (find_block_address (((void *) pc), Heap_Bottom));
+ }
+ else if ((((ULONG) Constant_Space) <= pc) && (pc < ((ULONG) Constant_Top)))
+ {
+ pc_location = pc_in_heap;
+ block_address = (find_block_address (((void *) pc), Constant_Space));
+ }
+ else
+ pc_location = pc_in_hyperspace;
+
+ /* Find Scheme's stack pointer. */
+ switch (pc_location)
+ {
+ case pc_in_builtin:
+ case pc_in_heap:
+ new_sp = ((SCHEME_OBJECT *) (context -> ctx_RegEsp));
+ break;
+ case pc_in_utility:
+ case pc_in_primitive:
+ case pc_in_c:
+ new_sp = Stack_Pointer;
+ break;
+ default:
+ new_sp = 0;
+ break;
+ }
+ if (! ((Stack_Bottom <= new_sp)
+ && (new_sp < Stack_Top)
+ && ((((ULONG) new_sp) & SCHEME_ALIGNMENT_MASK) == 0)))
+ new_sp = 0;
+
+ /* Build the trinfo structure. */
+ switch (pc_location)
+ {
+ case pc_in_heap:
+ if (block_address != 0)
+ {
+ (trinfo . state) = STATE_COMPILED_CODE;
+ (trinfo . pc_info_1)
+ = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_address));
+ (trinfo . pc_info_2)
+ = (LONG_TO_UNSIGNED_FIXNUM (pc - ((ULONG) block_address)));
+ }
+ else
+ {
+ (trinfo . state) = STATE_PROBABLY_COMPILED;
+ (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (pc));
+ (trinfo . pc_info_2) = SHARP_F;
+ }
+ Free = (compiled_code_free (context));
+ break;
+ case pc_in_builtin:
+ (trinfo . state) = STATE_PROBABLY_COMPILED;
+ (trinfo . pc_info_1)
+ = (LONG_TO_UNSIGNED_FIXNUM (pc_to_builtin_index (pc)));
+ (trinfo . pc_info_2) = SHARP_T;
+ Free = (compiled_code_free (context));
+ break;
+ case pc_in_utility:
+ (trinfo . state) = STATE_PROBABLY_COMPILED;
+ (trinfo . pc_info_1)
+ = (LONG_TO_UNSIGNED_FIXNUM (pc_to_utility_index (pc)));
+ (trinfo . pc_info_2) = UNSPECIFIC;
+ Free = ((new_sp == 0) ? MemTop : (interpreter_free (0)));
+ break;
+ case pc_in_primitive:
+ (trinfo . state) = STATE_PRIMITIVE;
+ (trinfo . pc_info_1) = (Regs [REGBLOCK_PRIMITIVE]);
+ (trinfo . pc_info_2)
+ = (LONG_TO_UNSIGNED_FIXNUM (Regs [REGBLOCK_LEXPR_ACTUALS]));
+ Free = ((new_sp == 0) ? MemTop : (interpreter_free (0)));
+ break;
+ default:
+ (trinfo . state) = STATE_UNKNOWN;
+ (trinfo . pc_info_1) = SHARP_F;
+ (trinfo . pc_info_2) = SHARP_F;
+ Free = (interpreter_free (1));
+ break;
+ }
+ {
+ SCHEME_OBJECT v
+ = (allocate_non_marked_vector
+ (TC_NON_MARKED_VECTOR,
+ ((((context -> ContextFlags) & CONTEXT_INTEGER) == 0) ? 4 : 10),
+ 0));
+ /* First two elements of vector must be PC and SP, in that order. */
+ VECTOR_SET (v, 0, ((SCHEME_OBJECT) (context -> ctx_RegEip)));
+ VECTOR_SET (v, 1, ((SCHEME_OBJECT) (context -> ctx_RegEsp)));
+ VECTOR_SET (v, 2, ((SCHEME_OBJECT) (context -> ctx_RegEbp)));
+ VECTOR_SET (v, 3, ((SCHEME_OBJECT) (context -> ctx_EFlags)));
+ if (((context -> ContextFlags) & CONTEXT_INTEGER) != 0)
+ {
+ VECTOR_SET (v, 4, ((SCHEME_OBJECT) (context -> ctx_RegEdi)));
+ VECTOR_SET (v, 5, ((SCHEME_OBJECT) (context -> ctx_RegEsi)));
+ VECTOR_SET (v, 6, ((SCHEME_OBJECT) (context -> ctx_RegEax)));
+ VECTOR_SET (v, 7, ((SCHEME_OBJECT) (context -> ctx_RegEbx)));
+ VECTOR_SET (v, 8, ((SCHEME_OBJECT) (context -> ctx_RegEcx)));
+ VECTOR_SET (v, 9, ((SCHEME_OBJECT) (context -> ctx_RegEdx)));
+ }
+ (trinfo . extra_trap_info) = v;
+ }
+ done:
+ setup_trap_frame (report, context, (& trinfo), new_sp);
+
+ /* If this was a hardware-generated floating-point exception, clear
+ the corresponding bit in the processor status word. Otherwise
+ the exception will be resignalled when we restart. */
+ if (((context -> ContextFlags) & CONTEXT_FLOATING_POINT) != 0)
+ switch (report -> ExceptionNum)
+ {
+ case XCPT_FLOAT_DENORMAL_OPERAND:
+ ((context -> ctx_env) [1]) &=~ 0x02;
+ break;
+ case XCPT_FLOAT_DIVIDE_BY_ZERO:
+ ((context -> ctx_env) [1]) &=~ 0x04;
+ break;
+ case XCPT_FLOAT_INEXACT_RESULT:
+ ((context -> ctx_env) [1]) &=~ 0x20;
+ break;
+ case XCPT_FLOAT_INVALID_OPERATION:
+ ((context -> ctx_env) [1]) &=~ 0x01;
+ break;
+ case XCPT_FLOAT_OVERFLOW:
+ ((context -> ctx_env) [1]) &=~ 0x08;
+ break;
+ case XCPT_FLOAT_UNDERFLOW:
+ ((context -> ctx_env) [1]) &=~ 0x10;
+ break;
+ }
+ /* Now attempt to continue. This requires some trickery if the
+ registers are configured for Scheme compiled code, because
+ longjmp will fail unless the stack and frame pointers are set up
+ for C. This is because of error checking that is built in to the
+ OS/2 exception handling mechanism: it checks the stack pointer to
+ make sure that the exception-handler registration records are on
+ the stack. */
+ if (! ((pc_location == pc_in_builtin) || (pc_location == pc_in_heap)))
+ abort_to_interpreter (PRIM_APPLY);
+ (context -> ctx_RegEsp) = C_Stack_Pointer;
+ (context -> ctx_RegEbp) = C_Frame_Pointer;
+ (context -> ctx_RegEip) = ((ULONG) do_abort_to_interpreter);
+}
+
+static void
+do_abort_to_interpreter (void)
+{
+ abort_to_interpreter (PRIM_APPLY);
+}
+
+static SCHEME_OBJECT *
+compiled_code_free (PCONTEXTRECORD context)
+{
+ if (((context -> ContextFlags) & CONTEXT_INTEGER) != 0)
+ {
+ ULONG edi = (context -> ctx_RegEdi);
+ if (((edi & SCHEME_ALIGNMENT_MASK) == 0)
+ && (((ULONG) Heap_Bottom) <= edi)
+ && (edi < ((ULONG) Heap_Top)))
+ return (((SCHEME_OBJECT *) edi) + FREE_PARANOIA_MARGIN);
+ }
+ return (interpreter_free (1));
+}
+
+static SCHEME_OBJECT *
+interpreter_free (int force_gc)
+{
+ return
+ ((((force_gc ? MemTop : Heap_Bottom) <= Free)
+ && (Free < Heap_Top)
+ && ((((ULONG) Free) & SCHEME_ALIGNMENT_MASK) == 0))
+ ? (((Free + FREE_PARANOIA_MARGIN) < MemTop)
+ ? (Free + FREE_PARANOIA_MARGIN)
+ : (Free < MemTop)
+ ? MemTop
+ : Free)
+ : MemTop);
+}
+\f
+/* Find the compiled code block in area which contains `pc_value'.
+ This attempts to be more efficient than `find_block_address_in_area'.
+ If the pointer is in the heap, it can actually do twice as
+ much work, but it is expected to pay off on the average. */
+
+#define MINIMUM_SCAN_RANGE 2048
+
+static SCHEME_OBJECT *
+find_block_address (char * pc_value, SCHEME_OBJECT * area_start)
+{
+ if (area_start == Constant_Space)
+ {
+ SCHEME_OBJECT * constant_block =
+ (find_constant_space_block
+ ((SCHEME_OBJECT *)
+ (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK)));
+ return
+ ((constant_block == 0)
+ ? 0
+ : (find_block_address_in_area (pc_value, constant_block)));
+ }
+ {
+ SCHEME_OBJECT * nearest_word =
+ ((SCHEME_OBJECT *)
+ (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
+ long maximum_distance = (nearest_word - area_start);
+ long distance = maximum_distance;
+ while ((distance / 2) > MINIMUM_SCAN_RANGE)
+ distance = (distance / 2);
+ while ((distance * 2) < maximum_distance)
+ {
+ SCHEME_OBJECT * block =
+ (find_block_address_in_area (pc_value, (nearest_word - distance)));
+ if (block != 0)
+ return (block);
+ distance *= 2;
+ }
+ }
+ return (find_block_address_in_area (pc_value, area_start));
+}
+\f
+/* Find the compiled code block in area which contains `pc_value', by
+ scanning sequentially the complete area. For the time being, skip
+ over manifest closures and linkage sections. */
+
+static SCHEME_OBJECT *
+find_block_address_in_area (char * pc_value, SCHEME_OBJECT * area_start)
+{
+ SCHEME_OBJECT * first_valid = area_start;
+ SCHEME_OBJECT * area = area_start;
+ while (((char *) area) < pc_value)
+ {
+ SCHEME_OBJECT object = (*area);
+ switch (OBJECT_TYPE (object))
+ {
+ case TC_LINKAGE_SECTION:
+ switch (READ_LINKAGE_KIND (object))
+ {
+ case GLOBAL_OPERATOR_LINKAGE_KIND:
+ case OPERATOR_LINKAGE_KIND:
+ {
+ long count = (READ_OPERATOR_LINKAGE_COUNT (object));
+ area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
+ }
+ break;
+ case ASSIGNMENT_LINKAGE_KIND:
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ case REFERENCE_LINKAGE_KIND:
+ default:
+ area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
+ break;
+ }
+ break;
+ case TC_MANIFEST_CLOSURE:
+ area += 1;
+ {
+ long count = (MANIFEST_CLOSURE_COUNT (area));
+ area = ((MANIFEST_CLOSURE_END (area, count)) + 1);
+ }
+ break;
+ case TC_MANIFEST_NM_VECTOR:
+ {
+ long count = (OBJECT_DATUM (object));
+ if (((char *) (area + (count + 1))) < pc_value)
+ {
+ area += (count + 1);
+ first_valid = area;
+ break;
+ }
+ {
+ SCHEME_OBJECT * block = (area - 1);
+ return
+ (((area == first_valid)
+ || ((OBJECT_TYPE (* block)) != TC_MANIFEST_VECTOR)
+ || ((OBJECT_DATUM (* block)) < ((unsigned long) (count + 1)))
+ || (! (PLAUSIBLE_CC_BLOCK_P (block))))
+ ? 0
+ : block);
+ }
+ }
+ default:
+ area += 1;
+ break;
+ }
+ }
+ return (0);
+}
+\f
+static void
+setup_trap_frame (PEXCEPTIONREPORTRECORD report,
+ PCONTEXTRECORD context,
+ trap_recovery_info_t * trinfo,
+ SCHEME_OBJECT * new_sp)
+{
+ long saved_mask;
+ SCHEME_OBJECT handler;
+ SCHEME_OBJECT trap_name;
+
+ /* Disable interrupts while building stack frame. */
+ saved_mask = (FETCH_INTERRUPT_MASK ());
+ SET_INTERRUPT_MASK (0);
+
+ /* Get the trap handler -- lose if there isn't one. */
+ handler
+ = ((Valid_Fixed_Obj_Vector ())
+ ? (Get_Fixed_Obj_Slot (Trap_Handler))
+ : SHARP_F);
+ if (handler == SHARP_F)
+ {
+ noise_start ();
+ noise ("There is no trap handler for recovery!\n");
+ noise ("This occurred during ");
+ describe_exception ((report -> ExceptionNum), 0);
+ noise (".\n");
+ noise ("pc = 0x%08x; sp = 0x%08x.\n",
+ (context -> ctx_RegEip), (context -> ctx_RegEsp));
+ (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
+ termination_trap ();
+ }
+
+ /* Set the GC interrupt bit if necessary. */
+ if (Free >= MemTop)
+ Request_GC (0);
+
+ /* Make sure the stack is correctly initialized. */
+ if (new_sp != 0)
+ Stack_Pointer = new_sp;
+ else
+ {
+ INITIALIZE_STACK ();
+ Will_Push (CONTINUATION_SIZE);
+ Store_Return (RC_END_OF_COMPUTATION);
+ Store_Expression (SHARP_F);
+ Save_Cont ();
+ Pushed ();
+ }
+ {
+ const char * name = (find_exception_name (report -> ExceptionNum));
+ trap_name
+ = ((name == 0) ? SHARP_F : (char_pointer_to_string ((char *) name)));
+ }
+ /* Push the hardware-trap stack frame. The continuation parser will
+ find this and use it to present meaningful debugging information
+ to the user. */
+ Will_Push (7 + CONTINUATION_SIZE);
+ STACK_PUSH (trinfo -> extra_trap_info);
+ STACK_PUSH (trinfo -> pc_info_2);
+ STACK_PUSH (trinfo -> pc_info_1);
+ STACK_PUSH (trinfo -> state);
+ STACK_PUSH (BOOLEAN_TO_OBJECT (new_sp != 0));
+ STACK_PUSH (long_to_integer (report -> ExceptionNum));
+ STACK_PUSH (trap_name);
+ Store_Return (RC_HARDWARE_TRAP);
+ Store_Expression (UNSPECIFIC);
+ Save_Cont ();
+ Pushed ();
+
+ /* Make sure the history register is properly initialized. */
+ if ((new_sp != 0) && ((trinfo -> state) == STATE_COMPILED_CODE))
+ Stop_History ();
+ History = (Make_Dummy_History ());
+
+ /* Push the call frame for the trap handler. */
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
+ STACK_PUSH (trap_name);
+ STACK_PUSH (handler);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
+ Pushed ();
+
+ /* Restore the interrupt mask and call the handler. */
+ SET_INTERRUPT_MASK (saved_mask);
+}
+\f
+#define EXCEPTION_ENTRY(name, description) { name, #name, description }
+static exception_entry_t exception_names [] =
+{
+ EXCEPTION_ENTRY (XCPT_ACCESS_VIOLATION, "access violation"),
+ EXCEPTION_ENTRY (XCPT_ARRAY_BOUNDS_EXCEEDED, "array bounds exceeded"),
+ EXCEPTION_ENTRY (XCPT_ASYNC_PROCESS_TERMINATE, "async process terminate"),
+ EXCEPTION_ENTRY (XCPT_B1NPX_ERRATA_02, "B1NPX errata"),
+ EXCEPTION_ENTRY (XCPT_BAD_STACK, "bad stack"),
+ EXCEPTION_ENTRY (XCPT_BREAKPOINT, "breakpoint"),
+ EXCEPTION_ENTRY (XCPT_DATATYPE_MISALIGNMENT, "data type misalignment"),
+ EXCEPTION_ENTRY (XCPT_FLOAT_DENORMAL_OPERAND,
+ "floating point denormal operand"),
+ EXCEPTION_ENTRY (XCPT_FLOAT_DIVIDE_BY_ZERO, "floating point divide by zero"),
+ EXCEPTION_ENTRY (XCPT_FLOAT_INEXACT_RESULT, "floating point inexact result"),
+ EXCEPTION_ENTRY (XCPT_FLOAT_INVALID_OPERATION,
+ "floating point invalid operation"),
+ EXCEPTION_ENTRY (XCPT_FLOAT_OVERFLOW, "floating point overflow"),
+ EXCEPTION_ENTRY (XCPT_FLOAT_STACK_CHECK, "floating point stack check"),
+ EXCEPTION_ENTRY (XCPT_FLOAT_UNDERFLOW, "floating point underflow"),
+ EXCEPTION_ENTRY (XCPT_GUARD_PAGE_VIOLATION, "guard page violation"),
+ EXCEPTION_ENTRY (XCPT_ILLEGAL_INSTRUCTION, "illegal instruction"),
+ EXCEPTION_ENTRY (XCPT_INTEGER_DIVIDE_BY_ZERO, "integer divide by zero"),
+ EXCEPTION_ENTRY (XCPT_INTEGER_OVERFLOW, "integer overflow"),
+ EXCEPTION_ENTRY (XCPT_INVALID_DISPOSITION, "invalid disposition"),
+ EXCEPTION_ENTRY (XCPT_INVALID_LOCK_SEQUENCE, "invalid lock sequence"),
+ EXCEPTION_ENTRY (XCPT_INVALID_UNWIND_TARGET, "invalid unwind target"),
+ EXCEPTION_ENTRY (XCPT_IN_PAGE_ERROR, "in-page error"),
+ EXCEPTION_ENTRY (XCPT_NONCONTINUABLE_EXCEPTION, "noncontinuable exception"),
+ EXCEPTION_ENTRY (XCPT_PRIVILEGED_INSTRUCTION, "privileged instruction"),
+ EXCEPTION_ENTRY (XCPT_PROCESS_TERMINATE, "process terminate"),
+ EXCEPTION_ENTRY (XCPT_SIGNAL, "signal"),
+ EXCEPTION_ENTRY (XCPT_SINGLE_STEP, "single step"),
+ EXCEPTION_ENTRY (XCPT_UNABLE_TO_GROW_STACK, "unable to grow stack"),
+ EXCEPTION_ENTRY (XCPT_UNWIND, "unwind")
+};
+
+static exception_entry_t *
+find_exception_entry (ULONG exception_number)
+{
+ unsigned int i = 0;
+ unsigned int end
+ = ((sizeof (exception_names)) / (sizeof (exception_entry_t)));
+ while (i < end)
+ {
+ if (exception_number == ((exception_names [i]) . number))
+ return (& (exception_names [i]));
+ i += 1;
+ }
+ return (0);
+}
+
+static const char *
+find_exception_name (ULONG exception_number)
+{
+ exception_entry_t * entry = (find_exception_entry (exception_number));
+ return ((entry == 0) ? 0 : (entry -> name));
+}
+
+static void
+describe_exception (ULONG exception_number, int earlierp)
+{
+ exception_entry_t * entry = (find_exception_entry (exception_number));
+ const char * prefix = (earlierp ? "earlier " : "");
+ if (entry == 0)
+ noise ("an %sunknown exception [code = %d]", prefix, exception_number);
+ else
+ noise ("a%s %s%s exception",
+ ((earlierp || (isvowel ((entry -> description) [0]))) ? "n" : ""),
+ prefix,
+ (entry -> description));
+}
+
+static int
+isvowel (char c)
+{
+ return
+ ((c == 'a') || (c == 'e') || (c == 'i') || (c == 'o') || (c == 'u')
+ || (c == 'A') || (c == 'E') || (c == 'I') || (c == 'O') || (c == 'U'));
+}
+\f
+static char * noise_accumulator;
+static char * noise_accumulator_position;
+
+static void
+noise_start (void)
+{
+ noise_accumulator = 0;
+ noise_accumulator_position = 0;
+}
+
+static void
+noise (const char * format, ...)
+{
+ unsigned int index = (noise_accumulator_position - noise_accumulator);
+ noise_accumulator
+ = ((noise_accumulator == 0)
+ ? (OS_malloc (256))
+ : (OS_realloc (noise_accumulator, (index + 256))));
+ noise_accumulator_position = (noise_accumulator + index);
+ {
+ va_list arg_pointer;
+ va_start (arg_pointer, format);
+ noise_accumulator_position
+ += (vsprintf (noise_accumulator_position, format, arg_pointer));
+ va_end (arg_pointer);
+ }
+}
+
+static USHORT
+noise_end (const char * title, ULONG style)
+{
+ if (noise_accumulator == 0)
+ return (MBID_YES);
+ {
+ USHORT rc
+ = (WinMessageBox (HWND_DESKTOP,
+ NULLHANDLE, /* client window handle */
+ noise_accumulator,
+ ((char *) title),
+ 0,
+ style));
+ OS_free (noise_accumulator);
+ noise_accumulator = 0;
+ noise_accumulator_position = 0;
+ return (rc);
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Id: pros2pm.c,v 1.1 1994/12/19 22:23:24 cph Exp $
+
+Copyright (c) 1994 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "scheme.h"
+#include "prims.h"
+#define INCL_WIN
+#include "os2.h"
+\f
+static qid_t pm_qid;
+static qid_t event_qid_local;
+static qid_t event_qid_remote;
+
+static wid_t
+wid_argument (unsigned int arg_number)
+{
+ unsigned long result = (arg_nonnegative_integer (arg_number));
+ if (!OS2_wid_validp (result))
+ error_bad_range_arg (arg_number);
+ return (result);
+}
+
+static short
+short_arg (unsigned int arg_number)
+{
+ long result = (arg_integer (arg_number));
+ if (! ((-32768 <= result) && (result < 32768)))
+ error_bad_range_arg (arg_number);
+ return (result);
+}
+
+#define SHORT_ARG short_arg
+#define USHORT_ARG(n) arg_index_integer ((n), 0x10000)
+
+static unsigned short
+dimension_arg (unsigned int arg_number)
+{
+ unsigned short result = (USHORT_ARG (arg_number));
+ if (result == 0)
+ error_bad_range_arg (arg_number);
+ return (result);
+}
+
+#define COORDINATE_ARG USHORT_ARG
+#define DIMENSION_ARG dimension_arg
+
+void
+OS2_initialize_window_primitives (void)
+{
+ pm_qid = (OS2_create_pm_qid (OS2_scheme_tqueue));
+ OS2_make_qid_pair ((&event_qid_local), (&event_qid_remote));
+ OS2_open_qid (event_qid_local, OS2_scheme_tqueue);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-BEEP", Prim_OS2_window_beep, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ DosBeep ((arg_nonnegative_integer (1)), (arg_nonnegative_integer (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-OPEN", Prim_OS2_window_open, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (long_to_integer (OS2_window_open (pm_qid,
+ event_qid_remote,
+ (STRING_ARG (1)))));
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-CLOSE", Prim_OS2_window_close, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ OS2_window_close (wid_argument (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SHOW", Prim_OS2_window_show, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ OS2_window_show ((wid_argument (1)), (BOOLEAN_ARG (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-WRITE", Prim_OS2_window_write, 6, 6, 0)
+{
+ PRIMITIVE_HEADER (6);
+ CHECK_ARG (4, STRING_P);
+ {
+ SCHEME_OBJECT string = (ARG_REF (4));
+ unsigned long start = (arg_nonnegative_integer (5));
+ unsigned long end = (arg_nonnegative_integer (6));
+ if (end > (STRING_LENGTH (string)))
+ error_bad_range_arg (6);
+ if (start > end)
+ error_bad_range_arg (5);
+ OS2_window_write ((wid_argument (1)),
+ (COORDINATE_ARG (2)),
+ (COORDINATE_ARG (3)),
+ (STRING_LOC (string, start)),
+ (end - start));
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-MOVE-CURSOR", Prim_OS2_window_move_cursor, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ OS2_window_move_cursor ((wid_argument (1)),
+ (COORDINATE_ARG (2)),
+ (COORDINATE_ARG (3)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SHAPE-CURSOR", Prim_OS2_window_shape_cursor, 4, 4, 0)
+{
+ PRIMITIVE_HEADER (4);
+ OS2_window_shape_cursor ((wid_argument (1)),
+ (DIMENSION_ARG (2)),
+ (DIMENSION_ARG (3)),
+ (arg_nonnegative_integer (4)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SHOW-CURSOR", Prim_OS2_window_show_cursor, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ OS2_window_show_cursor ((wid_argument (1)), (BOOLEAN_ARG (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-CLEAR", Prim_OS2_window_clear, 5, 5, 0)
+{
+ PRIMITIVE_HEADER (5);
+ OS2_window_clear ((wid_argument (1)),
+ (COORDINATE_ARG (2)),
+ (COORDINATE_ARG (3)),
+ (COORDINATE_ARG (4)),
+ (COORDINATE_ARG (5)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SCROLL", Prim_OS2_window_scroll, 7, 7, 0)
+{
+ PRIMITIVE_HEADER (7);
+ OS2_window_scroll ((wid_argument (1)),
+ (COORDINATE_ARG (2)),
+ (COORDINATE_ARG (3)),
+ (COORDINATE_ARG (4)),
+ (COORDINATE_ARG (5)),
+ (SHORT_ARG (6)),
+ (SHORT_ARG (7)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-INVALIDATE", Prim_OS2_window_invalidate, 5, 5, 0)
+{
+ PRIMITIVE_HEADER (5);
+ OS2_window_invalidate ((wid_argument (1)),
+ (COORDINATE_ARG (2)),
+ (COORDINATE_ARG (3)),
+ (COORDINATE_ARG (4)),
+ (COORDINATE_ARG (5)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SET-FONT", Prim_OS2_window_set_font, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, 1));
+ font_metrics_t * m
+ = (OS2_window_set_font ((wid_argument (1)),
+ (USHORT_ARG (2)),
+ (STRING_ARG (3))));
+ if (m == 0)
+ PRIMITIVE_RETURN (SHARP_F);
+ VECTOR_SET (result, 0, (long_to_integer (FONT_METRICS_WIDTH (m))));
+ VECTOR_SET (result, 1, (long_to_integer (FONT_METRICS_HEIGHT (m))));
+ VECTOR_SET (result, 2, (long_to_integer (FONT_METRICS_DESCENDER (m))));
+ OS_free (m);
+ PRIMITIVE_RETURN (result);
+ }
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SET-GRID", Prim_OS2_window_set_grid, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ OS2_window_set_grid ((wid_argument (1)),
+ (DIMENSION_ARG (2)),
+ (DIMENSION_ARG (3)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-ACTIVATE", Prim_OS2_window_activate, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ OS2_window_activate (wid_argument (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-GET-POS", Prim_OS2_window_get_pos, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
+ unsigned short width;
+ unsigned short height;
+ OS2_window_pos ((wid_argument (1)), (& width), (& height));
+ SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
+ SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
+ PRIMITIVE_RETURN (p);
+ }
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SET-POS", Prim_OS2_window_set_pos, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ OS2_window_set_pos ((wid_argument (1)), (USHORT_ARG (2)), (USHORT_ARG (3)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-GET-SIZE", Prim_OS2_window_get_size, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT p = (cons (SHARP_F, SHARP_F));
+ unsigned short width;
+ unsigned short height;
+ OS2_window_size ((wid_argument (1)), (& width), (& height));
+ SET_PAIR_CAR (p, (LONG_TO_UNSIGNED_FIXNUM (width)));
+ SET_PAIR_CDR (p, (LONG_TO_UNSIGNED_FIXNUM (height)));
+ PRIMITIVE_RETURN (p);
+ }
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SET-SIZE", Prim_OS2_window_set_size, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ OS2_window_set_size ((wid_argument (1)), (USHORT_ARG (2)), (USHORT_ARG (3)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-FOCUS?", Prim_OS2_window_focusp, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS2_window_focusp (wid_argument (1))));
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SET-STATE", Prim_OS2_window_set_state, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ OS2_window_set_state
+ ((wid_argument (1)),
+ ((window_state_t) (arg_index_integer (2, ((long) state_supremum)))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-SET-COLORS", Prim_OS2_window_set_colors, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ OS2_window_set_colors ((wid_argument (1)),
+ (arg_index_integer (2, 0x1000000)),
+ (arg_index_integer (3, 0x1000000)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+#define ET_BUTTON 0
+#define ET_CLOSE 1
+#define ET_FOCUS 2
+#define ET_KEY 3
+#define ET_PAINT 4
+#define ET_RESIZE 5
+#define ET_VISIBILITY 6
+
+#define CVT_UNSIGNED(n, v) \
+ VECTOR_SET (result, n, (LONG_TO_UNSIGNED_FIXNUM (v)))
+#define CVT_BOOLEAN(n, v) \
+ VECTOR_SET (result, n, (BOOLEAN_TO_OBJECT (v)))
+
+DEFINE_PRIMITIVE ("OS2WIN-GET-EVENT", Prim_OS2_window_get_event, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ Primitive_GC_If_Needed (8);
+ {
+ msg_t * message
+ = (OS2_receive_message (event_qid_local, (BOOLEAN_ARG (1)), 1));
+ SCHEME_OBJECT result = SHARP_F;
+ if (message != 0)
+ switch (MSG_TYPE (message))
+ {
+ case mt_button_event:
+ {
+ unsigned short type = (SM_BUTTON_EVENT_TYPE (message));
+ result = (allocate_marked_vector (TC_VECTOR, 7, 0));
+ CVT_UNSIGNED (0, ET_BUTTON);
+ CVT_UNSIGNED (1, (SM_BUTTON_EVENT_WID (message)));
+ CVT_UNSIGNED (2, (BUTTON_TYPE_NUMBER (type)));
+ CVT_UNSIGNED (3, (BUTTON_TYPE_EVENT (type)));
+ CVT_UNSIGNED (4, (SM_BUTTON_EVENT_X (message)));
+ CVT_UNSIGNED (5, (SM_BUTTON_EVENT_Y (message)));
+ CVT_UNSIGNED (6, (SM_BUTTON_EVENT_FLAGS (message)));
+ break;
+ }
+ case mt_close_event:
+ {
+ result = (allocate_marked_vector (TC_VECTOR, 2, 0));
+ CVT_UNSIGNED (0, ET_CLOSE);
+ CVT_UNSIGNED (1, (SM_CLOSE_EVENT_WID (message)));
+ break;
+ }
+ case mt_focus_event:
+ {
+ result = (allocate_marked_vector (TC_VECTOR, 3, 0));
+ CVT_UNSIGNED (0, ET_FOCUS);
+ CVT_UNSIGNED (1, (SM_FOCUS_EVENT_WID (message)));
+ CVT_BOOLEAN (2, (SM_FOCUS_EVENT_GAINEDP (message)));
+ break;
+ }
+ case mt_key_event:
+ {
+ result = (allocate_marked_vector (TC_VECTOR, 5, 0));
+ CVT_UNSIGNED (0, ET_KEY);
+ CVT_UNSIGNED (1, (SM_KEY_EVENT_WID (message)));
+ CVT_UNSIGNED (2, (SM_KEY_EVENT_CODE (message)));
+ CVT_UNSIGNED (3, (SM_KEY_EVENT_FLAGS (message)));
+ CVT_UNSIGNED (4, (SM_KEY_EVENT_REPEAT (message)));
+ break;
+ }
+ case mt_paint_event:
+ {
+ result = (allocate_marked_vector (TC_VECTOR, 6, 0));
+ CVT_UNSIGNED (0, ET_PAINT);
+ CVT_UNSIGNED (1, (SM_PAINT_EVENT_WID (message)));
+ CVT_UNSIGNED (2, (SM_PAINT_EVENT_XL (message)));
+ CVT_UNSIGNED (3, (SM_PAINT_EVENT_XH (message)));
+ CVT_UNSIGNED (4, (SM_PAINT_EVENT_YL (message)));
+ CVT_UNSIGNED (5, (SM_PAINT_EVENT_YH (message)));
+ break;
+ }
+ case mt_resize_event:
+ {
+ result = (allocate_marked_vector (TC_VECTOR, 4, 0));
+ CVT_UNSIGNED (0, ET_RESIZE);
+ CVT_UNSIGNED (1, (SM_RESIZE_EVENT_WID (message)));
+ CVT_UNSIGNED (2, (SM_RESIZE_EVENT_WIDTH (message)));
+ CVT_UNSIGNED (3, (SM_RESIZE_EVENT_HEIGHT (message)));
+ break;
+ }
+ case mt_visibility_event:
+ {
+ result = (allocate_marked_vector (TC_VECTOR, 3, 0));
+ CVT_UNSIGNED (0, ET_VISIBILITY);
+ CVT_UNSIGNED (1, (SM_VISIBILITY_EVENT_WID (message)));
+ CVT_BOOLEAN (2, (SM_VISIBILITY_EVENT_SHOWNP (message)));
+ break;
+ }
+ default:
+ OS2_destroy_message (message);
+ OS2_error_anonymous ();
+ break;
+ }
+ OS2_destroy_message (message);
+ PRIMITIVE_RETURN (result);
+ }
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-EVENT-READY?", Prim_OS2_window_event_ready, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ switch (OS2_message_availablep (event_qid_local, (BOOLEAN_ARG (1))))
+ {
+ case mat_available:
+ PRIMITIVE_RETURN (SHARP_T);
+ case mat_not_available:
+ PRIMITIVE_RETURN (SHARP_F);
+ case mat_interrupt:
+ PRIMITIVE_RETURN (FIXNUM_ZERO);
+ }
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-EVENT-DESCRIPTOR", Prim_OS2_window_event_descriptor, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (event_qid_local));
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-CONSOLE-WID", Prim_OS2_window_console_wid, 0, 0, 0)
+{
+ extern wid_t OS2_console_wid (void);
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS2_console_wid ()));
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-WIDTH", Prim_OS2_window_desktop_width, 0, 0, 0)
+{
+ SWP swp;
+ PRIMITIVE_HEADER (0);
+ WinQueryWindowPos (HWND_DESKTOP, (& swp));
+ PRIMITIVE_RETURN (long_to_integer (swp . cx));
+}
+
+DEFINE_PRIMITIVE ("OS2WIN-DESKTOP-HEIGHT", Prim_OS2_window_desktop_height, 0, 0, 0)
+{
+ SWP swp;
+ PRIMITIVE_HEADER (0);
+ WinQueryWindowPos (HWND_DESKTOP, (& swp));
+ PRIMITIVE_RETURN (long_to_integer (swp . cy));
+}
projects / mit-scheme.git / commitdiff