From 8af6411ddb1be3bb44b8eb138eed324d1f4c7ece Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 8 Feb 1992 14:54:26 +0000 Subject: [PATCH] This microcode will not run versions of Edwin prior to 3.66. * Add new primitive WITH-STACK-MARKER that marks the stack for the benefit of the continuation parser. * Implement new set of directory-reading primitives that are reentrant. Changes to X interface: * Add support for WM_DELETE_WINDOW and WM_TAKE_FOCUS window manager protocols. * Add support for Scheme to receive MapNotify and UnmapNotify events. * Window creation primitives allow third argument to be (NAME . CLASS) meaning set the class hint to those strings. * Primitive X-WINDOW-SET-CLASS-HINT now takes three arguments instead of four; the first argument was redundant. The last two arguments have been reversed. * New primitive X-WINDOW-SET-INPUT-HINT for use together with WM_TAKE_FOCUS protocol. * New primitives X-WINDOW-SET-TRANSIENT-FOR-HINT, X-WINDOW-ICONIFY, and X-WINDOW-WITHDRAW. --- v7/src/microcode/hooks.c | 53 ++++- v7/src/microcode/interp.c | 9 +- v7/src/microcode/osfs.h | 15 +- v7/src/microcode/prosfs.c | 102 +++++++-- v7/src/microcode/returns.h | 12 +- v7/src/microcode/utabmd.scm | 8 +- v7/src/microcode/uxfs.c | 187 +++++++++------ v7/src/microcode/version.h | 4 +- v7/src/microcode/x11.h | 33 ++- v7/src/microcode/x11base.c | 437 ++++++++++++++++++++++++++---------- v7/src/microcode/x11graph.c | 33 +-- v7/src/microcode/x11term.c | 66 +++--- v8/src/microcode/interp.c | 9 +- v8/src/microcode/returns.h | 12 +- v8/src/microcode/utabmd.scm | 8 +- v8/src/microcode/version.h | 4 +- 16 files changed, 702 insertions(+), 290 deletions(-) diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index b0a25e0c5..3370797be 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.43 1992/02/03 23:30:25 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.44 1992/02/08 14:54:04 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -538,6 +538,57 @@ DEFINE_PRIMITIVE ("ENABLE-INTERRUPTS!", Prim_enable_interrupts, 1, 1, 0) } } +DEFINE_PRIMITIVE ("RETURN-TO-APPLICATION", Prim_return_to_application, 2, LEXPR, + "Invokes first argument THUNK with no arguments and a special return address.\n\ +The return address calls the second argument on the remaining arguments.\n\ +This is used by the runtime system to create stack frames that can be\n\ +identified by the continuation parser.") +{ + PRIMITIVE_HEADER (LEXPR); + PRIMITIVE_CANONICALIZE_CONTEXT (); + { + long nargs = (LEXPR_N_ARGUMENTS ()); + if (nargs < 2) + signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS); + { + SCHEME_OBJECT thunk = (STACK_POP ()); + STACK_PUSH (STACK_FRAME_HEADER + (nargs - 2)); + Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN)); + Store_Expression (SHARP_F); + Store_Return (RC_INTERNAL_APPLY); + Save_Cont (); + Will_Push (STACK_ENV_EXTRA_SLOTS + 1); + STACK_PUSH (thunk); + STACK_PUSH (STACK_FRAME_HEADER); + Pushed (); + } + } + PRIMITIVE_ABORT (PRIM_APPLY); + /*NOTREACHED*/ +} + +DEFINE_PRIMITIVE ("WITH-STACK-MARKER", Prim_with_stack_marker, 3, 3, + "Call first argument THUNK with a continuation that has a special marker.\n\ +When THUNK returns, the marker is discarded.\n\ +The value of THUNK is returned to the continuation of this primitive.\n\ +The marker consists of the second and third arguments.\n\ +By convention, the second argument is a tag identifying the kind of marker,\n\ +and the third argument is data identifying the marker instance.") +{ + PRIMITIVE_HEADER (3); + PRIMITIVE_CANONICALIZE_CONTEXT (); + { + SCHEME_OBJECT thunk = (STACK_POP ()); + STACK_PUSH (MAKE_OBJECT (TC_RETURN_CODE, RC_STACK_MARKER)); + Will_Push (STACK_ENV_EXTRA_SLOTS + 1); + STACK_PUSH (thunk); + STACK_PUSH (STACK_FRAME_HEADER); + Pushed (); + } + PRIMITIVE_ABORT (PRIM_APPLY); + /*NOTREACHED*/ +} + DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2, 0) { PRIMITIVE_HEADER (2); diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index 5db955234..92726f2ff 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.65 1992/02/03 23:31:14 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.66 1992/02/08 14:54:07 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -2144,6 +2144,13 @@ Primitive_Internal_Apply: SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression())); break; + case RC_STACK_MARKER: + /* Frame consists of the return code followed by two objects. + The first object has already been popped into the Expression + register, so just pop the second argument. */ + Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1)); + break; + /* Interpret() continues on the next page */ /* Interpret(), continued */ diff --git a/v7/src/microcode/osfs.h b/v7/src/microcode/osfs.h index 8e6f3068c..ed57869e9 100644 --- a/v7/src/microcode/osfs.h +++ b/v7/src/microcode/osfs.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osfs.h,v 1.3 1991/10/29 13:58:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osfs.h,v 1.4 1992/02/08 14:54:10 cph Exp $ -Copyright (c) 1990-91 Massachusetts Institute of Technology +Copyright (c) 1990-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -52,9 +52,12 @@ extern void EXFUN extern void EXFUN (OS_file_link_soft, (CONST char * from_name, CONST char * to_name)); extern void EXFUN (OS_directory_make, (CONST char * name)); -extern void EXFUN (OS_directory_open, (CONST char * name)); -extern void EXFUN (OS_directory_close, (void)); -extern CONST char * EXFUN (OS_directory_read, (void)); -extern CONST char * EXFUN (OS_directory_read_matching, (CONST char * prefix)); +extern unsigned int EXFUN (OS_directory_open, (CONST char * name)); +extern int EXFUN (OS_directory_valid_p, (long index)); +extern void EXFUN (OS_directory_close, (unsigned int index)); +extern CONST char * EXFUN (OS_directory_read, (unsigned int index)); +extern CONST char * EXFUN + (OS_directory_read_matching, (unsigned int index, CONST char * prefix)); +extern int OS_directory_index; #endif /* SCM_OSFS_H */ diff --git a/v7/src/microcode/prosfs.c b/v7/src/microcode/prosfs.c index 0a2b535e4..48e5f64d5 100644 --- a/v7/src/microcode/prosfs.c +++ b/v7/src/microcode/prosfs.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosfs.c,v 1.6 1992/01/20 17:29:30 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosfs.c,v 1.7 1992/02/08 14:54:11 cph Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -237,6 +237,41 @@ DEFINE_PRIMITIVE ("DIRECTORY-MAKE", Prim_directory_make, 1, 1, OS_directory_make (STRING_ARG (1)); PRIMITIVE_RETURN (UNSPECIFIC); } + +DEFINE_PRIMITIVE ("DIRECTORY-OPEN-NOREAD", Prim_directory_open_noread, 1, 1, + "Open the directory NAME for reading.") +{ + PRIMITIVE_HEADER (1); + if (OS_directory_index >= 0) + error_external_return (); + OS_directory_index = (OS_directory_open (STRING_ARG (1))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("DIRECTORY-CLOSE", Prim_directory_close, 0, 0, + "Close the directory opened by `directory-open'.") +{ + PRIMITIVE_HEADER (0); + if (OS_directory_index >= 0) + { + OS_directory_close (OS_directory_index); + OS_directory_index = (-1); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +#define DIRREAD(expr) \ +{ \ + CONST char * result = (expr); \ + if (result == 0) \ + { \ + OS_directory_close (OS_directory_index); \ + OS_directory_index = (-1); \ + PRIMITIVE_RETURN (SHARP_F); \ + } \ + PRIMITIVE_RETURN \ + (char_pointer_to_string ((unsigned char *) result)); \ +} DEFINE_PRIMITIVE ("DIRECTORY-OPEN", Prim_directory_open, 1, 1, "Open the directory NAME for reading.\n\ @@ -244,16 +279,10 @@ If successful, return the first filename in the directory as a string.\n\ If there is no such file, #F is returned.") { PRIMITIVE_HEADER (1); - OS_directory_open (STRING_ARG (1)); - STRING_RESULT (OS_directory_read ()); -} - -DEFINE_PRIMITIVE ("DIRECTORY-OPEN-NOREAD", Prim_directory_open_noread, 1, 1, - "Open the directory NAME for reading.") -{ - PRIMITIVE_HEADER (1); - OS_directory_open (STRING_ARG (1)); - PRIMITIVE_RETURN (UNSPECIFIC); + if (OS_directory_index >= 0) + error_external_return (); + OS_directory_index = (OS_directory_open (STRING_ARG (1))); + DIRREAD (OS_directory_read (OS_directory_index)); } DEFINE_PRIMITIVE ("DIRECTORY-READ", Prim_directory_read, 0, 0, @@ -261,7 +290,9 @@ DEFINE_PRIMITIVE ("DIRECTORY-READ", Prim_directory_read, 0, 0, Return #F if there are no more files in the directory.") { PRIMITIVE_HEADER (0); - STRING_RESULT (OS_directory_read ()); + if (OS_directory_index < 0) + error_external_return (); + DIRREAD (OS_directory_read (OS_directory_index)); } DEFINE_PRIMITIVE ("DIRECTORY-READ-MATCHING", Prim_directory_read_matching, 1, 1, @@ -270,13 +301,48 @@ The filename must begin with the argument string.\n\ Return #F if there are no more matching files in the directory.") { PRIMITIVE_HEADER (1); - STRING_RESULT (OS_directory_read_matching (STRING_ARG (1))); + if (OS_directory_index < 0) + error_external_return (); + DIRREAD (OS_directory_read_matching (OS_directory_index, (STRING_ARG (1)))); +} + +DEFINE_PRIMITIVE ("NEW-DIRECTORY-OPEN", Prim_new_directory_open, 1, 1, + "Open the directory NAME for reading, returning a directory number.") +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (long_to_integer (OS_directory_open (STRING_ARG (1)))); } -DEFINE_PRIMITIVE ("DIRECTORY-CLOSE", Prim_directory_close, 0, 0, - "Close the directory opened by `directory-open'.") +static unsigned int +DEFUN (arg_directory_index, (argument), unsigned int argument) { - PRIMITIVE_HEADER (0); - OS_directory_close (); + long index = (arg_integer (argument)); + if (! (OS_directory_valid_p (index))) + error_bad_range_arg (argument); + return (index); +} + +DEFINE_PRIMITIVE ("NEW-DIRECTORY-CLOSE", Prim_new_directory_close, 1, 1, + "Close DIRECTORY.") +{ + PRIMITIVE_HEADER (1); + OS_directory_close (arg_directory_index (1)); PRIMITIVE_RETURN (UNSPECIFIC); } + +DEFINE_PRIMITIVE ("NEW-DIRECTORY-READ", Prim_new_directory_read, 1, 1, + "Read and return a filename from DIRECTORY, or #F if no more files.") +{ + PRIMITIVE_HEADER (1); + STRING_RESULT (OS_directory_read (arg_directory_index (1))); +} + +DEFINE_PRIMITIVE ("NEW-DIRECTORY-READ-MATCHING", Prim_new_directory_read_match, 2, 2, + "Read and return a filename from DIRECTORY.\n\ +The filename must begin with the STRING.\n\ +Return #F if there are no more matching files in the directory.") +{ + PRIMITIVE_HEADER (2); + STRING_RESULT + (OS_directory_read_matching ((arg_directory_index (1)), (STRING_ARG (2)))); +} diff --git a/v7/src/microcode/returns.h b/v7/src/microcode/returns.h index afa9e3120..f2f5acf6d 100644 --- a/v7/src/microcode/returns.h +++ b/v7/src/microcode/returns.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.39 1990/11/21 07:04:43 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.40 1992/02/08 14:54:12 cph Exp $ -Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -35,10 +35,6 @@ MIT in each case. */ /* Return codes. These are placed in Return when an interpreter operation needs to operate in several phases. */ -/* These names are also in storage.c. - Please maintain consistency. - Names should not exceed 31 characters. */ - #define RC_END_OF_COMPUTATION 0x00 /* formerly RC_RESTORE_CONTROL_POINT 0x01 */ #define RC_JOIN_STACKLETS 0x01 @@ -92,7 +88,7 @@ MIT in each case. */ /* The following are not used in the 68000 implementation */ #define RC_POP_RETURN_ERROR 0x40 #define RC_EVAL_ERROR 0x41 -/* formerly RC_REPEAT_PRIMITIVE 0x42 */ +#define RC_STACK_MARKER 0x42 #define RC_COMP_INTERRUPT_RESTART 0x43 /* formerly RC_COMP_RECURSION_GC 0x44 */ #define RC_RESTORE_INT_MASK 0x45 @@ -195,7 +191,7 @@ MIT in each case. */ /* 0x3F */ "", \ /* 0x40 */ "POP_RETURN_ERROR", \ /* 0x41 */ "EVAL_ERROR", \ -/* 0x42 */ "", \ +/* 0x42 */ "STACK_MARKER", \ /* 0x43 */ "COMPILER_INTERRUPT_RESTART", \ /* 0x44 */ "", \ /* 0x45 */ "RESTORE_INT_MASK", \ diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index db083a774..fb329aa36 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.60 1991/10/29 13:59:11 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.61 1992/02/08 14:54:14 cph Exp $ ;;; -;;; Copyright (c) 1987-91 Massachusetts Institute of Technology +;;; Copyright (c) 1987-92 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -440,7 +440,7 @@ #F ;3F POP-RETURN-ERROR ;40 EVAL-ERROR ;41 - REPEAT-PRIMITIVE ;42 + STACK-MARKER ;42 COMPILER-INTERRUPT-RESTART ;43 #F ;44 RESTORE-INTERRUPT-MASK ;45 @@ -698,4 +698,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.60 1991/10/29 13:59:11 cph Exp $" \ No newline at end of file +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.61 1992/02/08 14:54:14 cph Exp $" \ No newline at end of file diff --git a/v7/src/microcode/uxfs.c b/v7/src/microcode/uxfs.c index 01035292f..61b696227 100644 --- a/v7/src/microcode/uxfs.c +++ b/v7/src/microcode/uxfs.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxfs.c,v 1.5 1991/10/29 13:59:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxfs.c,v 1.6 1992/02/08 14:54:17 cph Exp $ -Copyright (c) 1990-1 Massachusetts Institute of Technology +Copyright (c) 1990-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -180,119 +180,174 @@ DEFUN (OS_directory_make, (name), CONST char * name) STD_VOID_SYSTEM_CALL (syscall_mkdir, (UX_mkdir (name, MODE_DIR))); } +int OS_directory_index; + #if defined(HAVE_DIRENT) || defined(HAVE_DIR) -static DIR * directory_pointer = 0; -#ifdef HAVE_DIRENT -static struct dirent * directory_entry; -#else -static struct direct * directory_entry; -#endif +static DIR ** directory_pointers; +static unsigned int n_directory_pointers; -#define READ_DIRECTORY_ENTRY() \ -{ \ - directory_entry = (readdir (directory_pointer)); \ - if (directory_entry == 0) \ - { \ - closedir (directory_pointer); \ - directory_pointer = 0; \ - return (0); \ - } \ - return (directory_entry -> d_name); \ +void +DEFUN_VOID (UX_initialize_directory_reader) +{ + directory_pointers = 0; + n_directory_pointers = 0; + OS_directory_index = (-1); } -void +static unsigned int +DEFUN (allocate_directory_pointer, (pointer), DIR ** pointer) +{ + if (n_directory_pointers == 0) + { + DIR ** pointers = ((DIR **) (UX_malloc ((sizeof (DIR *)) * 4))); + if (pointers == 0) + error_system_call (ENOMEM, syscall_malloc); + directory_pointers = pointers; + n_directory_pointers = 4; + { + DIR ** scan = directory_pointers; + DIR ** end = (scan + n_directory_pointers); + (*scan++) = pointer; + while (scan < end) + (*scan++) = 0; + } + return (0); + } + { + DIR ** scan = directory_pointers; + DIR ** end = (scan + n_directory_pointers); + while (scan < end) + if ((*scan++) == 0) + { + (*--scan) = pointer; + return (scan - directory_pointers); + } + } + { + unsigned int result = n_directory_pointers; + unsigned int n_pointers = (2 * n_directory_pointers); + DIR ** pointers = + ((DIR **) + (UX_realloc (((PTR) directory_pointers), + ((sizeof (DIR *)) * n_pointers)))); + if (pointers == 0) + error_system_call (ENOMEM, syscall_realloc); + { + DIR ** scan = (pointers + result); + DIR ** end = (pointers + n_pointers); + (*scan++) = pointer; + while (scan < end) + (*scan++) = 0; + } + directory_pointers = pointers; + n_directory_pointers = n_pointers; + return (result); + } +} + +#define REFERENCE_DIRECTORY(index) (directory_pointers[(index)]) +#define DEALLOCATE_DIRECTORY(index) ((directory_pointers[(index)]) = 0) + +int +DEFUN (OS_directory_valid_p, (index), long index) +{ + return + ((0 <= index) + && (index < n_directory_pointers) + && ((REFERENCE_DIRECTORY (index)) != 0)); +} + +unsigned int DEFUN (OS_directory_open, (name), CONST char * name) { - if (directory_pointer != 0) - error_external_return (); /* Cast `name' to non-const because hp-ux 7.0 declaration incorrect. */ - directory_pointer = (opendir ((char *) name)); - if (directory_pointer == 0) -#ifdef HAVE_DIRENT + DIR ** pointer = (opendir ((char *) name)); + if (pointer == 0) error_system_call (errno, syscall_opendir); -#else - error_external_return (); -#endif + return (allocate_directory_pointer (pointer)); } +#ifndef HAVE_DIRENT +#define dirent direct +#endif + CONST char * -DEFUN_VOID (OS_directory_read) +DEFUN (OS_directory_read, (index), unsigned int index) { - if (directory_pointer == 0) - error_external_return (); - READ_DIRECTORY_ENTRY (); + struct dirent * entry = (readdir (REFERENCE_DIRECTORY (index))); + return ((entry == 0) ? 0 : (entry -> d_name)); } CONST char * -DEFUN (OS_directory_read_matching, (prefix), CONST char * prefix) +DEFUN (OS_directory_read_matching, (index, prefix), + unsigned int index AND + CONST char * prefix) { - if (directory_pointer == 0) - error_external_return (); - { - unsigned int n = (strlen (prefix)); - while (1) - { - directory_entry = (readdir (directory_pointer)); - if (directory_entry == 0) - { - closedir (directory_pointer); - directory_pointer = 0; - return (0); - } - if ((strncmp (prefix, (directory_entry -> d_name), n)) == 0) - return (directory_entry -> d_name); - } - } + DIR * pointer = (REFERENCE_DIRECTORY (index)); + unsigned int n = (strlen (prefix)); + while (1) + { + struct dirent * entry = (readdir (pointer)); + if (entry == 0) + return (0); + if ((strncmp (prefix, (entry -> d_name), n)) == 0) + return (entry -> d_name); + } } void -DEFUN_VOID (OS_directory_close) +DEFUN (OS_directory_close, (index), unsigned int index) { - if (directory_pointer != 0) - { - closedir (directory_pointer); - directory_pointer = 0; - } + closedir (REFERENCE_DIRECTORY (index)); + DEALLOCATE_DIRECTORY (index); } + +#else /* not HAVE_DIRENT nor HAVE_DIR */ void DEFUN_VOID (UX_initialize_directory_reader) { - directory_pointer = 0; + OS_directory_index = (-1); } -#else /* not HAVE_DIRENT nor HAVE_DIR */ +int +DEFUN (OS_directory_valid_p, (index), long index) +{ + return (0); +} -void +unsigned int DEFUN (OS_directory_open, (name), CONST char * name) { error_unimplemented_primitive (); + return (0); } +#ifndef HAVE_DIRENT +#define dirent direct +#endif + CONST char * -DEFUN_VOID (OS_directory_read) +DEFUN (OS_directory_read, (index), unsigned int index) { error_unimplemented_primitive (); return (0); } CONST char * -DEFUN (OS_directory_read_matching, (prefix), CONST char * prefix) +DEFUN (OS_directory_read_matching, (index, prefix), + unsigned int index AND + CONST char * prefix) { error_unimplemented_primitive (); return (0); } void -DEFUN_VOID (OS_directory_close) +DEFUN (OS_directory_close, (index), unsigned int index) { error_unimplemented_primitive (); } -void -DEFUN_VOID (UX_initialize_directory_reader) -{ -} - #endif /* HAVE_DIRENT */ diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 7fe476a2e..cbdc9b158 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.107 1992/02/04 04:37:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.108 1992/02/08 14:54:19 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 107 +#define SUBVERSION 108 #endif diff --git a/v7/src/microcode/x11.h b/v7/src/microcode/x11.h index 592452370..85b3ba86c 100644 --- a/v7/src/microcode/x11.h +++ b/v7/src/microcode/x11.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11.h,v 1.10 1991/07/23 08:16:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11.h,v 1.11 1992/02/08 14:54:21 cph Exp $ -Copyright (c) 1989-91 Massachusetts Institute of Technology +Copyright (c) 1989-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,18 +36,25 @@ MIT in each case. */ #include #include #include +#include #include "ansidecl.h" struct xdisplay { unsigned int allocation_index; Display * display; + Atom wm_protocols; + Atom wm_delete_window; + Atom wm_take_focus; XEvent cached_event; char cached_event_p; }; #define XD_ALLOCATION_INDEX(xd) ((xd) -> allocation_index) #define XD_DISPLAY(xd) ((xd) -> display) +#define XD_WM_PROTOCOLS(xd) ((xd) -> wm_protocols) +#define XD_WM_DELETE_WINDOW(xd) ((xd) -> wm_delete_window) +#define XD_WM_TAKE_FOCUS(xd) ((xd) -> wm_take_focus) #define XD_CACHED_EVENT(xd) ((xd) -> cached_event) #define XD_CACHED_EVENT_P(xd) ((xd) -> cached_event_p) #define XD_TO_OBJECT(xd) (LONG_TO_UNSIGNED_FIXNUM (XD_ALLOCATION_INDEX (xd))) @@ -217,7 +224,7 @@ extern struct xcolormap * EXFUN (x_colormap_arg, (unsigned int arg)); extern unsigned int EXFUN (allocate_x_colormap, (Colormap colormap, struct xdisplay * xd)); extern void EXFUN (deallocate_x_colormap, (struct xcolormap * xcm)); - + extern int x_debug; extern PTR EXFUN (x_malloc, (unsigned int size)); @@ -227,14 +234,16 @@ extern char * EXFUN (x_get_default, (Display * display, char * resource_name, + char * resource_class, char * property_name, - char * class_name, + char * property_class, char * sdefault)); extern void EXFUN (x_default_attributes, (Display * display, char * resource_name, + char * resource_class, struct drawing_attributes * attributes)); extern struct xwindow * EXFUN @@ -246,3 +255,19 @@ extern struct xwindow * EXFUN struct drawing_attributes * attributes, struct xwindow_methods * methods, unsigned int extra)); + +extern void EXFUN + (xw_set_wm_input_hint, (struct xwindow * xw, int input_hint)); + +extern void EXFUN + (xw_set_wm_name, (struct xwindow * xw, CONST char * name)); + +extern void EXFUN + (xw_set_wm_icon_name, (struct xwindow * xw, CONST char * name)); + +extern void EXFUN + (xw_make_window_map, + (struct xwindow * xw, + CONST char * resource_name, + CONST char * resource_class, + SCHEME_OBJECT map_arg)); diff --git a/v7/src/microcode/x11base.c b/v7/src/microcode/x11base.c index 1e0426838..8535f1da2 100644 --- a/v7/src/microcode/x11base.c +++ b/v7/src/microcode/x11base.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11base.c,v 1.31 1992/02/04 04:37:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11base.c,v 1.32 1992/02/08 14:54:22 cph Exp $ Copyright (c) 1989-92 Massachusetts Institute of Technology @@ -248,17 +248,25 @@ DEFUN (x_set_mouse_colors, char * DEFUN (x_get_default, - (display, resource_name, property_name, class_name, sdefault), + (display, resource_name, resource_class, + property_name, property_class, sdefault), Display * display AND char * resource_name AND + char * resource_class AND char * property_name AND - char * class_name AND + char * property_class AND char * sdefault) { char * result = (XGetDefault (display, resource_name, property_name)); if (result != 0) return (result); - result = (XGetDefault (display, resource_name, class_name)); + result = (XGetDefault (display, resource_class, property_name)); + if (result != 0) + return (result); + result = (XGetDefault (display, resource_name, property_class)); + if (result != 0) + return (result); + result = (XGetDefault (display, resource_class, property_class)); if (result != 0) return (result); return (sdefault); @@ -266,15 +274,19 @@ DEFUN (x_get_default, static unsigned long DEFUN (x_default_color, - (display, resource_name, property_name, class_name, default_color), + (display, resource_class, resource_name, + property_name, property_class, default_color), Display * display AND char * resource_name AND + char * resource_class AND char * property_name AND - char * class_name AND + char * property_class AND unsigned long default_color) { char * color_name = - (x_get_default (display, resource_name, property_name, class_name, 0)); + (x_get_default + (display, resource_name, resource_class, + property_name, property_class, 0)); unsigned long result; return (((color_name != 0) @@ -288,28 +300,34 @@ DEFUN (x_default_color, } void -DEFUN (x_default_attributes, (display, resource_name, attributes), +DEFUN (x_default_attributes, + (display, resource_name, resource_class, attributes), Display * display AND char * resource_name AND + char * resource_class AND struct drawing_attributes * attributes) { int screen_number = (DefaultScreen (display)); (attributes -> font) = (XLoadQueryFont (display, - (x_get_default (display, resource_name, "font", "Font", "9x15")))); + (x_get_default + (display, resource_name, resource_class, + "font", "Font", "9x15")))); if ((attributes -> font) == 0) error_external_return (); { char * s = (x_get_default - (display, resource_name, "borderWidth", "BorderWidth", 0)); + (display, resource_name, resource_class, + "borderWidth", "BorderWidth", 0)); (attributes -> border_width) = ((s == 0) ? 2 : (atoi (s))); } { char * s = (x_get_default - (display, resource_name, "internalBorder", "BorderWidth", 0)); + (display, resource_name, resource_class, + "internalBorder", "BorderWidth", 0)); (attributes -> internal_border_width) = ((s == 0) ? (attributes -> border_width) : (atoi (s))); } @@ -319,22 +337,24 @@ DEFUN (x_default_attributes, (display, resource_name, attributes), unsigned long foreground_pixel; (attributes -> background_pixel) = (x_default_color - (display, resource_name, "background", "Background", white_pixel)); + (display, resource_class, resource_name, + "background", "Background", white_pixel)); foreground_pixel = (x_default_color - (display, resource_name, "foreground", "Foreground", black_pixel)); + (display, resource_class, resource_name, + "foreground", "Foreground", black_pixel)); (attributes -> foreground_pixel) = foreground_pixel; (attributes -> border_pixel) = (x_default_color - (display, resource_name, + (display, resource_class, resource_name, "borderColor", "BorderColor", foreground_pixel)); (attributes -> cursor_pixel) = (x_default_color - (display, resource_name, + (display, resource_class, resource_name, "cursorColor", "Foreground", foreground_pixel)); (attributes -> mouse_pixel) = (x_default_color - (display, resource_name, + (display, resource_class, resource_name, "pointerColor", "Foreground", foreground_pixel)); } } @@ -462,6 +482,82 @@ DEFUN_VOID (x_close_all_displays) } static void +DEFUN (xw_set_class_hint, (xw, name, class), + struct xwindow * xw AND + CONST char * name AND + CONST char * class) +{ + XClassHint * class_hint = (XAllocClassHint ()); + if (class_hint == 0) + error_external_return (); + (class_hint -> res_name) = name; + (class_hint -> res_class) = class; + XSetClassHint ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), class_hint); + XFree ((caddr_t) class_hint); +} + +void +DEFUN (xw_set_wm_input_hint, (xw, input_hint), + struct xwindow * xw AND + int input_hint) +{ + XWMHints * hints = (XAllocWMHints ()); + if (hints == 0) + error_external_return (); + (hints -> flags) = InputHint; + (hints -> input) = (input_hint != 0); + XSetWMHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), hints); + XFree ((caddr_t) hints); +} + +void +DEFUN (xw_set_wm_name, (xw, name), struct xwindow * xw AND CONST char * name) +{ + XTextProperty property; + if ((XStringListToTextProperty ((&name), 1, (&property))) == 0) + error_external_return (); + XSetWMName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); +} + +void +DEFUN (xw_set_wm_icon_name, (xw, name), + struct xwindow * xw AND + CONST char * name) +{ + XTextProperty property; + if ((XStringListToTextProperty ((&name), 1, (&property))) == 0) + error_external_return (); + XSetWMIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property)); +} + +void +DEFUN (xw_make_window_map, (xw, resource_name, resource_class, map_arg), + struct xwindow * xw AND + CONST char * resource_name AND + CONST char * resource_class AND + SCHEME_OBJECT map_arg) +{ + SCHEME_OBJECT map_arg = (ARG_REF (3)); + int map_p = 0; + if (map_arg == SHARP_F) + map_p = 1; + else if ((PAIR_P (map_arg)) + && (STRING_P (PAIR_CAR (map_arg))) + && (STRING_P (PAIR_CDR (map_arg)))) + { + resource_class = ((CONST char *) (STRING_LOC ((PAIR_CDR (map_arg)), 0))); + resource_name = ((CONST char *) (STRING_LOC ((PAIR_CAR (map_arg)), 0))); + map_p = 1; + } + xw_set_class_hint (xw, resource_name, resource_class); + if (map_p) + { + XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw))); + XFlush (XW_DISPLAY (xw)); + } +} + +static void DEFUN (xw_process_event, (xw, event), struct xwindow * xw AND XEvent * event) @@ -469,12 +565,12 @@ DEFUN (xw_process_event, (xw, event), if (x_debug) { char * type_name; + fprintf (stderr, "\nX event: "); switch (event -> type) { case ButtonPress: type_name = "ButtonPress"; break; case ButtonRelease: type_name = "ButtonRelease"; break; case CirculateNotify: type_name = "CirculateNotify"; break; - case ConfigureNotify: type_name = "ConfigureNotify"; break; case CreateNotify: type_name = "CreateNotify"; break; case DestroyNotify: type_name = "DestroyNotify"; break; case EnterNotify: type_name = "EnterNotify"; break; @@ -492,13 +588,45 @@ DEFUN (xw_process_event, (xw, event), case NoExpose: type_name = "NoExpose"; break; case ReparentNotify: type_name = "ReparentNotify"; break; case UnmapNotify: type_name = "UnmapNotify"; break; + case ConfigureNotify: + { + fprintf (stderr, "ConfigureNotify; width = %d, height = %d", + ((event -> xconfigure) . width), + ((event -> xconfigure) . height)); + goto debug_done; + } + case ClientMessage: + { + struct xdisplay * xd = (XW_XD (xw)); + if ((((event -> xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) + && (((event -> xclient) . format) == 32)) + { + if (((Atom) (((event -> xclient) . data . l) [0])) + == (XD_WM_DELETE_WINDOW (xd))) + type_name = "WM_DELETE_WINDOW"; + else if (((Atom) (((event -> xclient) . data . l) [0])) + == (XD_WM_TAKE_FOCUS (xd))) + type_name = "WM_TAKE_FOCUS"; + else + type_name = "WM_PROTOCOLS"; + } + else + { + fprintf (stderr, + "ClientMessage; message_type = 0x%x, format = %d", + ((event -> xclient) . message_type), + ((event -> xclient) . format)); + goto debug_done; + } + } + break; default: type_name = 0; break; } - fprintf (stderr, "\nX event: "); if (type_name != 0) fprintf (stderr, "%s", type_name); else fprintf (stderr, "%d", (event -> type)); + debug_done: fprintf (stderr, "\n"); fflush (stderr); } @@ -529,6 +657,10 @@ enum event_type event_type_leave, event_type_motion, event_type_expose, + event_type_delete_window, + event_type_map, + event_type_unmap, + event_type_take_focus, event_type_supremum }; @@ -543,8 +675,6 @@ enum event_type #define EVENT_2 4 #define EVENT_3 5 -#define EVENT_EXTRA(max_event) (max_event - 1) - #define EVENT_INTEGER(event, slot, number) \ VECTOR_SET ((event), (slot), (long_to_integer (number))) @@ -566,7 +696,7 @@ DEFUN (button_event, (xw, event, type), XButtonEvent * event AND enum event_type type) { - SCHEME_OBJECT result = (make_event_object (xw, type, 3)); + SCHEME_OBJECT result = (make_event_object (xw, type, 4)); EVENT_INTEGER (result, EVENT_0, (event -> x)); EVENT_INTEGER (result, EVENT_1, (event -> y)); { @@ -598,6 +728,7 @@ DEFUN (button_event, (xw, event, type), } VECTOR_SET (result, EVENT_2, conversion); } + EVENT_INTEGER (result, EVENT_3, (event -> time)); return (result); } @@ -617,10 +748,10 @@ DEFUN (key_event, (xw, event, type), if ((event -> state) & (ShiftMask || ControlMask || Mod1Mask || Mod2Mask || Mod3Mask || Mod4Mask || Mod5Mask)) - { - if ((event->state) & LockMask) - (event->state) -= LockMask; - } + { + if (((event->state) & LockMask) != 0) + (event->state) -= LockMask; + } nbytes = (XLookupString (event, copy_buffer, @@ -631,39 +762,44 @@ DEFUN (key_event, (xw, event, type), return (SHARP_F); else { - long bucky = 0; - - SCHEME_OBJECT result - = (make_event_object (xw, type, EVENT_EXTRA (EVENT_2))); - - /* Create Scheme bucky bits (kept independent of the */ - /* character). X has already controlified, so Scheme may */ - /* choose to ignore the control bucky bit. */ - if ((event -> state) & Mod1Mask) /* Meta */ - bucky |= 1; - if ((event -> state) & ControlMask) /* Control */ - bucky |= 2; - if ((event -> state) & Mod2Mask) /* Super */ - bucky |= 4; - if ((event -> state) & Mod3Mask) /* Hyper */ - bucky |= 8; - if ((event -> state) & Mod4Mask) /* Top */ - bucky |= 16; + SCHEME_OBJECT result = (make_event_object (xw, type, 4)); VECTOR_SET (result, EVENT_0, (memory_to_string (nbytes, ((unsigned char *) copy_buffer)))); - VECTOR_SET (result, EVENT_1, LONG_TO_UNSIGNED_FIXNUM (bucky)); - /* Move vendor-specific bit from bit 28 (zero-based) to bit 23 */ - /* so that all keysym values will fit in Scheme fixnums. */ + /* Create Scheme bucky bits (kept independent of the character). + X has already controlified, so Scheme may choose to ignore + the control bucky bit. */ + { + long bucky = 0; + if ((event -> state) & Mod1Mask) /* Meta */ + bucky |= 1; + if ((event -> state) & ControlMask) /* Control */ + bucky |= 2; + if ((event -> state) & Mod2Mask) /* Super */ + bucky |= 4; + if ((event -> state) & Mod3Mask) /* Hyper */ + bucky |= 8; + if ((event -> state) & Mod4Mask) /* Top */ + bucky |= 16; + VECTOR_SET (result, EVENT_1, (LONG_TO_UNSIGNED_FIXNUM (bucky))); + } + /* Move vendor-specific bit from bit 28 (zero-based) to bit 23 + so that all keysym values will fit in Scheme fixnums. */ VECTOR_SET (result, EVENT_2, - LONG_TO_UNSIGNED_FIXNUM ((keysym & 0xffffff) - | (0x800000 & (keysym >> 5)))); + (LONG_TO_UNSIGNED_FIXNUM ((keysym & 0xffffff) + | (0x800000 & (keysym >> 5))))); + EVENT_INTEGER (result, EVENT_3, (event -> time)); return (result); } } +#define CONVERT_TRIVIAL_EVENT(scheme_name) \ + if (EVENT_ENABLED (xw, scheme_name)) \ + result = (make_event_object (xw, scheme_name, 0)); \ + break + static SCHEME_OBJECT DEFUN (x_event_to_object, (event), XEvent * event) { @@ -723,22 +859,39 @@ DEFUN (x_event_to_object, (event), XEvent * event) ((event -> xgraphicsexpose) . height)); } break; - case EnterNotify: - if (EVENT_ENABLED (xw, event_type_enter)) - result = (make_event_object (xw, event_type_enter, 0)); - break; - case LeaveNotify: - if (EVENT_ENABLED (xw, event_type_leave)) - result = (make_event_object (xw, event_type_leave, 0)); - break; - case FocusIn: - if (EVENT_ENABLED (xw, event_type_focus_in)) - result = (make_event_object (xw, event_type_focus_in, 0)); - break; - case FocusOut: - if (EVENT_ENABLED (xw, event_type_focus_out)) - result = (make_event_object (xw, event_type_focus_out, 0)); + case ClientMessage: + { + struct xdisplay * xd = (XW_XD (xw)); + if ((((event -> xclient) . message_type) == (XD_WM_PROTOCOLS (xd))) + && (((event -> xclient) . format) == 32)) + { + if (((Atom) (((event -> xclient) . data . l) [0])) + == (XD_WM_DELETE_WINDOW (xd))) + { + if (EVENT_ENABLED (xw, event_type_delete_window)) + result = + (make_event_object (xw, event_type_delete_window, 0)); + } + else if (((Atom) (((event -> xclient) . data . l) [0])) + == (XD_WM_TAKE_FOCUS (xd))) + { + if (EVENT_ENABLED (xw, event_type_take_focus)) + { + result = + (make_event_object (xw, event_type_take_focus, 1)); + EVENT_INTEGER + (result, EVENT_0, (((event -> xclient) . data . l) [1])); + } + } + } + } break; + case EnterNotify: CONVERT_TRIVIAL_EVENT (event_type_enter); + case LeaveNotify: CONVERT_TRIVIAL_EVENT (event_type_leave); + case FocusIn: CONVERT_TRIVIAL_EVENT (event_type_focus_in); + case FocusOut: CONVERT_TRIVIAL_EVENT (event_type_focus_out); + case MapNotify: CONVERT_TRIVIAL_EVENT (event_type_map); + case UnmapNotify: CONVERT_TRIVIAL_EVENT (event_type_unmap); } return (result); } @@ -848,6 +1001,12 @@ DEFINE_PRIMITIVE ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0) } (XD_ALLOCATION_INDEX (xd)) = (allocate_table_index ((&x_display_table), xd)); + (XD_WM_PROTOCOLS (xd)) = + (XInternAtom ((XD_DISPLAY (xd)), "WM_PROTOCOLS", False)); + (XD_WM_DELETE_WINDOW (xd)) = + (XInternAtom ((XD_DISPLAY (xd)), "WM_DELETE_WINDOW", False)); + (XD_WM_TAKE_FOCUS (xd)) = + (XInternAtom ((XD_DISPLAY (xd)), "WM_TAKE_FOCUS", False)); (XD_CACHED_EVENT_P (xd)) = 0; PRIMITIVE_RETURN (XD_TO_OBJECT (xd)); } @@ -890,27 +1049,45 @@ DEFINE_PRIMITIVE ("X-DISPLAY-PROCESS-EVENTS", Prim_x_display_process_events, 2, static void DEFUN (update_input_mask, (xw), struct xwindow * xw) { - long event_mask = 0; - if (EVENT_ENABLED (xw, event_type_expose)) - event_mask |= ExposureMask; - if (EVENT_ENABLED (xw, event_type_configure)) - event_mask |= StructureNotifyMask; - if (EVENT_ENABLED (xw, event_type_button_down)) - event_mask |= ButtonPressMask; - if (EVENT_ENABLED (xw, event_type_button_up)) - event_mask |= ButtonReleaseMask; - if (EVENT_ENABLED (xw, event_type_key_press)) - event_mask |= KeyPressMask; - if (EVENT_ENABLED (xw, event_type_enter)) - event_mask |= EnterWindowMask; - if (EVENT_ENABLED (xw, event_type_leave)) - event_mask |= LeaveWindowMask; - if ((EVENT_ENABLED (xw, event_type_focus_in)) - || (EVENT_ENABLED (xw, event_type_focus_out))) - event_mask |= FocusChangeMask; - if (EVENT_ENABLED (xw, event_type_motion)) - event_mask |= PointerMotionMask; - XSelectInput ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), event_mask); + { + long event_mask = 0; + + if (EVENT_ENABLED (xw, event_type_expose)) + event_mask |= ExposureMask; + if ((EVENT_ENABLED (xw, event_type_configure)) + || (EVENT_ENABLED (xw, event_type_map)) + || (EVENT_ENABLED (xw, event_type_unmap))) + event_mask |= StructureNotifyMask; + if (EVENT_ENABLED (xw, event_type_button_down)) + event_mask |= ButtonPressMask; + if (EVENT_ENABLED (xw, event_type_button_up)) + event_mask |= ButtonReleaseMask; + if (EVENT_ENABLED (xw, event_type_key_press)) + event_mask |= KeyPressMask; + if (EVENT_ENABLED (xw, event_type_enter)) + event_mask |= EnterWindowMask; + if (EVENT_ENABLED (xw, event_type_leave)) + event_mask |= LeaveWindowMask; + if ((EVENT_ENABLED (xw, event_type_focus_in)) + || (EVENT_ENABLED (xw, event_type_focus_out))) + event_mask |= FocusChangeMask; + if (EVENT_ENABLED (xw, event_type_motion)) + event_mask |= PointerMotionMask; + XSelectInput ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), event_mask); + } + { + struct xdisplay * xd = (XW_XD (xw)); + Atom protocols [2]; + unsigned int n_protocols = 0; + + if (EVENT_ENABLED (xw, event_type_delete_window)) + (protocols[n_protocols++]) = (XD_WM_DELETE_WINDOW (xd)); + if (EVENT_ENABLED (xw, event_type_take_focus)) + (protocols[n_protocols++]) = (XD_WM_TAKE_FOCUS (xd)); + if (n_protocols > 0) + XSetWMProtocols + ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&protocols[0]), n_protocols); + } } DEFINE_PRIMITIVE ("X-WINDOW-EVENT-MASK", Prim_x_window_event_mask, 1, 1, 0) @@ -951,6 +1128,20 @@ DEFINE_PRIMITIVE ("X-WINDOW-ANDC-EVENT-MASK", Prim_x_window_andc_event_mask, 2, } PRIMITIVE_RETURN (UNSPECIFIC); } + +DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-FOCUS", Prim_x_window_set_input_focus, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + struct xwindow * xw = (x_window_arg (1)); + XSetInputFocus + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + RevertToParent, + ((Time) (arg_integer (2)))); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} DEFINE_PRIMITIVE ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 0) { @@ -1300,8 +1491,6 @@ DEFINE_PRIMITIVE ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0) PRIMITIVE_HEADER (3); { struct xwindow * xw = (x_window_arg (1)); - Display * display = (XW_DISPLAY (xw)); - int screen_number = (DefaultScreen (display)); XMoveWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), @@ -1315,47 +1504,69 @@ DEFINE_PRIMITIVE ("X-WINDOW-SET-NAME", Prim_x_window_set_name, 2, 2, "Set the name of WINDOW to STRING.") { PRIMITIVE_HEADER (2); - { - struct xwindow * xw = (x_window_arg (1)); - XStoreName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (STRING_ARG (2))); - } + xw_set_wm_name ((x_window_arg (1)), (STRING_ARG (2))); PRIMITIVE_RETURN (UNSPECIFIC); } - + DEFINE_PRIMITIVE ("X-WINDOW-SET-ICON-NAME", Prim_x_window_set_icon_name, 2, 2, "Set the icon name of WINDOW to STRING.") +{ + PRIMITIVE_HEADER (2); + xw_set_wm_icon_name ((x_window_arg (1)), (STRING_ARG (2))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("X-WINDOW-SET-CLASS-HINT", Prim_x_window_set_class_hint, 3, 3, + "Set the class hint of WINDOW to RESOURCE_NAME and RESOURCE_CLASS.") +{ + PRIMITIVE_HEADER (3); + xw_set_class_hint ((x_window_arg (1)), (STRING_ARG (2)), (STRING_ARG (3))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-HINT", Prim_x_window_set_input_hint, 2, 2, + "Set the input hint of WINDOW to INPUT.") +{ + PRIMITIVE_HEADER (2); + xw_set_wm_input_hint ((x_window_arg (1)), (BOOLEAN_ARG (2))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("X-WINDOW-SET-TRANSIENT-FOR-HINT", Prim_x_window_set_transient_for, 2, 2, + "Set the transient-for hint of WINDOW to PRIMARY-WINDOW.") { PRIMITIVE_HEADER (2); { struct xwindow * xw = (x_window_arg (1)); - XSetIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (STRING_ARG (2))); + struct xwindow * transient_for = (x_window_arg (2)); + if ((xw == transient_for) || ((XW_XD (xw)) != (XW_XD (transient_for)))) + error_bad_range_arg (2); + XSetTransientForHint + ((XW_DISPLAY (xw)), + (XW_WINDOW (xw)), + (XW_WINDOW (transient_for))); } PRIMITIVE_RETURN (UNSPECIFIC); } -DEFINE_PRIMITIVE ("X-WINDOW-SET-CLASS-HINT", - Prim_x_graphics_set_class_hint, 4, 4, - "(X-WINDOW-SET-CLASS-HINT DISPLAY WINDOW RESOURCE_CLASS RESOURCE_NAME)\n\ -Set the XA_WM_CLASS property of WINDOW on DISPLAY to RESOURCE_CLASS\n\ -and RESOURCE_NAME.") +DEFINE_PRIMITIVE ("X-WINDOW-ICONIFY", Prim_x_window_iconify, 1, 1, 0) { - PRIMITIVE_HEADER (4); + PRIMITIVE_HEADER (1); { - struct xdisplay * xd = (x_display_arg (1)); - Display * display = (XD_DISPLAY (xd)); - struct xwindow * xw = (x_window_arg (2)); - Window window = (XW_WINDOW (xw)); - XClassHint *class_hint; - - CHECK_ARG (3, STRING_P); - CHECK_ARG (4, STRING_P); - class_hint = XAllocClassHint (); - if (class_hint == NULL) - error_external_return (); - class_hint->res_class = STRING_ARG (3); - class_hint->res_name = STRING_ARG (4); - XSetClassHint (display, window, class_hint); - XFree ((caddr_t) class_hint); + struct xwindow * xw = (x_window_arg (1)); + Display * display = (XW_DISPLAY (xw)); + XIconifyWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display))); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("X-WINDOW-WITHDRAW", Prim_x_window_withdraw, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + struct xwindow * xw = (x_window_arg (1)); + Display * display = (XW_DISPLAY (xw)); + XWithdrawWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display))); } PRIMITIVE_RETURN (UNSPECIFIC); } diff --git a/v7/src/microcode/x11graph.c b/v7/src/microcode/x11graph.c index 916bd3c66..af771516c 100644 --- a/v7/src/microcode/x11graph.c +++ b/v7/src/microcode/x11graph.c @@ -1,9 +1,9 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11graph.c,v 1.18 1991/12/19 19:52:39 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11graph.c,v 1.19 1992/02/08 14:54:24 cph Exp $ -Copyright (c) 1989-91 Massachusetts Institute of Technology +Copyright (c) 1989-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,9 +39,8 @@ MIT in each case. */ #include "prims.h" #include "x11.h" -#define RESOURCE_NAME "scheme-graphics" -#define DEFAULT_RESOURCE_CLASS "SchemeGraphics" -#define DEFAULT_RESOURCE_NAME "schemeGraphics" +#define RESOURCE_NAME "schemeGraphics" +#define RESOURCE_CLASS "SchemeGraphics" #define DEFAULT_GEOMETRY "512x384+0+0" struct gw_extra @@ -299,7 +298,8 @@ If third argument SUPPRESS-MAP? is true, do not map the window immediately.") struct drawing_attributes attributes; struct xwindow_methods methods; XSetWindowAttributes wattributes; - x_default_attributes (display, RESOURCE_NAME, (&attributes)); + x_default_attributes + (display, RESOURCE_NAME, RESOURCE_CLASS, (&attributes)); (wattributes . background_pixel) = (attributes . background_pixel); (wattributes . border_pixel) = (attributes . border_pixel); (wattributes . backing_store) = Always; @@ -317,7 +317,8 @@ If third argument SUPPRESS-MAP? is true, do not map the window immediately.") (XGeometry (display, (DefaultScreen (display)), (((ARG_REF (2)) == SHARP_F) ? (x_get_default - (display, RESOURCE_NAME, "geometry", "Geometry", 0)) + (display, RESOURCE_NAME, RESOURCE_CLASS, + "geometry", "Geometry", 0)) : (STRING_ARG (2))), DEFAULT_GEOMETRY, (attributes . border_width), 1, 1, extra, extra, @@ -346,22 +347,10 @@ If third argument SUPPRESS-MAP? is true, do not map the window immediately.") (XW_X_CURSOR (xw)) = 0; (XW_Y_CURSOR (xw)) = 0; wm_set_size_hint (xw, geometry_mask, x_pos, y_pos); - XStoreName (display, window, "scheme-graphics"); - XSetIconName (display, window, "scheme-graphics"); + xw_set_wm_name (xw, "scheme-graphics"); + xw_set_wm_icon_name (xw, "scheme-graphics"); XSelectInput (display, window, StructureNotifyMask); - if ((ARG_REF (3)) == SHARP_F) - { - XClassHint *class_hint = XAllocClassHint (); - - if (class_hint == NULL) - error_external_return (); - class_hint->res_class = DEFAULT_RESOURCE_CLASS; - class_hint->res_name = DEFAULT_RESOURCE_NAME; - XSetClassHint (display, window, class_hint); - XFree ((caddr_t) class_hint); - XMapWindow (display, window); - XFlush (display); - } + xw_make_window_map (xw, RESOURCE_NAME, RESOURCE_CLASS, (ARG_REF (3))); PRIMITIVE_RETURN (XW_TO_OBJECT (xw)); } } diff --git a/v7/src/microcode/x11term.c b/v7/src/microcode/x11term.c index 1fff18145..7fa00af9a 100644 --- a/v7/src/microcode/x11term.c +++ b/v7/src/microcode/x11term.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11term.c,v 1.15 1991/04/26 05:25:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11term.c,v 1.16 1992/02/08 14:54:26 cph Exp $ -Copyright (c) 1989-91 Massachusetts Institute of Technology +Copyright (c) 1989-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -85,7 +85,8 @@ struct xterm_extra #define HL_ARG(arg) arg_index_integer (arg, 2) -#define RESOURCE_NAME "edwin" +#define RESOURCE_NAME "schemeTerminal" +#define RESOURCE_CLASS "SchemeTerminal" #define DEFAULT_GEOMETRY "80x40+0+0" #define BLANK_CHAR ' ' #define DEFAULT_HL 0 @@ -152,34 +153,37 @@ DEFUN (xterm_process_event, (xw, event), } static void -DEFUN (xterm_wm_set_size_hint, (xw, geometry_mask, x, y), +DEFUN (xterm_set_wm_normal_hints, (xw, geometry_mask, x, y), struct xwindow * xw AND int geometry_mask AND unsigned int x AND unsigned int y) { - Window window = (XW_WINDOW (xw)); - unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); XFontStruct * font = (XW_FONT (xw)); unsigned int fwidth = (FONT_WIDTH (font)); unsigned int fheight = (FONT_HEIGHT (font)); - XSizeHints size_hints; - (size_hints . flags) = - (PResizeInc - | PMinSize + unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); + XSizeHints * size_hints = (XAllocSizeHints ()); + if (size_hints == 0) + error_external_return (); + (size_hints -> flags) = + (PResizeInc | PMinSize | PBaseSize | (((geometry_mask & XValue) && (geometry_mask & YValue)) ? USPosition : PPosition) | (((geometry_mask & WidthValue) && (geometry_mask & HeightValue)) ? USSize : PSize)); - (size_hints . x) = x; - (size_hints . y) = y; - (size_hints . width) = (((XW_X_CSIZE (xw)) * fwidth) + extra); - (size_hints . height) = (((XW_Y_CSIZE (xw)) * fheight) + extra); - (size_hints . width_inc) = fwidth; - (size_hints . height_inc) = fheight; - (size_hints . min_width) = extra; - (size_hints . min_height) = extra; - XSetNormalHints ((XW_DISPLAY (xw)), window, (& size_hints)); + (size_hints -> x) = x; + (size_hints -> y) = y; + (size_hints -> width) = (((XW_X_CSIZE (xw)) * fwidth) + extra); + (size_hints -> height) = (((XW_Y_CSIZE (xw)) * fheight) + extra); + (size_hints -> width_inc) = (FONT_WIDTH (font)); + (size_hints -> height_inc) = (FONT_HEIGHT (font)); + (size_hints -> min_width) = extra; + (size_hints -> min_height) = extra; + (size_hints -> base_width) = extra; + (size_hints -> base_height) = extra; + XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints); + XFree ((caddr_t) size_hints); } static void @@ -384,7 +388,7 @@ DEFUN (xterm_reconfigure, (xw, width, height), (XW_CHARACTER_MAP (xw))= new_char_map; (XW_HIGHLIGHT_MAP (xw))= new_hl_map; xterm_dump_contents (xw, 0, 0, x_csize, y_csize); - xterm_wm_set_size_hint (xw, 0, 0, 0); + xterm_set_wm_normal_hints (xw, 0, 0, 0); XFlush (XW_DISPLAY (xw)); } } @@ -475,7 +479,8 @@ DEFINE_PRIMITIVE ("XTERM-OPEN-WINDOW", Prim_xterm_open_window, 3, 3, 0) Display * display = (XD_DISPLAY (xd)); struct drawing_attributes attributes; struct xwindow_methods methods; - x_default_attributes (display, RESOURCE_NAME, (&attributes)); + x_default_attributes + (display, RESOURCE_NAME, RESOURCE_CLASS, (&attributes)); (methods . deallocator) = xterm_deallocate; (methods . event_processor) = xterm_process_event; (methods . x_coordinate_map) = xterm_x_coordinate_map; @@ -491,7 +496,8 @@ DEFINE_PRIMITIVE ("XTERM-OPEN-WINDOW", Prim_xterm_open_window, 3, 3, 0) (display, (DefaultScreen (display)), (((ARG_REF (2)) == SHARP_F) ? (x_get_default - (display, RESOURCE_NAME, "geometry", "Geometry", 0)) + (display, RESOURCE_NAME, RESOURCE_CLASS, + "geometry", "Geometry", 0)) : (STRING_ARG (2))), DEFAULT_GEOMETRY, (attributes . border_width), (FONT_WIDTH (attributes . font)), (FONT_HEIGHT (attributes . font)), @@ -533,14 +539,11 @@ DEFINE_PRIMITIVE ("XTERM-OPEN-WINDOW", Prim_xterm_open_window, 3, 3, 0) while (scan < end) (*scan++) = DEFAULT_HL; } - xterm_wm_set_size_hint (xw, geometry_mask, x_pos, y_pos); - XStoreName (display, window, "scheme-terminal"); - XSetIconName (display, window, "scheme-terminal"); - if ((ARG_REF (3)) == SHARP_F) - { - XMapWindow (display, window); - XFlush (display); - } + xterm_set_wm_normal_hints (xw, geometry_mask, x_pos, y_pos); + xw_set_wm_input_hint (xw, 1); + xw_set_wm_name (xw, "scheme-terminal"); + xw_set_wm_icon_name (xw, "scheme-terminal"); + xw_make_window_map (xw, RESOURCE_NAME, RESOURCE_CLASS, (ARG_REF (3))); PRIMITIVE_RETURN (XW_TO_OBJECT (xw)); } } @@ -568,6 +571,9 @@ DEFINE_PRIMITIVE ("XTERM-SET-SIZE", Prim_xterm_set_size, 3, 3, 0) xw = (x_window_arg (1)); extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw))); font = (XW_FONT (xw)); + /* Update the WM normal hints so they have the latest values for + font dimensions and internal border width. */ + xterm_set_wm_normal_hints (xw, 0, 0, 0); XResizeWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index 94ac15519..0c064f061 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.65 1992/02/03 23:31:14 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.66 1992/02/08 14:54:07 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -2144,6 +2144,13 @@ Primitive_Internal_Apply: SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression())); break; + case RC_STACK_MARKER: + /* Frame consists of the return code followed by two objects. + The first object has already been popped into the Expression + register, so just pop the second argument. */ + Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1)); + break; + /* Interpret() continues on the next page */ /* Interpret(), continued */ diff --git a/v8/src/microcode/returns.h b/v8/src/microcode/returns.h index cd2467936..c0e3082bd 100644 --- a/v8/src/microcode/returns.h +++ b/v8/src/microcode/returns.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.39 1990/11/21 07:04:43 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.40 1992/02/08 14:54:12 cph Exp $ -Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -35,10 +35,6 @@ MIT in each case. */ /* Return codes. These are placed in Return when an interpreter operation needs to operate in several phases. */ -/* These names are also in storage.c. - Please maintain consistency. - Names should not exceed 31 characters. */ - #define RC_END_OF_COMPUTATION 0x00 /* formerly RC_RESTORE_CONTROL_POINT 0x01 */ #define RC_JOIN_STACKLETS 0x01 @@ -92,7 +88,7 @@ MIT in each case. */ /* The following are not used in the 68000 implementation */ #define RC_POP_RETURN_ERROR 0x40 #define RC_EVAL_ERROR 0x41 -/* formerly RC_REPEAT_PRIMITIVE 0x42 */ +#define RC_STACK_MARKER 0x42 #define RC_COMP_INTERRUPT_RESTART 0x43 /* formerly RC_COMP_RECURSION_GC 0x44 */ #define RC_RESTORE_INT_MASK 0x45 @@ -195,7 +191,7 @@ MIT in each case. */ /* 0x3F */ "", \ /* 0x40 */ "POP_RETURN_ERROR", \ /* 0x41 */ "EVAL_ERROR", \ -/* 0x42 */ "", \ +/* 0x42 */ "STACK_MARKER", \ /* 0x43 */ "COMPILER_INTERRUPT_RESTART", \ /* 0x44 */ "", \ /* 0x45 */ "RESTORE_INT_MASK", \ diff --git a/v8/src/microcode/utabmd.scm b/v8/src/microcode/utabmd.scm index 9f5dd4cd0..7cb3a6487 100644 --- a/v8/src/microcode/utabmd.scm +++ b/v8/src/microcode/utabmd.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.60 1991/10/29 13:59:11 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.61 1992/02/08 14:54:14 cph Exp $ ;;; -;;; Copyright (c) 1987-91 Massachusetts Institute of Technology +;;; Copyright (c) 1987-92 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -440,7 +440,7 @@ #F ;3F POP-RETURN-ERROR ;40 EVAL-ERROR ;41 - REPEAT-PRIMITIVE ;42 + STACK-MARKER ;42 COMPILER-INTERRUPT-RESTART ;43 #F ;44 RESTORE-INTERRUPT-MASK ;45 @@ -698,4 +698,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.60 1991/10/29 13:59:11 cph Exp $" \ No newline at end of file +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.61 1992/02/08 14:54:14 cph Exp $" \ No newline at end of file diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index 4b65a0af5..3d7a12240 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.107 1992/02/04 04:37:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.108 1992/02/08 14:54:19 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 107 +#define SUBVERSION 108 #endif -- 2.25.1