/* -*-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
}
}
\f
+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);
/* -*-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
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 */
\f
/* Interpret(), continued */
/* -*-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
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 */
/* -*-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
OS_directory_make (STRING_ARG (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
+\f
+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\
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,
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,
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))));
+}
+\f
+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))));
+}
/* -*-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
/* Return codes. These are placed in Return when an
interpreter operation needs to operate in several phases. */
\f
-/* 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
/* 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
/* 0x3F */ "", \
/* 0x40 */ "POP_RETURN_ERROR", \
/* 0x41 */ "EVAL_ERROR", \
-/* 0x42 */ "", \
+/* 0x42 */ "STACK_MARKER", \
/* 0x43 */ "COMPILER_INTERRUPT_RESTART", \
/* 0x44 */ "", \
/* 0x45 */ "RESTORE_INT_MASK", \
;;; -*-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
#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
;;; 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
/* -*-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
STD_VOID_SYSTEM_CALL (syscall_mkdir, (UX_mkdir (name, MODE_DIR)));
}
\f
+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));
+}
+\f
+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);
}
+\f
+#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 */
/* -*-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
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 107
+#define SUBVERSION 108
#endif
/* -*-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
#include <X11/cursorfont.h>
#include <X11/keysym.h>
#include <X11/Xutil.h>
+#include <X11/Xatom.h>
#include "ansidecl.h"
\f
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)))
extern unsigned int EXFUN
(allocate_x_colormap, (Colormap colormap, struct xdisplay * xd));
extern void EXFUN (deallocate_x_colormap, (struct xcolormap * xcm));
-
+\f
extern int x_debug;
extern PTR EXFUN (x_malloc, (unsigned int size));
(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
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));
/* -*-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
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);
\f
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)
}
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)));
}
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));
}
}
}
\f
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));
+ }
+}
+\f
+static void
DEFUN (xw_process_event, (xw, event),
struct xwindow * xw AND
XEvent * 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;
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);
}
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
};
#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)))
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));
{
}
VECTOR_SET (result, EVENT_2, conversion);
}
+ EVENT_INTEGER (result, EVENT_3, (event -> time));
return (result);
}
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,
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);
}
}
\f
+#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)
{
((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);
}
}
(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));
}
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)
}
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);
+}
\f
DEFINE_PRIMITIVE ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 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)),
"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);
}
-\f
+
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);
+}
+\f
+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);
}
/* -*-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
#include "prims.h"
#include "x11.h"
\f
-#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
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;
(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,
(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));
}
}
/* -*-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
#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
}
\f
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
(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));
}
}
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;
(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)),
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));
}
}
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)),
/* -*-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
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 */
\f
/* Interpret(), continued */
/* -*-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
/* Return codes. These are placed in Return when an
interpreter operation needs to operate in several phases. */
\f
-/* 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
/* 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
/* 0x3F */ "", \
/* 0x40 */ "POP_RETURN_ERROR", \
/* 0x41 */ "EVAL_ERROR", \
-/* 0x42 */ "", \
+/* 0x42 */ "STACK_MARKER", \
/* 0x43 */ "COMPILER_INTERRUPT_RESTART", \
/* 0x44 */ "", \
/* 0x45 */ "RESTORE_INT_MASK", \
;;; -*-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
#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
;;; 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
/* -*-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
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 107
+#define SUBVERSION 108
#endif
projects / mit-scheme.git / commitdiff