From: Chris Hanson Date: Mon, 19 Dec 1994 22:23:24 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6848 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=61e1220af6ba8097fe1979db9a58e666b08c0eaf;p=mit-scheme.git Initial revision --- diff --git a/v7/src/microcode/os2xcpt.c b/v7/src/microcode/os2xcpt.c new file mode 100644 index 000000000..050a477f5 --- /dev/null +++ b/v7/src/microcode/os2xcpt.c @@ -0,0 +1,913 @@ +/* -*-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 +#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; + +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); + +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); +} + +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 (); +} + +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); +} + +/* 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); +} + +/* 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)); +} + +/* 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); +} + +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); +} + +#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')); +} + +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); + } +} diff --git a/v7/src/microcode/pros2io.c b/v7/src/microcode/pros2io.c new file mode 100644 index 000000000..54a060adf --- /dev/null +++ b/v7/src/microcode/pros2io.c @@ -0,0 +1,153 @@ +/* -*-C-*- + +$Id: pros2io.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" +#include "os2.h" + +DEFINE_PRIMITIVE ("OS2-SELECT-REGISTRY-LUB", Prim_OS2_select_registry_lub, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (QID_MAX + 1)); +} + +DEFINE_PRIMITIVE ("CHANNEL-DESCRIPTOR", Prim_channel_descriptor, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + Tchannel channel = (arg_channel (1)); + if (! (((CHANNEL_OPERATOR (channel)) != 0) && (CHANNEL_INPUTP (channel)))) + error_bad_range_arg (1); + PRIMITIVE_RETURN + (LONG_TO_UNSIGNED_FIXNUM + (CHANNEL_CONTEXT_READER_QID + ((channel_context_t *) (CHANNEL_OPERATOR_CONTEXT (channel))))); + } +} + +static qid_t +arg_qid (int arg_number) +{ + unsigned int qid = (arg_index_integer (arg_number, (QID_MAX + 1))); + if (!OS2_qid_openp (qid)) + error_bad_range_arg (arg_number); + return (qid); +} + +DEFINE_PRIMITIVE ("OS2-SELECT-DESCRIPTOR", Prim_OS2_select_descriptor, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + switch (OS2_message_availablep ((arg_qid (1)), (BOOLEAN_ARG (2)))) + { + case mat_available: + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0)); + case mat_not_available: + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1)); + case mat_interrupt: + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2)); + default: + error_external_return (); + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + +DEFINE_PRIMITIVE ("OS2-SELECT-REGISTRY-TEST", Prim_OS2_select_registry_test, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + CHECK_ARG (1, STRING_P); + if ((STRING_LENGTH (ARG_REF (1))) != (QID_MAX + 1)) + error_bad_range_arg (1); + CHECK_ARG (2, STRING_P); + if ((STRING_LENGTH (ARG_REF (1))) != (QID_MAX + 1)) + error_bad_range_arg (2); + { + char * registry = (STRING_LOC ((ARG_REF (1)), 0)); + char * results = (STRING_LOC ((ARG_REF (2)), 0)); + int blockp = (BOOLEAN_ARG (3)); + int inputp = 0; + int interruptp = 0; + qid_t qid; + int n; + + for (qid = 0; (qid <= QID_MAX); qid += 1) + { + (results [qid]) = 0; + if ((registry [qid]) != 0) + switch (OS2_message_availablep (qid, 0)) + { + case mat_available: + inputp = 1; + (results [qid]) = 1; + break; + case mat_interrupt: + interruptp = 1; + break; + } + } + while (1) + { + for (qid = 0; (qid <= QID_MAX); qid += 1) + (OS2_scheme_tqueue_avail_map [qid]) = 0; + n = (OS2_tqueue_select (OS2_scheme_tqueue, blockp)); + if (n == (-1)) + break; + else if (n < 0) + { + interruptp = 1; + break; + } + else + { + int breakp = 0; + for (qid = 0; (qid <= QID_MAX); qid += 1) + if (((registry [qid]) != 0) + && (OS2_scheme_tqueue_avail_map [qid])) + { + inputp = 1; + (results [qid]) = 1; + if (blockp) + breakp = 1; + } + if (breakp) + break; + } + } + if (inputp) + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0)); + else if (!interruptp) + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1)); + else + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2)); + } +} diff --git a/v7/src/microcode/pros2pm.c b/v7/src/microcode/pros2pm.c new file mode 100644 index 000000000..f569d59d7 --- /dev/null +++ b/v7/src/microcode/pros2pm.c @@ -0,0 +1,439 @@ +/* -*-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" + +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); +} + +#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)); +}