which included commits to RCS files with non-trunk default branches.
This is usually because xmkmf is not in your path or because you are
using the default cygwin shell. The default cygwin shell (/bin/sh.exe)
-is ash which appears to work in most circumstances but has some wierd
+is ash which appears to work in most circumstances but has some weird
failure modes. I recommend replacing sh.exe with bash.exe, this will
mean configure is slower but more reliable.
Or you could set TERMCAP only when you set TERM--which should not
happen in a non-login shell.
-*** The popup menu appears at the buttom/right of my screen.
+*** The popup menu appears at the bottom/right of my screen.
You probably have something like the following in your ~/.Xdefaults
launched. Forcing a static link of libc.a alone by adding
/usr/lib/libc.a at the end of the link line solves this. Note that
my 9.07 build of 19.14b17 and my (old) build of 19.13 both exhibit
- the same behaviour. I've tried various hpux patches to no avail. If
+ the same behavior. I've tried various hpux patches to no avail. If
this problem cannot be solved before the release date, binary kits
for HP *must* be linked statically against libc, otherwise this
problem will show up. (This is directed at whoever will volunteer
if test -n "$dll_cflags"; then
AC_MSG_RESULT([${dll_cflags}])
-
+
# Check to make sure the dll_cflags actually works.
AC_MSG_CHECKING([if PIC flag ${dll_cflags} really works])
save_CFLAGS="$CFLAGS"
dnl I believe that libtool is incorrect in trying to drive the linker
dnl directly. This can cause considerable problems if the module you are
dnl compiling has C++ or other static initializers. If we use ld directly,
-dnl we dont end up with the crt stuff being linked in, and we dont end up
+dnl we don't end up with the crt stuff being linked in, and we don't end up
dnl with any .init or .fini sections (or the moral equivalent thereof).
-dnl gcc takes great care to do this propperly when invoked in -shared
-dnl mode, and we really do want this behaviour. Perhaps the libtool folks
+dnl gcc takes great care to do this properly when invoked in -shared
+dnl mode, and we really do want this behavior. Perhaps the libtool folks
dnl are not aware that any SVR4 based dynamic loader will automatically
dnl execute code in the .init section before dlopen() returns. This is
-dnl vital, as the module may have been compiled to rely on that behaviour.
+dnl vital, as the module may have been compiled to rely on that behavior.
dnl
dnl So, having said all of that, we diverge from libtool significantly
dnl here. We want to try and use the C compiler as much as possible. Only
dnl gcc uses, which can be the internal collect2 that comes with gcc.
dnl If the user ever changes their compiler version, the paths will no
dnl longer be correct, and ellcc will break. This is clearly unacceptable.
-dnl By using the compiler driver on the path, we dont have this problem.
+dnl By using the compiler driver on the path, we don't have this problem.
dnl If that is not clear, consider that gcc -print-prog-name=ld can
dnl produce something along the lines of:
dnl /usr/local/lib/gcc-lib/OS-NAME/GCC-VERSION/ld
dnl shared objects, we try that. Only if all of that fails do we revert
dnl back to the libtool ld trickery.
dnl
-dnl We dont do ANY of this if we can't produce shared objects.
+dnl We don't do ANY of this if we can't produce shared objects.
dnl
if test "$can_build_shared" = "yes"; then
cc_produces_so=no
dnl Last thing, check how to get a linked executable to have its symbols
dnl exported, so that the modules have access to them.
dnl
-dnl XEmacs FIXME - we need to set ld_dynamic_link_flags propperly for
+dnl XEmacs FIXME - we need to set ld_dynamic_link_flags properly for
dnl most of these systems, which was missing from libtool. I know they
dnl all have a way of doing this, but someone needs to look at this
dnl for each OS and make sure it is correct. Remember that the arguments
--with-debug-malloc Use the debugging malloc package.
--with-clash-detection Use lock files to detect multiple edits of the same
file. The default is to do clash detection.
---lockdir=DIR The directory to put clash detection files in, such as
- `/var/lock/emacs'.
- Defaults to `${statedir}/xemacs/lock'.
You may also specify any of the `path' variables found in Makefile.in,
including --bindir, --libdir, --docdir, --lispdir, --sitelispdir,
* Note. under this mechanism, any data item that undergoes
* relocation and is then further modified during the execution of
* the image before dynodump(3x) is called will lose the
- * modification that occured during the applications execution.
+ * modification that occurred during the applications execution.
*
* N.B. The above commentary is not quite correct in the flags have been hardwired
* to RTLD_SAVREL.
*/
-#pragma ident "@(#) $Id: dynodump.c,v 1.6 1998/03/31 20:10:55 steve Exp $ - SMI"
+#pragma ident "@(#) $Id: dynodump.c,v 1.6.2.2 2000/09/20 02:39:17 martinb Exp $ - SMI"
#define __EXTENSIONS__ 1
* If we had a .heap section, then its size is part of the program
* headers notion of data size. Because we're only going to output one
* heap section (ignoring the one in the running binary) we need to
- * subract the size of that which we're ignoring.
+ * subtract the size of that which we're ignoring.
*/
if (heap_cache) {
edata = S_ROUND((data_phdr->p_vaddr
tibetan-1-column:241:2:94:4:1:0:56:0:Tibetan 1 column glyph
tibetan:252:2:94:4:2:0:55:0:Tibetan characters
lao:167:1:94:3:1:0:49:0:Lao characters (ISO10646 0E80..0EDF)
-indian-1-column:240:2:94:4:1:0:54:0:Indian charset for 2-column width glypps
+indian-1-column:240:2:94:4:1:0:54:0:Indian charset for 2-column width glyphs
indian-2-column:251:2:94:4:2:0:53:0:Indian charset for 2-column width glyphs
indian-is13194:225:1:94:3:2:0:53:1:Generic Indian charset for data exchange with IS 13194
ascii-right-to-left:166:1:94:3:1:1:66:0:ASCII (left half of ISO8859-1) with right-to-left direction
!
! See the NEWS file (C-h n) or XEmacs manual (C-h i) for a description of
! the various resources and the syntax for setting them.
-!
-! Energize users: note that this is not the same app-defaults file that is
-! used with the Energize-specific version of XEmacs.
! Colors and backgrounds.
! Note that the menubar resources do not use the `face' syntax, since they
! are X toolkit widgets and thus outside the domain of XEmacs proper.
!
+! When X Font Sets are enabled with ./configure --with-xfs (eg, for
+! multilingual menubars and XIM), some .font resources (those specific to
+! the Lucid widget set) are ignored in favor of .fontSet resources. This
+! example shows how to add fonts for Japanese menubars:
+!
+! *menubar*FontSet: -*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-*, \
+! -*-*-*-*-*-*-*-120-*-jisx0208.1983-0
+!
*menubar*Font: -*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-*
*popup*Font: -*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-*
per X.
The only thing selection doesn't do is set the clipboard automatically
-as this would break the MS-Windows model. If you want this behaviour
-then set `selection-sets-clipboard' to t
+as this would break the MS-Windows model. If you want this behavior
+then set `selection-sets-clipboard' to t.
** Mail spool locking now works correctly.
XEmacs has always come with a little auxiliary program, movemail,
** Pixel-based scrolling has been implemented.
By default this will attempt to scroll in increments equal to the
height of the default face. Set `window-pixel-scroll-increment' to
-modify this behaviour.
+modify this behavior.
** Operation progress can be displayed using graphical widgets.
See `lprogress-display' for details. This support has been switched
on by default for font-lock and some web browsing functions. If you
-do not like this behaviour set `progress-display-use-echo-area'.
+do not like this behavior set `progress-feedback-use-echo-area'.
** The PostgreSQL Relational Database Management System is now supported.
It is now possible to build XEmacs so that the programming interface
for most packages (and some core Lisp files) to use correctly. Also,
the `init-file-user' variable has been obsoleted in the process.
-The user-visible options like `-u' have not changed their behaviour.
+The user-visible options like `-u' have not changed their behavior.
** XEmacs finally has an automated test suite!
Although this is not yet very sophisticated, it is already responsible
(keywordp (intern ":foo")) ; The same as (keywordp :foo)
=> t
-This behaviour is compatible with other code which treats symbols
+This behavior is compatible with other code which treats symbols
beginning with colon as keywords only if they are interned in the
global obarray. `keywordp' used to wrongly return t in both cases
above.
customizable Common Lisp like one (implemented entirely in Emacs
Lisp). During reading of Emacs Lisp source files, it is about 40%
slower than the built-in reader, but there is no difference in
-loading byte compiled files - they dont contain any syntactic sugar
+loading byte compiled files - they don't contain any syntactic sugar
and are loaded with the built in subroutine `load'.
** ediff - Compare and merge files with graphical difference display
which an XEmacs process is currently running.
.PP
\fIgnudoit\fP is a shell script frontend to ``gnuclient -batch -eval form''.
-Its use is depreciated. Try to get used to calling gnuclient directly.
+Its use is deprecated. Try to get used to calling gnuclient directly.
.PP
\fIgnuserv\fP is the server program that is set running by XEmacs to
handle all incoming and outgoing requests. It is not usually invoked
#
# The largish sed script prefixes all version numbers with a sort key.
# That key is constructed by padding out any single or double digits to 3
-# digits from the version number, then converting all occurences of `.' to
+# digits from the version number, then converting all occurrences of `.' to
# `0', and prefixing and suffixing the entire result with an additional
# zero. After sorting, the sort key is stripped from the output.
# We do all this because `sort' cannot numerically sort decimal numbers and
-.TH XEMACS 1 "1998 January 13"
+.TH XEMACS 1 "2000-09-20"
.UC 4
.SH NAME
xemacs \- Emacs: The Next Generation
,
.B \-no-site-file
, and
-.B \-no-packages
+.B \-no-early-packages
\.
.TP
.BI \-u " user, " \-user " user"
(useful with
.BR \-batch ).
.PP
-.SM Using XEmacs with X
+.SM Using XEmacs with X Windows
.PP
.I XEmacs
has been tailored to work well with the X window system.
If you run
.I XEmacs
-from under X windows, it will create its own X window to
-display in. You will probably want to start the editor
-as a background process
-so that you can continue using your original window.
+from under X windows, it will create its own X window to display in.
.PP
.I XEmacs
can be started with the following standard X options:
for more information.
.TP
.B -privateColormap
-Require XEmacs to create and use a private colormap for display. This will keep
-XEmacs from taking colors from the default colormap and keeping them from other
-clients.
+Require XEmacs to create and use a private colormap for display. This
+will keep XEmacs from taking colors from the default colormap and
+keeping them from other clients, at the cost of causing annoying
+flicker when the focus changes. Use this option only if your X server
+does not support 24 bit visuals.
.TP
.BI \-geometry " ##x##+##+##"
Specify the geometry of the initial window. The ##'s represent a number;
.BI \-xrm " argument"
This allows you to set an arbitrary resource on the command line.
.I argument
-should be a resource specification, as might as in your
+should be a resource specification, as might be found in your
.I \.Xresources
or
.I \.Xdefaults
.IR on ,
the window will be displayed in reverse video. Consider
explicitly setting the foreground and background colors instead
-of using this resources.
+of using this resource.
.TP
.B borderWidth (\fPclass\fB BorderWidth)
Sets the window's border width in pixels.
will try to use (as described above).
.TP
.B privateColormap (\fPclass\fB PrivateColormap)
-If set,
+If set,
.I XEmacs
will default to using a private colormap.
.TP
Sets the position of vertical and horizontal scrollbars. Should be one
of the strings "top-left", "bottom-left", "top-right", or "bottom-right".
The default is "bottom-right" for the Motif and Lucid scrollbars and
-"buttom-left" for the Athena scrollbars.
+"bottom-left" for the Athena scrollbars.
.TP
.B topToolBarHeight (\fPclass\fB TopToolBarHeight)
Sets the height of the top toolbar, in pixels. 0 means no top toolbar.
/usr/local/lib/xemacs-$VERSION/info - the Info files may be here instead.
-/usr/local/lib/xemacs-$VERSION/src - C source files and object files.
-(May not be present.)
-
/usr/local/lib/xemacs-$VERSION/lisp/* - Lisp source files and compiled files
that define most editing commands. The files are contained in subdirectories,
categorized by function or individual package. Some are preloaded;
preloaded Lisp functions of \fIXEmacs\fP.
They are stored here to reduce the size of \fIXEmacs\fP proper.
-.br
-/usr/local/lib/xemacs-$VERSION/etc/SERVICE - lists people offering
-various services to assist users of \fIXEmacs\fP,
-including education, troubleshooting, porting and customization.
-
-/usr/local/lib/xemacs/lock - holds lock files that are made for all
-files being modified in
-.IR XEmacs ,
-to prevent simultaneous modification of one file by two users.
-
/usr/local/lib/xemacs/site-lisp - locally-provided Lisp files.
-
-/usr/lib/X11/rgb.txt - list of valid X color names.
.PP
.SH BUGS AND HELP
There is a newsgroup, comp.emacs.xemacs, for reporting
+2000-10-04 Martin Buchholz <martin@xemacs.org>
+
+ * XEmacs 21.2.36 is released.
+
+2000-09-30 Martin Buchholz <martin@xemacs.org>
+
+ * gnuserv.c (main): Warning removal.
+
+2000-09-27 Martin Buchholz <martin@xemacs.org>
+
+ * ellcc.c: Make global variables static. Avoids warnings on AIX.
+
+ * fakemail.c (make_file_preface): Use standard type time_t.
+ Actually check that the 25th char returned from ctime is '\n'.
+
+2000-09-19 Martin Buchholz <martin@xemacs.org>
+
+ * *: Spelling mega-patch
+
+2000-09-12 Martin Buchholz <martin@xemacs.org>
+
+ * gnuclient.c (main):
+ * hexl.c (usage):
+ Use `Usage', not `usage', in Usage messages.
+
+2000-07-15 Ben Wing <ben@xemacs.org>
+
+ * etags.c (add_regex): added commented out code for use figuring
+ out Windows quoting problems.
+ * hexl.c (main): fixed warnings about possible used uninitialized.
+
2000-07-19 Martin Buchholz <martin@xemacs.org>
* XEmacs 21.2.35 is released.
* exist in your home directory, containing individual mail messages in
* separate files in the standard gosling emacs mail reader format.
*
- * Program takes one argument: an output file. THis file will contain
+ * Program takes one argument: an output file. This file will contain
* all the messages in Messages directory, in berkeley mail format.
* If no output file is mentioned, messages are put in ~/OMAIL.
*
* In order to get rmail to read the messages, the resulting file must
* be mv'ed to ~/mbox, and then have rmail invoked on them.
- *
+ *
* Author: Larry Kolodney, 1985
*/
fclose (cff);
}
fclose (mddf);
- fclose (mfilef);
+ fclose (mfilef);
return 0;
}
#include <config.h>
#include <stdio.h>
#include <stdlib.h>
+#include <stddef.h>
#include <string.h>
#include <ctype.h>
#include <errno.h>
#define ELLCC_LINK_MODE 1
#define ELLCC_INIT_MODE 2
-int ellcc_mode = ELLCC_COMPILE_MODE;
-char *progname;
-char *mod_name = (char *)0, *mod_version = (char *)0, *mod_title = (char *)0;
-char *mod_output = (char *)0;
-int verbose = 0;
-char **exec_argv;
-int exec_argc = 1, *exec_args;
-int real_argc = 0;
-int prog_argc;
-char **prog_argv;
+static int ellcc_mode = ELLCC_COMPILE_MODE;
+static char *progname;
+static char *mod_name = NULL;
+static char *mod_version = NULL;
+static char *mod_title = NULL;
+static char *mod_output = NULL;
+static int verbose = 0;
+static char **exec_argv;
+static int exec_argc = 1;
+static int *exec_args;
+static int real_argc = 0;
+static int prog_argc;
+static char **prog_argv;
/*
* We allow the user to over-ride things in the environment
patbuf->buffer = NULL;
patbuf->allocated = 0;
+#if 0 /* useful when debugging windows quoting convention problems */
+ printf ("Compiling regex pattern: %s\n", regexp_pattern);
+#endif
+
err = re_compile_pattern (regexp_pattern, strlen (regexp_pattern), patbuf);
if (err != NULL)
{
make_file_preface (void)
{
char *the_string, *temp;
- long idiotic_interface;
+ time_t idiotic_interface;
long prefix_length;
long user_length;
long date_length;
the_date = ctime (&idiotic_interface);
/* the_date has an unwanted newline at the end */
date_length = strlen (the_date) - 1;
- the_date[date_length] = '\0';
+ if (the_date[date_length] == '\n')
+ the_date[date_length] = '\0';
#ifdef WIN32_NATIVE
temp = "(null)";
#else
/* Assume relative Unix style path. Get the current directory
and prepend it. FIXME: need to fix the case of DOS paths like
"\foo", where we need to get the current drive. */
-
+
strcat (fullpath, get_current_working_directory ());
len = strlen (fullpath);
{
fprintf (stderr,
#ifdef INTERNET_DOMAIN_SOCKETS
- "usage: %s [-nw] [-display display] [-q] [-v] [-l library]\n"
+ "Usage: %s [-nw] [-display display] [-q] [-v] [-l library]\n"
" [-batch] [-f function] [-eval form]\n"
" [-h host] [-p port] [-r remote-path] [[+line] file] ...\n",
#else /* !INTERNET_DOMAIN_SOCKETS */
- "usage: %s [-nw] [-q] [-v] [-l library] [-f function] [-eval form] "
+ "Usage: %s [-nw] [-q] [-v] [-l library] [-f function] [-eval form] "
"[[+line] path] ...\n",
#endif /* !INTERNET_DOMAIN_SOCKETS */
progname);
progname);
exit (1);
}
- /* Don't do disconnect_from_server becasue we have already read
+ /* Don't do disconnect_from_server because we have already read
data, and disconnect doesn't do anything else. */
#ifndef INTERNET_DOMAIN_SOCKETS
if (connect_type == (int) CONN_IPC)
{
perror(progname);
fprintf(stderr,"%s: unable to select\n",progname);
- exit(1);
+ return 1;
} /* if */
#ifdef UNIX_DOMAIN_SOCKETS
if (FD_ISSET(fileno(stdin), &rmask)) /* from stdin (gnu process) */
handle_response();
#endif /* NOT SYSV_IPC */
- } /* while */
-
- return 0;
+ } /* while (1) */
} /* main */
#endif /* SYSV_IPC || UNIX_DOMAIN_SOCKETS || INTERNET_DOMAIN_SOCKETS */
#endif
for (;;)
{
- register int i, c, d;
+ register int i, c = 0, d;
#define hexchar(x) (isdigit (x) ? x - '0' : x - 'a' + 10)
string[17] = '\0';
for (;;)
{
- register int i, c;
+ register int i, c = 0;
for (i=0; i < 16; ++i)
{
void
usage (void)
{
- (void) fprintf (stderr, "usage: %s [-de] [-iso]\n", progname);
+ fprintf (stderr, "Usage: %s [-de] [-iso]\n", progname);
exit (1);
}
-/*
-
-
+/*
+
+
PROPOSAL FOR HOW THIS ALL OUGHT TO WORK
this isn't implemented yet, but this is the plan-in-progress
-
+
In general, it's accepted that the best way to internationalize is for all
messages to be referred to by a symbolic name (or number) and come out of a
table or tables, which are easy to change.
something has gone wrong. (Except to do things like remove assumptions
about the order of words within a sentence, or how pluralization works.)
- There are two parts to the task of displaying translated strings to the
+ There are two parts to the task of displaying translated strings to the
user: the first is to extract the strings which need to be translated from
the sources; and the second is to make some call which will translate those
strings before they are presented to the user.
-
+
The old way was to use the same form to do both, that is, GETTEXT() was both
the tag that we searched for to build a catalog, and was the form which did
the translation. The new plan is to separate these two things more: the
already, and the translation will get done in some more centralized, lower
level place.
- This program (make-msgfile.c) addresses the first part, extracting the
+ This program (make-msgfile.c) addresses the first part, extracting the
strings.
-
+
For the emacs C code, we need to recognize the following patterns:
-
+
message ("string" ... )
error ("string")
report_file_error ("string" ... )
signal_simple_error ("string" ... )
signal_simple_error_2 ("string" ... )
-
+
build_translated_string ("string")
#### add this and use it instead of build_string() in some places.
-
+
yes_or_no_p ("string" ... )
#### add this instead of funcalling Qyes_or_no_p directly.
barf_or_query_if_file_exists #### restructure this
check all callers of Fsignal #### restructure these
signal_error (Qerror ... ) #### change all of these to error()
-
+
And we also parse out the `interactive' prompts from DEFUN() forms.
-
+
#### When we've got a string which is a candidate for translation, we
should ignore it if it contains only format directives, that is, if
there are no alphabetic characters in it that are not a part of a `%'
directive. (Careful not to translate either "%s%s" or "%s: ".)
For the emacs Lisp code, we need to recognize the following patterns:
-
+
(message "string" ... )
(error "string" ... )
(format "string" ... )
(read-file-name "string" ... )
(temp-minibuffer-message "string")
(query-replace-read-args "string" ... )
-
+
I expect there will be a lot like the above; basically, any function which
is a commonly used wrapper around an eventual call to `message' or
`read-from-minibuffer' needs to be recognized by this program.
(dgettext "domain-name" "string") #### do we still need this?
-
+
things that should probably be restructured:
`princ' in cmdloop.el
`insert' in debug.el
face-interactive
help.el, syntax.el all messed up
-
+
Menu descriptors: one way to extract the strings in menu labels would be
to teach this program about "^(defvar .*menu\n" forms; that's probably
"string" ... ;###translate
- where the magic token ";###translate" on a line means that the string
- constant on this line should go into the message catalog. This is analagous
+ where the magic token ";###translate" on a line means that the string
+ constant on this line should go into the message catalog. This is analogous
to the magic ";###autoload" comments, and to the magic comments used in the
EPSF structuring conventions.
translations, there are hooks in a small number of low level places in
emacs.
- Assume the existence of a C function gettext(str) which returns the
+ Assume the existence of a C function gettext(str) which returns the
translation of `str' if there is one, otherwise returns `str'.
- message() takes a char* as its argument, and always filters it through
Solving the "translating too much" problem:
The concern has been raised that in this situation:
- "Help" is a string for which we know a translation;
- - someone visits a file called Help, and someone does something
+ - someone visits a file called Help, and someone does something
contrived like (error buffer-file-name)
then we would display the translation of Help, which would not be correct.
We can solve this by adding a bit to Lisp_String objects which identifies
them as having been read as literal constants from a .el or .elc file (as
- opposed to having been constructed at run time as it would in the above
+ opposed to having been constructed at run time as it would in the above
case.) To solve this:
- Fmessage() takes a lisp string as its first argument.
else
process_Lisp_file ();
fputc ('\n', outfile);
-
+
fclose (infile);
}
instead of 1000.
(find-tag-internal): Use `letf'.
(tags-delete): Removed -- was unused.
- (set-buffer-tag-table): Use `expland-file-name'.
+ (set-buffer-tag-table): Use `expand-file-name'.
(get-tag-table-buffer): Use `ecase'.
(add-to-tag-completion-table): Mark the filename messages with
progress.
* modes/lazy-shot.el (lazy-shot-mode): Unstall lazy-shot only if
needed.
- (lazy-shot-fontify-internal): Functionality put in seperate function.
+ (lazy-shot-fontify-internal): Functionality put in separate function.
(lazy-shot-lock-extent): Use it.
(lazy-shot-fontify-region): Dumb implementation added.
(lazy-shot-unstall-after-fontify): Needed to disable lazy
;; Copyright (C) 1991, 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
-;; Copyright (C) 1996 Ben Wing.
+;; Copyright (C) 1996, 2000 Ben Wing.
;; Author: Roland McGrath <roland@gnu.ai.mit.edu>
;; Keywords: maint
(directory-file-name
(file-name-directory file))))
"\\\\" "/"))
-
+
;;;###autoload
(defun generate-file-autoloads (file &optional funlist)
"Insert at point a loaddefs autoload section for FILE.
updated.")
(defconst cusload-file-name "custom-load.el"
- "Generic filename ot put custom loads into.
-Unless you are an XEmacs maintainr, it is probably unwise to change this.")
+ "Generic filename to put custom loads into.
+Unless you are an XEmacs maintainer, it is probably unwise to change this.")
;;;###autoload
(defun update-file-autoloads (file)
(goto-char (point-max))
(insert "\n(provide '" sym ")\n")))))
-;; #### this function is almost identical, but subtly different,
-;; from batch-update-autoloads. Steve, it's your responsibility to
-;; clean this up. The two should be merged, but I'm not sure what
-;; package-creation scripts out there might be using this. --ben
+(defvar autoload-package-name nil)
+
+;; #### this function is almost identical to, but subtly different from,
+;; batch-update-autoloads. Both of these functions, unfortunately, are
+;; used in various build scripts in xemacs-packages. They should be
+;; merged. (However, it looks like no scripts pass more than one arg,
+;; making merging easy.) --ben
;;;###autoload
(defun batch-update-directory ()
(setq command-line-args-left nil)))
;; #### i created the following. this one and the last should be merged into
-;; batch-update-autoloads. --ben
+;; batch-update-autoloads and batch-update-one-directory. --ben
;;;###autoload
(defun batch-update-one-directory ()
;; Copyright (C) 1997 Adrian Aichner
;; Author: Adrian Aichner <adrian@xemacs.org>
-;; Date: Sun., Apr. 20, 1997, 1998, 1999.
-;; Version: 1.35
+;; Date: Sun., Apr. 20, 1997-2000.
+;; Version: $Revision: 1.5.2.6 $
;; Keywords: internal
;; This file is part of XEmacs.
;;; Code:
(require 'config)
+(require 'custom)
+(require 'cl)
(provide 'build-report)
-;; Due to recommendation by developers on xemacs-beta@xemacs.org,
-;; release versions are to be checked out using `co -u -kv ...'.
-(defconst build-report-version
- "1.35"
- "Version number of build-report.")
+;;; Constant definitions used internally by `build-report'. These are not
+;;; anticipated to be changed by users of `build-report'.
+;;; If users do need to change the value of any of these, they need to do
+;;; it after `build-report' has been loaded (not just required). Please
+;;; report it to the maintainers of `build-report' when you think you
+;;; need to do this.
+(defconst build-report-installation-version-regexp
+ "XEmacs\\s-+\\([0-9]+\\)\\.\\([0-9]+\\)\\(\\(-b\\|\\.\\)\\([0-9]+\\)\\)?\\s-+\\\\?\"\\([^\\\"]+\\)\\\\?\"\\s-+configured\\s-+for\\s-+`\\(.+\\)'\\."
+ "*REGEXP matching XEmacs Beta Version string in
+`build-report-installation-file' file. This variable is used by
+`build-report-installation-data'.")
+
+(defconst build-report-version-file-regexp
+ "emacs_major_version\\s-*=\\s-*\\([0-9]+\\)
+emacs_minor_version\\s-*=\\s-*\\([0-9]+\\)
+emacs_beta_version\\s-*=\\s-*\\([0-9]+\\)?
+xemacs_codename\\s-*=\\s-*\"\\([^\"]+\\)\""
+ "*REGEXP matching XEmacs Beta Version variable assignments in
+`build-report-version-file' file. This variable is used by
+`build-report-version-file-data'.")
+
+(defconst build-report-installation-srcdir-regexp
+ "\\s-*Where should the build process find the source code\\?\\s-*\\(.*\\)$"
+ "REGEXP matching XEmacs Beta srcdir as the first substring match in
+`build-report-installation-file' file. This variable is used by
+`build-report-installation-data'.")
+
+;;; Customization support for build-report starts here.
(defgroup build-report nil
- "Package automating the process of sending XEmacs Build Reports."
+ "Standardizes the Creation of XEmacs Build Reports."
+ :load 'build-report
:group 'build)
(defcustom build-report-destination
- "xemacs-build-reports@xemacs.org"
- "The mail address XEmacs Build Reports should go to."
- :type 'string
+ (quote ("XEmacs Build Reports List <xemacs-build-reports@xemacs.org>"
+ "XEmacs Beta List <xemacs-beta@xemacs.org>"))
+ "*The list of mail addresses XEmacs Build Reports should most likely
+go to."
+ :type '(repeat
+ :custom-show t
+ :documentation-shown t
+ string)
:group 'build-report)
(defcustom build-report-keep-regexp
- (list
- "make\\["
- "error"
- "warn"
- "pure.*\\(space\\|size\\)"
- "hides\\b"
- "strange"
- "shadowings"
- "^Compilation"
- "not\\s-+found")
- "Regexp of make process output lines to keep in the report."
- :type '(repeat regexp)
+ (quote ("^\\(cd\\|n?make\\)\\s-" "errors?" "warnings?"
+ "pure.*\\(space\\|size\\)" "hides\\b" "strange" "shadowings"
+ "^Compil\\(ing\\s-+in\\|ation\\)" "^Using" "not\\s-+found"
+ "^While\\s-+compiling.*\\(\n\\s-+.+\\)*" "^Note:"
+ "Installing" "[Ff]ile(s) copied"
+ "\\s-+tests\\s-+"))
+ "*Regexp of make process output lines to keep in the report."
+ :type '(repeat
+ :custom-show t
+ :documentation-shown t
+ regexp)
:group 'build-report)
(defcustom build-report-delete-regexp
- (list
- "confl.*with.*auto-inlining"
- (concat (regexp-quote (gethash 'blddir (config-value-hash-table))) "/lisp/[^ \t\n]+ hides "))
- "Regexp of make process output lines to delete from the report."
- :type '(repeat regexp)
+ (quote ("confl.*with.*auto-inlining" "^Formatting:"))
+ "*Regexp of make process output lines to delete from the report."
+ :type '(repeat
+ :custom-show t
+ :documentation-shown t
+ regexp)
:group 'build-report)
-(defcustom build-report-make-output-file
- (concat (gethash 'blddir (config-value-hash-table)) "/beta.err")
- "Filename where stdout and stderr of XEmacs make process have been stored.
-mk.err will not be created automatically. You'll have to run make with
-output redirection. I use an alias
+(defcustom build-report-make-output-dir
+ (cond
+ ((equal system-type 'windows-nt)
+ (expand-file-name "nt"
+ (gethash 'blddir (config-value-hash-table))))
+ (t
+ (gethash 'blddir (config-value-hash-table))))
+ "*Directory where the build report file is found.
+ If this is empty or nil, the default, it is replaced by the value of
+ the XEmacs build directory."
+ :type '(directory
+ :custom-show t
+ :documentation-shown t)
+ :group 'build-report)
+
+(defcustom build-report-make-output-files
+ (quote ("beta.err"))
+ "*List of Filenames where stdout and stderr of XEmacs make process
+have been stored. These are relative to
+`build-report-make-output-dir`. You'll have to run make with output
+redirection or use the `build' XEmacs package to save this output. You
+may use following alias
+
alias mk 'make \!* >>&\! \!$.err &'
-for that, so that I get beta.err went I run `mk beta'."
- :type 'file
+
+under csh, so that you get beta.err went you run `mk beta'."
+ :type '(repeat
+ :custom-show t
+ :documentation-shown t
+ file)
:group 'build-report)
(defcustom build-report-installation-file
- (concat (gethash 'blddir (config-value-hash-table)) "/Installation")
- "Installation file produced by XEmacs configure process."
- :type 'file
+ (expand-file-name "Installation"
+ (gethash 'blddir (config-value-hash-table)))
+ "*Installation file produced by XEmacs configure process."
+ :type '(file
+ :custom-show t
+ :documentation-shown t)
:group 'build-report)
-(defcustom build-report-installation-insert-all nil
- "Tell build-report to insert the whole Installation file
-instead of just the last report."
+(defcustom build-report-version-file
+ (expand-file-name
+ "version.sh"
+ (gethash 'blddir (config-value-hash-table)))
+ "*version.sh file identifying XEmacs (Beta) Distribution."
+ :type '(file
+ :custom-show t
+ :documentation-shown t)
+ :group 'build-report)
+
+(defcustom build-report-installation-insert-all
+ nil
+ "*Tell build-report to insert the whole Installation file
+ instead of just the last report."
:type 'boolean
:group 'build-report)
(defcustom build-report-subject
(concat "[%s] " emacs-version " on " system-configuration)
- "XEmacs Build Report Subject Line. %s-sequences will be substituted
-with user input through `build-report' according to
-`build-report-prompts' using `format'."
- :type 'string
+ "*XEmacs Build Report Subject Line. %s-sequences will be substituted
+ with user input through `build-report' according to
+ `build-report-prompts' using `format'."
+ :type '(string
+ :custom-show t
+ :documentation-shown t)
:group 'build-report)
(defcustom build-report-prompts
- '(("Status?: " "Success" "Failure"))
- "XEmacs Build Report Prompt(s). This is a list of prompt-string
-lists used by `build-report' in conjunction with
-`build-report-subject'. Each list consists of a prompt string
-followed by any number of strings which can be chosen via the history
-mechanism."
+ (quote (("Status?: " ("Success" "Failure"))))
+ "*XEmacs Build Report Prompt(s). This is a list of prompt-string
+ lists used by `build-report' in conjunction with
+ `build-report-subject'. Each list consists of a prompt string
+ followed by any number of strings which can be chosen via the history
+ mechanism."
+ :type '(repeat
+ :custom-show t
+ :documentation-shown t
+ (list
+ :tag "Prompt"
+ string
+ (repeat
+ :tag "Values"
+ string)))
:group 'build-report)
(defcustom build-report-file-encoding
"7bit"
- "XEmacs Build Report File Encoding to be used when MIME support is
-available."
+ "*XEmacs Build Report File Encoding to be used when MIME support is
+ available."
:group 'build-report)
;; Symbol Name mappings from TM to SEMI serving as Compatibility
(defalias 'mime-edit-insert-binary-file
'mime-editor/insert-binary-file)))
+(defun build-report-make-output-get ()
+ "Returns the filename the XEmacs make output is saved in."
+ (interactive)
+ (if (or (string-equal build-report-make-output-dir "")
+ (null build-report-make-output-dir))
+ (mapcar
+ (function
+ (lambda (f)
+ (expand-file-name
+ f
+ (file-name-as-directory
+ (gethash 'blddir (config-value-hash-table))))))
+ build-report-make-output-files)
+ (mapcar
+ (function
+ (lambda (f)
+ (expand-file-name
+ f
+ (file-name-as-directory build-report-make-output-dir))))
+ build-report-make-output-files)))
+
;;;###autoload
(defun build-report (&rest args)
- "Initializes a fresh mail composition buffer using `compose-mail'
-with the contents of XEmacs Installation file and excerpts from XEmacs
-make output and errors and leaves point at the beginning of the mail text.
- See also
-`compose-mail', `mail-user-agent',
-`build-report-destination',
-`build-report-keep-regexp',
-`build-report-delete-regexp',
-`build-report-make-output-file' and
-`build-report-installation-file'."
+ "Composes a fresh mail message with the contents of the built XEmacs
+Installation file and excerpts from XEmacs make output.
+`compose-mail' is used to create the mail message. Point is left at
+the beginning of the mail text. You may add some personal notes if
+you like and send the report.
+See also
+ `compose-mail', `mail-user-agent',
+ `build-report-destination',
+ `build-report-keep-regexp',
+ `build-report-delete-regexp',
+ `build-report-make-output-dir',
+ `build-report-make-output-files', and
+ `build-report-installation-file'."
+ ;; `interactive' form returns value for formal parameter `args'.
(interactive
(let (prompt
- hist
- arg
- (prompts build-report-prompts))
+ hist
+ arg
+ (prompts build-report-prompts))
(progn
(while prompts
- (defvar hist)
- (setq prompt (caar prompts))
- (setq hist (cdar prompts))
- (setq prompts (cdr prompts))
- (setq arg (cons (read-string prompt "" 'hist) arg)))
+ (defvar hist)
+ (setq prompt (caar prompts))
+ (setq hist (cdar prompts))
+ ;; `build-report-prompts' used to be a list of lists, the
+ ;; first element of each list being the prompt, the rest being
+ ;; the history. The history is now in a separate list. We
+ ;; better check for that.
+ (if (listp (car hist))
+ (setq hist (car hist)))
+ (setq prompts (cdr prompts))
+ (setq arg (cons (read-string prompt "" 'hist) arg)))
arg)))
(save-excursion
+ (if (file-exists-p build-report-installation-file)
+ (multiple-value-bind
+ (major minor beta codename configuration)
+ (build-report-installation-data build-report-installation-file)
+ (setq build-report-subject
+ (format "[%%s] XEmacs %s.%s%s \"%s\", %s"
+ major minor beta codename configuration)))
+ (multiple-value-bind
+ (major minor beta codename)
+ (build-report-version-file-data build-report-version-file)
+ (setq build-report-subject
+ (format "[%%s] XEmacs %s.%s%s \"%s\", %s"
+ major minor beta codename system-configuration))))
(compose-mail
- build-report-destination
+ ;; `build-report-destination' used to be a single string, so
+ ;; let's test if we really get a list of destinations.
+ (if (listp build-report-destination)
+ (read-string
+ "Build Report Destination: "
+ (car build-report-destination)
+ 'build-report-destination)
+ (read-string
+ "Build Report Destination: "
+ build-report-destination)
+ )
(apply 'format build-report-subject args)
nil
nil
nil
nil
nil)
- (let ((report-begin (point)))
- (insert (build-report-insert-make-output report-begin))
- (insert (build-report-insert-installation-file
- report-begin
- build-report-installation-insert-all))
+ (let* ((report-begin (point))
+ (files (reverse (build-report-make-output-get)))
+ (file (car files)))
+ (while file
+ (if (file-exists-p file)
+ (insert (build-report-insert-make-output report-begin file))
+ (insert (format "%s not found!\n" file)))
+ (insert "\n")
+ (setq files (cdr files))
+ (setq file (car files)))
+ (if (file-exists-p build-report-installation-file)
+ (insert (build-report-insert-installation-file
+ report-begin
+ build-report-installation-insert-all))
+ (insert (format "%s not found!\n" build-report-installation-file)))
+;;; (when (and (>= major 21) (>= minor 2) (or (null beta) (>= beta 32)))
+;;; (insert "\n")
+;;; (insert (build-report-insert-config-inc report-begin)))
+ (insert "\n")
(insert (build-report-insert-header report-begin))
(goto-char report-begin))))
"Inserts the build-report-header at the point specified by `where'."
(goto-char where)
(with-temp-buffer
- (insert "\n> XEmacs Build Report as generated\n> by"
- " build-report-version "
- build-report-version " follows:\n\n")
+ (insert
+ (format "
+> XEmacs Build Report generated by emacs-version
+> %s
+> with system-configuration
+> %s
+> follows:\n\n" emacs-version system-configuration))
(buffer-string)))
-(defun build-report-insert-make-output (where)
- "Inserts the output of the XEmacs Beta make run.
+(defun build-report-insert-make-output (where file)
+ "Inserts the output of the XEmacs Beta make run in the
+current buffer at position WHERE.
The make process output must have been saved in
-`build-report-make-output-file' during the XEmacs Beta building."
+`build-report-make-output-files' during the XEmacs Beta building."
(goto-char where)
(with-temp-buffer
- (if (file-exists-p build-report-make-output-file)
- (progn
- (if (featurep 'mime-setup)
- (progn
- (mime-edit-insert-tag
- "text"
- "plain"
- (concat
- "\nContent-Disposition: attachment;"
- " filename=\""
- (file-name-nondirectory
- build-report-make-output-file)
- "\""))
- (mime-edit-insert-binary-file
- build-report-make-output-file
- build-report-file-encoding))
- (insert-file-contents build-report-make-output-file))
- (goto-char (point-min))
- (delete-non-matching-lines (build-report-keep))
- (goto-char (point-min))
- (delete-matching-lines (build-report-delete))
- (goto-char (point-min))
- (insert "> Contents of "
- build-report-make-output-file
- "\n> keeping lines matching\n> \""
- (build-report-keep)
- "\"\n> and then deleting lines matching\n> \""
- (build-report-delete)
- "\"\n\n"))
- (insert "> " build-report-make-output-file
- " does not exist!\n\n"))
+ (if (file-exists-p file)
+ (progn
+ (if (featurep 'mime-setup)
+ (progn
+ (mime-edit-insert-tag
+ "text"
+ "plain"
+ (concat
+ "\nContent-Disposition: attachment;"
+ " filename=\""
+ (file-name-nondirectory
+ file)
+ "\""))
+ (mime-edit-insert-binary-file
+ file
+ build-report-file-encoding))
+ (insert-file-contents file))
+ (when build-report-keep-regexp
+ (goto-char (point-min))
+ (delete-non-matching-lines (build-report-keep)))
+ (when build-report-delete-regexp
+ (goto-char (point-min))
+ (delete-matching-lines (build-report-delete)))
+ (goto-char (point-min))
+ (if build-report-keep-regexp
+ (insert
+ (format
+ "> keeping lines matching
+> \"%s\"
+"
+ (build-report-keep))))
+ (if build-report-delete-regexp
+ (insert
+ (format
+ "> %sdeleting lines matching
+> \"%s\"
+"
+ (if build-report-keep-regexp
+ "and then "
+ "")
+ (build-report-delete))))
+ (insert "\n")
+ (goto-char (point-min))
+ (insert
+ (format "> Contents of %s\n" file)))
+ (insert "> " file
+ " does not exist!\n\n"))
(buffer-string)))
(defun build-report-insert-installation-file (where all)
(goto-char where)
(with-temp-buffer
(if (file-exists-p build-report-installation-file)
- (let (file-begin last-configure)
- (insert "> Contents of "
- build-report-installation-file
- ":\n")
- (insert
- (format
- "> (Output from %s of ./configure)\n\n"
- (if all "all runs" "most recent run")))
- (if (featurep 'mime-setup)
- (progn
- (mime-edit-insert-tag
- "text"
- "plain"
- (concat
- "\nContent-Disposition: attachment;"
- " filename=\""
- (file-name-nondirectory
- build-report-installation-file)
- "\""))
- (mime-edit-insert-binary-file
- build-report-installation-file
- build-report-file-encoding)
- (setq file-begin (mime-edit-content-beginning)))
- (setq file-begin (point))
- (insert-file-contents
- build-report-installation-file))
- (unless all
- (setq last-configure
- (search-backward-regexp
- "^\\(uname.*\\|osversion\\):\\s-+" file-begin t))
- (if (and file-begin last-configure)
- (delete-region file-begin last-configure))))
+ (let (file-begin last-configure)
+ (insert "> Contents of "
+ build-report-installation-file
+ ":\n")
+ (insert
+ (format
+ "> (Output from %s of ./configure)\n\n"
+ (if all "all runs" "most recent run")))
+ (if (featurep 'mime-setup)
+ (progn
+ (mime-edit-insert-tag
+ "text"
+ "plain"
+ (concat
+ "\nContent-Disposition: attachment;"
+ " filename=\""
+ (file-name-nondirectory
+ build-report-installation-file)
+ "\""))
+ (mime-edit-insert-binary-file
+ build-report-installation-file
+ build-report-file-encoding)
+ (setq file-begin (mime-edit-content-beginning)))
+ (setq file-begin (point))
+ (insert-file-contents
+ build-report-installation-file))
+ (unless all
+ (setq last-configure
+ (search-backward-regexp
+ "^\\(uname.*\\|osversion\\|OS\\):\\s-+" file-begin t))
+ (if (and file-begin last-configure)
+ (delete-region file-begin last-configure))))
(insert "> " build-report-installation-file
- " does not exist!\n\n"))
+ " does not exist!\n\n"))
(buffer-string)))
(defun build-report-keep ()
- "build-report-internal function of no general value."
+ "Concatenate elements of `build-report-keep-regexp' and a general
+MIME tag REGEXP. The result is a REGEXP string matching either of the
+REGEXPs in `build-report-keep-regexp' or a general MIME tag REGEXP."
(mapconcat #'identity
- (cons "^--\\[\\[\\|\\]\\]$" build-report-keep-regexp) "\\|"))
+ (cons "^--\\[\\[\\|\\]\\]$" build-report-keep-regexp) "\\|"))
(defun build-report-delete ()
- "build-report-internal function of no general value."
- (mapconcat #'identity
- build-report-delete-regexp "\\|"))
+ "Concatenate elements of `build-report-delete-regexp' and a general
+MIME tag REGEXP. The result is a REGEXP string matching either of the
+REGEXPs in `build-report-delete-regexp' or a general MIME tag REGEXP."
+ (mapconcat '(lambda (item) item)
+ build-report-delete-regexp "\\|"))
+
+(defun build-report-installation-data (&optional file)
+ "Return a list of XEmacs installation data containing MAJOR_NUMBER
+MINOR_NUMBER BETA_STRING CODENAME CONFIGURATION SRCDIR from FILE,
+which defaults to `build-report-installation-file'."
+ (interactive "fInstallation file: ")
+ (unless file
+ (setq file build-report-installation-file))
+ (let
+ (major minor beta codename configuration srcdir)
+ (save-window-excursion
+ (find-file-read-only file)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (cond
+ ((looking-at build-report-installation-version-regexp)
+ (goto-char (match-end 0))
+ (setq major (match-string 1))
+ (setq minor (match-string 2))
+ (setq beta (match-string 3))
+ (setq codename (match-string 6))
+ (setq configuration (match-string 7)))
+ ((looking-at build-report-installation-srcdir-regexp)
+ (goto-char (match-end 0))
+ (setq srcdir (match-string 1)))
+ ;; We avoid matching a potentially zero-length string to avoid
+ ;; infinite looping.
+ ((looking-at
+ "^.+$")
+ (goto-char (match-end 0)))
+ ((looking-at "\n")
+ (goto-char (match-end 0)))))
+ (values major minor (or beta "") codename configuration srcdir))))
+
+(defun build-report-version-file-data (&optional file)
+ "Return a list of XEmacs version information containing
+MAJOR_NUMBER MINOR_NUMBER BETA_STRING CODENAME from FILE, which
+defaults to `build-report-version-file'."
+ (interactive "fversion.sh file: ")
+ (unless file
+ (setq file build-report-version-file))
+ (let
+ (major minor beta codename)
+ (save-window-excursion
+ (find-file-read-only file)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (cond
+ ((looking-at build-report-version-file-regexp)
+ (goto-char (match-end 0))
+ (setq major (match-string 1))
+ (setq minor (match-string 2))
+ (setq beta (match-string 3))
+ (setq codename (match-string 4)))
+ ;; We avoid matching a potentially zero-length string to avoid
+ ;; infinite looping.
+ ((looking-at
+ "^.+$")
+ (goto-char (match-end 0)))
+ ((looking-at "\n")
+ (goto-char (match-end 0)))))
+ (values major minor (or beta "") codename))))
;;; build-report.el ends here
;; fetch and return the offset for the current opcode.
;; return NIL if this opcode has no offset
;; OP, PTR and BYTES are used and set dynamically
- (defvar op)
- (defvar ptr)
- (defvar bytes)
+ (declare (special op ptr bytes))
(cond ((< op byte-nth)
(let ((tem (logand op 7)))
(setq op (logand op 248))
(defun byte-optimize-lapcode (lap &optional for-effect)
"Simple peephole optimizer. LAP is both modified and returned."
- (let (lap0 ;; off0 unused
- lap1 ;; off1
- lap2 ;; off2
+ (let (lap0
+ lap1
+ lap2
+ variable-frequency
(keep-going 'first-time)
(add-depth 0)
rest tmp tmp2 tmp3
;; Rebuild byte-compile-constants / byte-compile-variables.
;; Simple optimizations that would inhibit other optimizations if they
;; were done in the optimizing loop, and optimizations which there is no
- ;; need to do more than once.
+ ;; need to do more than once.
(setq byte-compile-constants nil
- byte-compile-variables nil)
+ byte-compile-variables nil
+ variable-frequency (make-hash-table :test 'eq))
(setq rest lap)
(while rest
(setq lap0 (car rest)
lap1 (nth 1 rest))
- (if (memq (car lap0) byte-constref-ops)
- (if (eq (cdr lap0) 'byte-constant)
- (or (memq (cdr lap0) byte-compile-variables)
- (setq byte-compile-variables (cons (cdr lap0)
- byte-compile-variables)))
- (or (memq (cdr lap0) byte-compile-constants)
- (setq byte-compile-constants (cons (cdr lap0)
- byte-compile-constants)))))
+ (case (car lap0)
+ ((byte-varref byte-varset byte-varbind)
+ (incf (gethash (cdr lap0) variable-frequency 0))
+ (unless (memq (cdr lap0) byte-compile-variables)
+ (push (cdr lap0) byte-compile-variables)))
+ ((byte-constant)
+ (unless (memq (cdr lap0) byte-compile-constants)
+ (push (cdr lap0) byte-compile-constants))))
(cond (;;
- ;; const-C varset-X const-C --> const-C dup varset-X
+ ;; const-C varset-X const-C --> const-C dup varset-X
;; const-C varbind-X const-C --> const-C dup varbind-X
;;
(and (eq (car lap0) 'byte-constant)
(eq (car (nth 2 rest)) 'byte-constant)
- (eq (cdr lap0) (car (nth 2 rest)))
+ (eq (cdr lap0) (cdr (nth 2 rest)))
(memq (car lap1) '(byte-varbind byte-varset)))
(byte-compile-log-lap " %s %s %s\t-->\t%s dup %s"
lap0 lap1 lap0 lap0 lap1)
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
)
(setq rest (cdr rest)))
+ ;; Since the first 6 entries of the compiled-function constants
+ ;; vector are most efficient for varref/set/bind ops, we sort by
+ ;; reference count. This generates maximally space efficient and
+ ;; pretty time-efficient byte-code. See `byte-compile-constants-vector'.
+ (setq byte-compile-variables
+ (sort byte-compile-variables
+ #'(lambda (v1 v2)
+ (< (gethash v1 variable-frequency)
+ (gethash v2 variable-frequency)))))
+ ;; Another hack - put the most used variable in position 6, for
+ ;; better locality of reference with adjoining constants.
+ (let ((tail (last byte-compile-variables 6)))
+ (setq byte-compile-variables
+ (append (nbutlast byte-compile-variables 6)
+ (nreverse tail))))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
lap)
(cond ((eq (car-safe spec) 'special)
(if (boundp 'byte-compile-bound-variables)
(setq byte-compile-bound-variables
- ;; todo: this should compute correct binding bits vs. 0
- (append (mapcar #'(lambda (v) (cons v 0))
- (cdr spec))
- byte-compile-bound-variables))))
+ (append
+ (mapcar #'(lambda (v) (cons v byte-compile-global-bit))
+ (cdr spec))
+ byte-compile-bound-variables))))
((eq (car-safe spec) 'inline)
(while (setq spec (cdr spec))
(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan.
(defsetf x-get-secondary-selection x-own-secondary-selection t)
(defsetf x-get-selection x-own-selection t)
+(defsetf get-selection own-selection t)
;;; More complex setf-methods.
;;; These should take &environment arguments, but since full arglists aren't
(remove* cl-item cl-seq ':test 'equal))
(defun remq (cl-elt cl-list)
- "Remove all occurances of ELT in LIST, comparing with `eq'.
+ "Remove all occurrences of ELT in LIST, comparing with `eq'.
This is a non-destructive function; it makes a copy of LIST to avoid
corrupting the original LIST.
Also see: `delq', `delete', `delete*', `remove', `remove*'."
Otherwise, the macro is expanded and the expansion is considered
in place of FORM. When a non-macro-call results, it is returned.
-The second optional arg ENVIRONMENT species an environment of macro
+The second optional arg ENVIRONMENT specifies an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation."
(let ((cl-macro-environment cl-env))
(while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
(sleep-for 2))))
ans)))
-;; these may be redefined later, but make the original def easily encapsulable
-(define-function 'yes-or-no-p 'yes-or-no-p-minibuf)
-(define-function 'y-or-n-p 'y-or-n-p-minibuf)
+(defun yes-or-no-p (prompt)
+ "Ask user a yes-or-no question. Return t if answer is yes.
+The question is asked with a dialog box or the minibuffer, as appropriate.
+Takes one argument, which is the string to display to ask the question.
+It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
+The user must confirm the answer with RET,
+and can edit it until it as been confirmed."
+ (if (should-use-dialog-box-p)
+ (yes-or-no-p-dialog-box prompt)
+ (yes-or-no-p-minibuf prompt)))
+
+(defun y-or-n-p (prompt)
+ "Ask user a \"y or n\" question. Return t if answer is \"y\".
+Takes one argument, which is the string to display to ask the question.
+The question is asked with a dialog box or the minibuffer, as appropriate.
+It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
+No confirmation of the answer is requested; a single character is enough.
+Also accepts Space to mean yes, or Delete to mean no."
+ (if (should-use-dialog-box-p)
+ (yes-or-no-p-dialog-box prompt)
+ (y-or-n-p-minibuf prompt)))
+
\f
(defun read-char ()
start end filename append visit lockname
coding-system)))
-;;; The following was all that remained in mule-files.el, so I moved it
-;;; here for neatness. -sb
-(when (featurep 'mule)
- (setq-default buffer-file-coding-system 'iso-2022-8))
-
;;; code-files.el ends here
(Transmission Control Protocol) and 'udp (User Datagram Protocol) are
supported. When omitted, 'tcp is assumed.
-Ouput via `process-send-string' and input via buffer or filter (see
+Output via `process-send-string' and input via buffer or filter (see
`set-process-filter') are stream-oriented. That means UDP datagrams are
not guaranteed to be sent and received in discrete packets. (But small
datagrams around 500 bytes that are not truncated by `process-send-string'
;;; Commentary:
;; This file generates the custom-load files, loaded by cus-load.el.
-;; The only entry point is `Custom-make-dependencies'.
+;; Entry points are `Custom-make-dependencies' and
+;; `Custom-make-one-dependency'.
;; It works by scanning all the `.el' files in a directory, and
;; evaluates any `defcustom', `defgroup', or `defface' expression that
;; understand, but is in fact very easy to break. Be sure to read and
;; understand the commentary above!
-;;;###autoload
-(defun Custom-make-dependencies (&optional subdirs)
- "Extract custom dependencies from .el files in SUBDIRS.
-SUBDIRS is a list of directories. If it is nil, the command-line
-arguments are used. If it is a string, only that directory is
-processed. This function is especially useful in batch mode.
-
-Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS"
- (interactive "DDirectory: ")
- (and (stringp subdirs)
- (setq subdirs (list subdirs)))
- (or subdirs
- ;; Usurp the command-line-args
- (setq subdirs command-line-args-left
- command-line-args-left nil))
+(defun Custom-make-dependencies-1 (subdirs)
(setq subdirs (mapcar #'expand-file-name subdirs))
(with-temp-buffer
(let ((enable-local-eval nil)
(insert "\n;;; custom-load.el ends here\n"))
(clrhash hash)))))))))
+(defun Custom-make-one-dependency ()
+ "Extract custom dependencies from .el files in one dir, on the command line.
+Like `Custom-make-dependencies' but snarfs only one command-line argument,
+making it useful in a chain of batch commands in a single XEmacs invocation."
+ (let ((subdir (car command-line-args-left)))
+ (setq command-line-args-left (cdr command-line-args-left))
+ (Custom-make-dependencies-1 (list subdir))))
+
+;;;###autoload
+(defun Custom-make-dependencies (&optional subdirs)
+ "Extract custom dependencies from .el files in SUBDIRS.
+SUBDIRS is a list of directories. If it is nil, the command-line
+arguments are used. If it is a string, only that directory is
+processed. This function is especially useful in batch mode.
+
+Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS"
+ (interactive "DDirectory: ")
+ (and (stringp subdirs)
+ (setq subdirs (list subdirs)))
+ (or subdirs
+ ;; Usurp the command-line-args
+ (setq subdirs command-line-args-left
+ command-line-args-left nil))
+ (Custom-make-dependencies-1 subdirs))
+
(provide 'cus-dep)
;;; cus-dep.el ends here
(defun custom-save-resets (property setter special)
(let (started-writing ignored-special)
+ (setq ignored-special ignored-special) ;; suppress byte-compiler warning
;; (custom-save-delete setter) Done by caller
(let ((standard-output (current-buffer))
(mapper `(lambda (object)
(setq ignored-special special)
(mapatoms mapper)
(when started-writing
- (princ ")\n")))))
+ (princ ")\n"))))
+ )
(defun custom-save-loaded-themes ()
(defun custom-theme-reset-faces (theme &rest args)
(custom-check-theme theme)
"Reset the value of the face to values previously defined.
-Assosiate this setting with THEME.
+Associate this setting with THEME.
ARGS is a list of lists of the form
;;;###autoload
(defun custom-reset-faces (&rest args)
"Reset the value of the face to values previously defined.
-Assosiate this setting with the 'user' theme.
+Associate this setting with the 'user' theme.
ARGS is defined as for `custom-theme-reset-faces'"
(apply #'custom-theme-reset-faces 'user args))
the current value for that symbol. The default is
`default-value'.
:require VALUE should be a feature symbol. Each feature will be
- required after initialization, of the the user have saved this
+ required after initialization, of the user have saved this
option.
Read the section about customization in the Emacs Lisp manual for more
"(deftheme THEME &optional DOC &key KEYWORDS)
Define a theme labeled by SYMBOL THEME. The optional argument DOC is a
-doc string describing the the theme. It is optionally followed by the
+doc string describing the theme. It is optionally followed by the
following keyboard arguments
:short-description DESC
(defun custom-theme-load-themes (by-theme &rest body)
"Load the themes specified by BODY and record them as required by
-theme BY-THEME. BODY is a secuence of
+theme BY-THEME. BODY is a sequence of
- a SYMBOL
require the theme SYMBOL
- a list (reset THEME)
(defsubst copy-upto-last (elt list)
- "Copy all the elements of the list upto the last occurence of elt"
+ "Copy all the elements of the list upto the last occurrence of elt"
;; Is it faster to do more work in C than to do less in elisp?
(nreverse (cdr (member elt (reverse list)))))
(defun custom-theme-reset-variables (theme &rest args)
"Reset the value of the variables to values previously defined.
-Assosiate this setting with THEME.
+Associate this setting with THEME.
ARGS is a list of lists of the form
(defun custom-reset-variables (&rest args)
"Reset the value of the variables to values previously defined.
-Assosiate this setting with the `user' theme.
+Associate this setting with the `user' theme.
The ARGS are as in `custom-theme-reset-variables'."
(apply #'custom-theme-reset-variables 'user args))
;;; dialog.el --- Dialog-box support for XEmacs
;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 2000 Ben Wing.
;; Maintainer: XEmacs Development Team
;; Keywords: extensions, internal, dumped
Return t if the answer is \"yes\".
Takes one argument, which is the string to display to ask the question."
(save-selected-frame
- (popup-dialog-box
- (list prompt ["Yes" yes t] ["No" no t] nil ["Cancel" cancel t]))
- (let (event)
- (catch 'ynp-done
- (while t
- (setq event (next-command-event event))
- (when (misc-user-event-p event)
- (message "%s" (event-object event))
- (case (event-object event)
- ((yes) (throw 'ynp-done t))
- ((no) (throw 'ynp-done nil))
- ((cancel menu-no-selection-hook) (signal 'quit nil))))
- (unless (button-release-event-p event) ; don't beep twice
- (beep)
- (message "please answer the dialog box")))))))
-
-(defun yes-or-no-p-maybe-dialog-box (prompt)
- "Ask user a yes-or-no question. Return t if answer is yes.
-The question is asked with a dialog box or the minibuffer, as appropriate.
-Takes one argument, which is the string to display to ask the question.
-It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
-The user must confirm the answer with RET,
-and can edit it until it as been confirmed."
- (if (should-use-dialog-box-p)
- (yes-or-no-p-dialog-box prompt)
- (yes-or-no-p-minibuf prompt)))
-
-(defun y-or-n-p-maybe-dialog-box (prompt)
- "Ask user a \"y or n\" question. Return t if answer is \"y\".
-Takes one argument, which is the string to display to ask the question.
-The question is asked with a dialog box or the minibuffer, as appropriate.
-It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
-No confirmation of the answer is requested; a single character is enough.
-Also accepts Space to mean yes, or Delete to mean no."
- (if (should-use-dialog-box-p)
- (yes-or-no-p-dialog-box prompt)
- (y-or-n-p-minibuf prompt)))
-
-(when (fboundp 'popup-dialog-box)
- (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box)
- (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box))
+ (make-dialog-box 'question
+ :question prompt
+ :modal t
+ :buttons '(["Yes" (dialog-box-finish t)]
+ ["No" (dialog-box-finish nil)]
+ nil
+ ["Cancel" (dialog-box-cancel)]))))
-;; this is call-compatible with the horribly-named FSF Emacs function
-;; `x-popup-dialog'. I refuse to use that name.
+;; FSF has a similar function `x-popup-dialog'.
(defun get-dialog-box-response (position contents)
- ;; by Stig@hackvan.com
- ;; modified by pez@atlantic2.sbi.com
"Pop up a dialog box and return user's selection.
POSITION specifies which frame to use.
This is normally an event or a window or frame.
(select-frame position))
((windowp position)
(select-window position)))
- (let ((dbox (cons (car contents)
- (mapcar #'(lambda (x)
- (cond
- ((null x)
- nil)
- ((stringp x)
- `[,x 'ignore nil]) ;this will never get
- ;selected
- (t
- `[,(car x) (throw 'result ',(cdr x)) t])))
- (cdr contents))
- )))
- (catch 'result
- (popup-dialog-box dbox)
- (dispatch-event (next-command-event)))))
+ (make-dialog-box 'question
+ :question (car contents)
+ :modal t
+ :buttons
+ (mapcar #'(lambda (x)
+ (cond
+ ((null x)
+ nil)
+ ((stringp x)
+ ;;this will never get selected
+ `[,x 'ignore nil])
+ (t
+ `[,(car x) (dialog-box-finish ',(cdr x)) t])))
+ (cdr contents))))
(defun message-box (fmt &rest args)
"Display a message, in a dialog box if possible.
str)))
(defun message-or-box (fmt &rest args)
- "Display a message in a dialog box or in the echo area.\n\
-If this command was invoked with the mouse, use a dialog box.\n\
+ "Display a message in a dialog box or in the echo area.
+If this command was invoked with the mouse, use a dialog box.
Otherwise, use the echo area.
The arguments are the same as to `format'.
(apply 'message-box fmt args)
(apply 'message fmt args)))
-(defun make-dialog-box (&optional spec props parent)
- "Create a frame suitable for use as a general dialog box.
-The frame is made a child of PARENT (defaults to the selected frame),
-and has additional properties PROPS, as well as `dialog-frame-plist'.
-SPEC is a string or glyph to be placed in the gutter. If INVISIBLE is
-non-nil then the frame is initially unmapped.
-Normally the created frame has no modelines, menubars, scrollbars,
-minibuffer or toolbars and is entirely covered by its gutter."
- (or parent (setq parent (selected-frame)))
- (let* ((ftop (frame-property parent 'top))
- (fleft (frame-property parent 'left))
- (fwidth (frame-pixel-width parent))
- (fheight (frame-pixel-height parent))
- (fonth (font-height (face-font 'default)))
- (fontw (font-width (face-font 'default)))
- (props (append props dialog-frame-plist))
- (dfheight (plist-get props 'height))
- (dfwidth (plist-get props 'width))
- (unmapped (plist-get props 'initially-unmapped))
- (gutter-spec spec)
- (name (or (plist-get props 'name) "XEmacs"))
- (frame nil))
- (plist-remprop props 'initially-unmapped)
- ;; allow the user to just provide a glyph
- (when (glyphp spec)
- (setq gutter-spec (copy-sequence "\n"))
- (set-extent-begin-glyph (make-extent 0 1 gutter-spec) spec))
- ;; under FVWM at least, if I don't specify the initial position,
- ;; it ends up always at (0, 0). xwininfo doesn't tell me
- ;; that there are any program-specified position hints, so
- ;; it must be an FVWM bug. So just be smashing and position
- ;; in the center of the selected frame.
- (setq frame (make-frame
- (append props
- `(popup ,parent initially-unmapped t
- menubar-visible-p nil
- has-modeline-p nil
- default-toolbar-visible-p nil
- top-gutter-visible-p t
- top-gutter-height ,(* dfheight fonth)
- top-gutter ,gutter-spec
- minibuffer none
- name ,name
- modeline-shadow-thickness 0
- vertical-scrollbar-visible-p nil
- horizontal-scrollbar-visible-p nil
- unsplittable t
- left ,(+ fleft (- (/ fwidth 2)
- (/ (* dfwidth fontw)
- 2)))
- top ,(+ ftop (- (/ fheight 2)
- (/ (* dfheight fonth)
- 2)))))))
- (set-face-foreground 'modeline [default foreground] frame)
- (set-face-background 'modeline [default background] frame)
- (unless unmapped (make-frame-visible frame))
- frame))
+(defun make-dialog-box (type &rest cl-keys)
+ "Pop up a dialog box.
+TYPE is a symbol, the type of dialog box. Remaining arguments are
+keyword-value pairs, specifying the particular characteristics of the
+dialog box. The allowed keywords are particular to each type, but
+some standard keywords are common to many types:
+
+:title
+ The title of the dialog box's window.
+
+:modal
+ If true, indicates that XEmacs will wait until the user is \"done\"
+ with the dialog box (usually, this means that a response has been
+ given). Typically, the response is returned. NOTE: Some dialog
+ boxes are always modal. If the dialog box is modal, `make-dialog-box'
+ returns immediately. The return value will be either nil or a
+ dialog box handle of some sort, e.g. a frame for type `general'.
+
+---------------------------------------------------------------------------
+
+Recognized types are
+
+general
+ A dialog box consisting of an XEmacs glyph, typically a `layout'
+ widget specifying a dialog box arrangement. This is the most
+ general and powerful dialog box type, but requires more work than
+ the other types below.
+
+question
+ A simple dialog box that displays a question and contains one or
+ more user-defined buttons to specify possible responses. (This is
+ compatible with the old built-in dialog boxes formerly specified
+ using `popup-dialog-box'.)
+
+file
+ A file dialog box, of the type typically used in the window system
+ XEmacs is running on.
+
+color
+ A color picker.
+
+find
+ A find dialog box.
+
+font
+ A font chooser.
+
+print
+ A dialog box used when printing (e.g. number of pages, printer).
+
+page-setup
+ A dialog box for setting page options (e.g. margins) for printing.
+
+replace
+ A find/replace dialog box.
+
+mswindows-message
+ An MS Windows-specific standard dialog box type similar to `question'.
+
+---------------------------------------------------------------------------
+
+For type `general':
+
+This type creates a frame and puts the specified widget layout in it.
+\(Currently this is done by eliminating all areas but the gutter and placing
+the layout there; but this is an implementation detail and may change.)
+
+The keywords allowed for `general' are
+
+:spec
+ The widget spec -- anything that can be passed to `make-glyph'.
+
+:title
+ The title of the frame.
+:parent
+ The frame is made a child of this frame (defaults to the selected frame).
+
+:properties
+ Additional properties of the frame, as well as `dialog-frame-plist'.
+
+---------------------------------------------------------------------------
+
+For type `question':
+
+The keywords allowed are
+
+:modal
+ t or nil. When t, the dialog box callback should exit the dialog box
+ using the functions `dialog-box-finish' or `dialog-box-cancel'.
+:title
+ The title of the frame.
+:question
+ A string, the question.
+:buttons
+ A list, describing the buttons below the question. Each of these is a
+ vector, the syntax of which is essentially the same as that of popup menu
+ items. They may have any of the following forms:
+
+ [ \"name\" callback <active-p> ]
+ [ \"name\" callback <active-p> \"suffix\" ]
+ [ \"name\" callback :<keyword> <value> :<keyword> <value> ... ]
+
+ The name is the string to display on the button; it is filtered through the
+ resource database, so it is possible for resources to override what string
+ is actually displayed.
+
+ Accelerators can be indicated in the string by putting the sequence
+ \"%_\" before the character corresponding to the key that will invoke
+ the button. Uppercase and lowercase accelerators are equivalent. The
+ sequence \"%%\" is also special, and is translated into a single %.
+
+ If the `callback' of a button is a symbol, then it must name a command.
+ It will be invoked with `call-interactively'. If it is a list, then it is
+ evaluated with `eval'.
+
+ One (and only one) of the buttons may be `nil'. This marker means that all
+ following buttons should be flushright instead of flushleft.
+
+ Though the keyword/value syntax is supported for dialog boxes just as in
+ popup menus, the only keyword which is both meaningful and fully implemented
+ for dialog box buttons is `:active'.
+
+---------------------------------------------------------------------------
+
+For type `file':
+
+The keywords allowed are
+
+:initial-filename
+ The initial filename to be placed in the dialog box (defaults to nothing).
+:initial-directory
+ The initial directory to be selected in the dialog box (defaults to the
+ current buffer's `default-directory).
+:filter-list
+ A list of (filter-desc filter ...)
+:title
+ The title of the dialog box (defaults to \"Open\").
+:allow-multi-select t or nil
+:create-prompt-on-nonexistent t or nil
+:overwrite-prompt t or nil
+:file-must-exist t or nil
+:no-network-button t or nil
+:no-read-only-return t or nil
+
+---------------------------------------------------------------------------
+
+For type `print':
+
+This invokes the Windows standard Print dialog.
+This dialog is usually invoked when the user selects the Print command.
+After the user presses OK, the program should start actual printout.
+
+The keywords allowed are
+
+:device
+ An 'msprinter device.
+:print-settings
+ A printer settings object.
+
+Exactly one of these keywords must be given.
+
+The function brings up the Print dialog, where the user can
+select a different printer and/or change printer options. Connection
+name can change as a result of selecting a different printer device. If
+a printer is specified, then changes are stored into the settings object
+currently selected into that printer. If a settings object is supplied,
+then changes are recorded into it, and, it it is selected into a
+printer, then changes are propagated to that printer
+too.
+
+Return value is nil if the user has canceled the dialog. Otherwise, it
+is a new plist, with the following properties:
+ name Printer device name, even if unchanged by the user.
+ from-page First page to print, 1-based. If not specified by the user,
+ then this value is not included in the plist.
+ to-page Last page to print, inclusive, 1-based. If not specified by
+ the user, then this value is not included in the plist.
+ copies Number of copies to print. Always returned.
+
+The DEVICE is destroyed and an error is signaled in case of
+initialization problem with the new printer.
+
+See also the `page-setup' and `print-setup' dialog boxes.
+
+---------------------------------------------------------------------------
+
+For type `page-setup':
+
+This invokes the Windows standard Page Setup dialog.
+This dialog is usually invoked in response to the Page Setup command, and
+used to chose such parameters as page orientation, print margins etc.
+Note that this dialog contains the \"Printer\" button, which invokes
+the Printer Setup dialog (see `msprinter-print-setup-dialog') so that the
+user can update the printer options or even select a different printer
+as well.
+
+The keywords allowed are
+
+:device
+ An 'msprinter device.
+:print-settings
+ A printer settings object.
+:properties
+ A plist of job properties.
+
+Exactly one of these keywords must be given.
+
+The function brings up the Page Setup dialog, where the user
+can select a different printer and/or change printer options.
+Connection name can change as a result of selecting a different printer
+device. If a printer is specified, then changes are stored into the
+settings object currently selected into that printer. If a settings
+object is supplied, then changes are recorded into it, and, it it is
+selected into a printer, then changes are propagated to that printer
+too.
+
+:properties specifies a plist of job properties;
+see `default-msprinter-frame-plist' for the complete list. The plist
+is used to initialize the dialog.
+
+Return value is nil if the user has canceled the dialog. Otherwise,
+it is a new plist, containing the new list of properties.
+
+The DEVICE is destroyed and an error is signaled in case of
+initialization problem with the new printer.
+
+See also the `print' and `print-setup' dialogs.
+
+---------------------------------------------------------------------------
+
+For type `print-setup':
+
+This invokes the Windows standard Print Setup dialog.
+This dialog is usually invoked when the user selects the Printer Setup
+command.
+
+The keywords allowed are
+
+:device
+ An 'msprinter device.
+:print-settings
+ A printer settings object.
+
+Exactly one of these keywords must be given.
+
+The function brings up the Print Setup dialog, where the user
+can select a different printer and/or change printer options.
+Connection name can change as a result of selecting a different printer
+device. If a printer is specified, then changes are stored into the
+settings object currently selected into that printer. If a settings
+object is supplied, then changes are recorded into it, and, it it is
+selected into a printer, then changes are propagated to that printer
+too.
+
+Return value is nil if the user has canceled the dialog. Otherwise, it
+is a new plist, with the following properties:
+ name Printer device name, even if unchanged by the user.
+
+The printer device is destroyed and an error is signaled if new printer
+is selected by the user, but cannot be initialized.
+
+See also the `print' and `page-setup' dialogs.
+
+---------------------------------------------------------------------------
+
+For type `mswindows-message':
+
+The keywords allowed are
+
+:title
+ The title of the dialog box.
+:message
+ The string to display.
+:flags
+ A symbol or list of symbols:
+
+ -- To specify the buttons in the message box:
+
+ abortretryignore
+ The message box contains three push buttons: Abort, Retry, and Ignore.
+ ok
+ The message box contains one push button: OK. This is the default.
+ okcancel
+ The message box contains two push buttons: OK and Cancel.
+ retrycancel
+ The message box contains two push buttons: Retry and Cancel.
+ yesno
+ The message box contains two push buttons: Yes and No.
+ yesnocancel
+ The message box contains three push buttons: Yes, No, and Cancel.
+
+
+ -- To display an icon in the message box:
+
+ iconexclamation, iconwarning
+ An exclamation-point icon appears in the message box.
+ iconinformation, iconasterisk
+ An icon consisting of a lowercase letter i in a circle appears in
+ the message box.
+ iconquestion
+ A question-mark icon appears in the message box.
+ iconstop, iconerror, iconhand
+ A stop-sign icon appears in the message box.
+
+
+ -- To indicate the default button:
+
+ defbutton1
+ The first button is the default button. This is the default.
+ defbutton2
+ The second button is the default button.
+ defbutton3
+ The third button is the default button.
+ defbutton4
+ The fourth button is the default button.
+
+
+ -- To indicate the modality of the dialog box:
+
+ applmodal
+ The user must respond to the message box before continuing work in
+ the window identified by the hWnd parameter. However, the user can
+ move to the windows of other applications and work in those windows.
+ Depending on the hierarchy of windows in the application, the user
+ may be able to move to other windows within the application. All
+ child windows of the parent of the message box are automatically
+ disabled, but popup windows are not. This is the default.
+ systemmodal
+ Same as applmodal except that the message box has the WS_EX_TOPMOST
+ style. Use system-modal message boxes to notify the user of serious,
+ potentially damaging errors that require immediate attention (for
+ example, running out of memory). This flag has no effect on the
+ user's ability to interact with windows other than those associated
+ with hWnd.
+ taskmodal
+ Same as applmodal except that all the top-level windows belonging to
+ the current task are disabled if the hWnd parameter is NULL. Use
+ this flag when the calling application or library does not have a
+ window handle available but still needs to prevent input to other
+ windows in the current application without suspending other
+ applications.
+
+
+ In addition, you can specify the following flags:
+
+ default-desktop-only
+ The desktop currently receiving input must be a default desktop;
+ otherwise, the function fails. A default desktop is one an
+ application runs on after the user has logged on.
+ help
+ Adds a Help button to the message box. Choosing the Help button or
+ pressing F1 generates a Help event.
+ right
+ The text is right-justified.
+ rtlreading
+ Displays message and caption text using right-to-left reading order
+ on Hebrew and Arabic systems.
+ setforeground
+ The message box becomes the foreground window. Internally, Windows
+ calls the SetForegroundWindow function for the message box.
+ topmost
+ The message box is created with the WS_EX_TOPMOST window style.
+ service-notification
+ Windows NT only: The caller is a service notifying the user of an
+ event. The function displays a message box on the current active
+ desktop, even if there is no user logged on to the computer. If
+ this flag is set, the hWnd parameter must be NULL. This is so the
+ message box can appear on a desktop other than the desktop
+ corresponding to the hWnd.
+
+
+ The return value is one of the following menu-item values returned by
+ the dialog box:
+
+ abort
+ Abort button was selected.
+ cancel
+ Cancel button was selected.
+ ignore
+ Ignore button was selected.
+ no
+ No button was selected.
+ ok
+ OK button was selected.
+ retry
+ Retry button was selected.
+ yes
+ Yes button was selected.
+
+ If a message box has a Cancel button, the function returns the
+ `cancel' value if either the ESC key is pressed or the Cancel button
+ is selected. If the message box has no Cancel button, pressing ESC has
+ no effect."
+ (flet ((dialog-box-modal-loop (thunk)
+ (let* ((frames (frame-list))
+ (result
+ ;; ok, this is extremely tricky. normally a modal
+ ;; dialog will pop itself down using (dialog-box-finish)
+ ;; or (dialog-box-cancel), which throws back to this
+ ;; catch. but question dialog boxes pop down themselves
+ ;; regardless, so a badly written question dialog box
+ ;; that does not use (dialog-box-finish) could seriously
+ ;; wedge us. furthermore, we disable all other frames
+ ;; in order to implement modality; we need to restore
+ ;; them before the dialog box is destroyed, because
+ ;; otherwise windows at least will notice that no top-
+ ;; level window can have the focus and will shift the
+ ;; focus to a different app, raising it and obscuring us.
+ ;; so we create `delete-dialog-box-hook', which is
+ ;; called right *before* the dialog box gets destroyed.
+ ;; here, we put a hook on it, and when it's our dialog
+ ;; box and not someone else's that's being destroyed,
+ ;; we reenable all the frames and remove the hook.
+ ;; BUT ... we still have to deal with exiting the
+ ;; modal loop in case it doesn't happen before us.
+ ;; we can't do this until after the callbacks for this
+ ;; dialog box get executed, and that doesn't happen until
+ ;; after the dialog box is destroyed. so to keep things
+ ;; synchronous, we enqueue an eval event, which goes into
+ ;; the same queue as the misc-user events encapsulating
+ ;; the dialog callbacks and will go after it (because
+ ;; destroying the dialog box happens after processing
+ ;; its selection). if the dialog boxes are written
+ ;; properly, we don't see this eval event, because we've
+ ;; already exited our modal loop. (Thus, we make sure the
+ ;; function given in this eval event is actually defined
+ ;; and does nothing.) If we do see it, though, we know
+ ;; that we encountered a badly written dialog box and
+ ;; need to exit now. Currently we just return nil, but
+ ;; maybe we should signal an error or issue a warning.
+ (catch 'internal-dialog-box-finish
+ (let ((id (eval thunk))
+ (sym (gensym)))
+ (fset sym
+ `(lambda (did)
+ (when (eq ',id did)
+ (mapc 'enable-frame ',frames)
+ (enqueue-eval-event
+ 'internal-make-dialog-box-exit did)
+ (remove-hook 'delete-dialog-box-hook
+ ',sym))))
+ (add-hook 'delete-dialog-box-hook sym)
+ (mapc 'disable-frame frames)
+ (block nil
+ (while t
+ (let ((event (next-event)))
+ (if (and (eval-event-p event)
+ (eq (event-function event)
+ 'internal-make-dialog-box-exit)
+ (eq (event-object event) id))
+ (return '(nil))
+ (dispatch-event event)))))))))
+ (if (listp result)
+ (car result)
+ (signal 'quit nil)))))
+ (case type
+ (general
+ (cl-parsing-keywords
+ ((:title "XEmacs")
+ (:parent (selected-frame))
+ :modal
+ :properties
+ :spec)
+ ()
+ (flet ((create-dialog-box-frame ()
+ (let* ((ftop (frame-property cl-parent 'top))
+ (fleft (frame-property cl-parent 'left))
+ (fwidth (frame-pixel-width cl-parent))
+ (fheight (frame-pixel-height cl-parent))
+ (fonth (font-height (face-font 'default)))
+ (fontw (font-width (face-font 'default)))
+ (cl-properties (append cl-properties
+ dialog-frame-plist))
+ (dfheight (plist-get cl-properties 'height))
+ (dfwidth (plist-get cl-properties 'width))
+ (unmapped (plist-get cl-properties
+ 'initially-unmapped))
+ (gutter-spec cl-spec)
+ (name (or (plist-get cl-properties 'name) "XEmacs"))
+ (frame nil))
+ (plist-remprop cl-properties 'initially-unmapped)
+ ;; allow the user to just provide a glyph
+ (or (glyphp cl-spec) (setq cl-spec (make-glyph cl-spec)))
+ (setq gutter-spec (copy-sequence "\n"))
+ (set-extent-begin-glyph (make-extent 0 1 gutter-spec)
+ cl-spec)
+ ;; under FVWM at least, if I don't specify the
+ ;; initial position, it ends up always at (0, 0).
+ ;; xwininfo doesn't tell me that there are any
+ ;; program-specified position hints, so it must be
+ ;; an FVWM bug. So just be smashing and position in
+ ;; the center of the selected frame.
+ (setq frame
+ (make-frame
+ (append cl-properties
+ `(popup ,cl-parent initially-unmapped t
+ menubar-visible-p nil
+ has-modeline-p nil
+ default-toolbar-visible-p nil
+ top-gutter-visible-p t
+ top-gutter-height ,
+ (* dfheight fonth)
+ top-gutter ,gutter-spec
+ minibuffer none
+ name ,name
+ modeline-shadow-thickness 0
+ vertical-scrollbar-visible-p nil
+ horizontal-scrollbar-visible-p nil
+ unsplittable t
+ left ,(+ fleft (- (/ fwidth 2)
+ (/ (* dfwidth
+ fontw)
+ 2)))
+ top ,(+ ftop (- (/ fheight 2)
+ (/ (* dfheight
+ fonth)
+ 2)))))))
+ (set-face-foreground 'modeline [default foreground] frame)
+ (set-face-background 'modeline [default background] frame)
+ (unless unmapped (make-frame-visible frame))
+ (let ((newbuf (generate-new-buffer " *dialog box*")))
+ (set-buffer-dedicated-frame newbuf frame)
+ (set-frame-property frame 'dialog-box-buffer newbuf)
+ (with-current-buffer newbuf
+ (setq frame-title-format cl-title)
+ (make-local-hook 'delete-frame-hook)
+ (add-hook 'delete-frame-hook
+ #'(lambda (frame)
+ (kill-buffer
+ (frame-property
+ frame
+ 'dialog-box-buffer))))))
+ frame)))
+ (if cl-modal
+ (dialog-box-modal-loop '(create-dialog-box-frame))
+ (create-dialog-box-frame)))))
+ (question
+ (cl-parsing-keywords
+ ((:modal nil))
+ t
+ (remf cl-keys :modal)
+ (if cl-modal
+ (dialog-box-modal-loop `(make-dialog-box-internal ',type
+ ',cl-keys))
+ (make-dialog-box-internal type cl-keys))))
+ (t
+ (make-dialog-box-internal type cl-keys)))))
+
+(defun dialog-box-finish (result)
+ "Exit a modal dialog box, returning RESULT.
+This is meant to be executed from a dialog box callback function."
+ (throw 'internal-dialog-box-finish (list result)))
+
+(defun dialog-box-cancel ()
+ "Cancel a modal dialog box.
+This is meant to be executed from a dialog box callback function."
+ (throw 'internal-dialog-box-finish 'cancel))
+
+;; an eval event, used as a trigger inside of the dialog modal loop.
+(defun internal-make-dialog-box-exit (did)
+ nil)
+
+(make-obsolete 'popup-dialog-box 'make-dialog-box)
+(defun popup-dialog-box (desc)
+ "Obsolete equivalent of (make-dialog-box 'question ...).
+
+\(popup-dialog-box (QUESTION BUTTONS ...)
+
+is equivalent to
+\(make-dialog-box 'question :question QUESTION :buttons BUTTONS)"
+ (check-argument-type 'stringp (car desc))
+ (or (consp (cdr desc))
+ (error 'syntax-error
+ "Dialog descriptor must supply at least one button"
+ desc))
+ (make-dialog-box 'question :question (car desc) :buttons (cdr desc)))
;;; dialog.el ends here
;; Copyright (C) 1998 Oliver Graf <ograf@fga.de>
;; Maintainer: XEmacs Development Team, Oliver Graf <ograf@fga.de>
-;; Keywords: drag, drop, dumped
+;; Keywords: mouse, gui, dumped
;; This file is part of XEmacs.
;; to-do: open ftp URLs with efs...
(t
;; some other URL, try to fire up some browser for it
- (if (boundp 'browse-url-browser-function)
- (funcall browse-url-browser-function (car data))
+ (if (fboundp 'browse-url)
+ (browse-url (car data))
(display-message 'error
"Can't show URL, no browser selected"))))
(undo-boundary)
;; 02111-1307, USA.
;;; Synched up with: Not synched with FSF but coordinated with the FSF
-;;; easymenu maintor for compatibility with FSF 20.4.
+;;; easymenu maintainer for compatibility with FSF 20.4.
;;; Please: Coordinate changes with Inge Frick <inge@nada.kth.se>
;; Commentary:
;; Easymenu allows you to define menus for both Emacs 19 and XEmacs.
-;; This file
+;; This file
;; The advantages of using easymenu are:
;; - Easier to use than either the Emacs 19 and XEmacs menu syntax.
-;; - Common interface for Emacs 18, Emacs 19, and XEmacs.
+;; - Common interface for Emacs 18, Emacs 19, and XEmacs.
;; (The code does nothing when run under Emacs 18).
;; The public functions are:
;; - Function: easy-menu-define SYMBOL MAPS DOC MENU
;; SYMBOL is both the name of the variable that holds the menu and
-;; the name of a function that will present a the menu.
+;; the name of a function that will present the menu.
;; MAPS is a list of keymaps where the menu should appear in the menubar.
;; DOC is the documentation string for the variable.
-;; MENU is an XEmacs style menu description.
+;; MENU is an XEmacs style menu description.
;; See the documentation for easy-menu-define for details.
;; - Function: easy-menu-change PATH NAME ITEMS
;; Change an existing menu.
;; The menu must already exist and be visible on the menu bar.
-;; PATH is a list of strings used for locating the menu on the menu bar.
-;; NAME is the name of the menu.
+;; PATH is a list of strings used for locating the menu on the menu bar.
+;; NAME is the name of the menu.
;; ITEMS is a list of menu items, as defined in `easy-menu-define'.
;; - Function: easy-menu-add MENU [ MAP ]
ENABLE is an expression; the item is enabled for selection
whenever this expression's value is non-nil.
-Alternatively, a menu item may have the form:
+Alternatively, a menu item may have the form:
[ NAME CALLBACK [ KEYWORD ARG ] ... ]
NAME is a string; the name of an argument to CALLBACK.
:style STYLE
-
+
STYLE is a symbol describing the type of menu item. The following are
-defined:
+defined:
-toggle: A checkbox.
+toggle: A checkbox.
Currently just prepend the name with the string \"Toggle \".
-radio: A radio button.
+radio: A radio button.
nil: An ordinary menu item.
:selected SELECTED
(easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
(defun easy-menu-do-define (symbol maps doc menu)
- (if (featurep 'menubar)
- (progn
- (set symbol menu)
- (fset symbol (list 'lambda '(e)
- doc
- '(interactive "@e")
- '(run-hooks 'activate-menubar-hook)
- '(setq zmacs-region-stays 't)
- (list 'popup-menu symbol))))))
+ (when (featurep 'menubar)
+ (set symbol menu)
+ (fset symbol `(lambda (e)
+ ,doc
+ (interactive "@e")
+ (run-hooks 'activate-menubar-hook)
+ (setq zmacs-region-stays 't)
+ (popup-menu ,symbol)))))
(defun easy-menu-change (&rest args)
(when (featurep 'menubar)
(defun easy-menu-add (menu &optional map)
"Add MENU to the current menu bar."
- (if (featurep 'menubar)
- (progn
- (unless (member menu easy-menu-all-popups)
- (push menu easy-menu-all-popups))
- (setq mode-popup-menu (if (> (length easy-menu-all-popups) 1)
- (cons (easy-menu-title)
- (reverse easy-menu-all-popups))
- (car easy-menu-all-popups)))
-
- (cond ((null current-menubar)
- ;; Don't add it to a non-existing menubar.
- nil)
- ((assoc (car menu) current-menubar)
- ;; Already present.
- nil)
- ((equal current-menubar '(nil))
- ;; Set at left if only contains right marker.
- (set-buffer-menubar (list menu nil)))
- (t
- ;; Add at right.
- (set-buffer-menubar (copy-sequence current-menubar))
- (add-menu nil (car menu) (cdr menu)))))))
+ (when (featurep 'menubar)
+ (unless (member menu easy-menu-all-popups)
+ (push menu easy-menu-all-popups))
+ (setq mode-popup-menu (if (> (length easy-menu-all-popups) 1)
+ (cons (easy-menu-title)
+ (reverse easy-menu-all-popups))
+ (let ((same-as-menu
+ (car easy-menu-all-popups)))
+ (cons (normalize-menu-item-name
+ (car same-as-menu))
+ (cdr same-as-menu)))))
+
+ (cond ((null current-menubar)
+ ;; Don't add it to a non-existing menubar.
+ nil)
+ ((assoc (car menu) current-menubar)
+ ;; Already present.
+ nil)
+ ((equal current-menubar '(nil))
+ ;; Set at left if only contains right marker.
+ (set-buffer-menubar (list menu nil)))
+ (t
+ ;; Add at right.
+ (set-buffer-menubar (copy-sequence current-menubar))
+ (add-menu nil (car menu) (cdr menu))))))
(defun easy-menu-remove (menu)
"Remove MENU from the current menu bar."
- (if (featurep 'menubar)
- (progn
- (setq easy-menu-all-popups (delq menu easy-menu-all-popups)
- mode-popup-menu (if (< (length easy-menu-all-popups) 1)
- (cons (easy-menu-title)
- (reverse easy-menu-all-popups))
- (car easy-menu-all-popups)))
-
- (and current-menubar
- (assoc (car menu) current-menubar)
- (delete-menu-item (list (car menu)))))))
+ (when (featurep 'menubar)
+ (setq easy-menu-all-popups (delq menu easy-menu-all-popups)
+ mode-popup-menu (if (< (length easy-menu-all-popups) 1)
+ (cons (easy-menu-title)
+ (reverse easy-menu-all-popups))
+ (let ((same-as-menu
+ (car easy-menu-all-popups)))
+ (cons (normalize-menu-item-name
+ (car same-as-menu))
+ (cdr same-as-menu)))))
+
+ (and current-menubar
+ (assoc (car menu) current-menubar)
+ (delete-menu-item (list (car menu))))))
(defsubst easy-menu-normalize (menu)
(if (symbolp menu)
menu))
(defun easy-menu-add-item (menu path item &optional before)
- "At the end of the submenu of MENU with path PATH add ITEM.
+ "At the end of the submenu of MENU with path PATH, add ITEM.
If ITEM is already present in this submenu, then this item will be changed.
otherwise ITEM will be added at the end of the submenu, unless the optional
argument BEFORE is present, in which case ITEM will instead be added
before the item named BEFORE.
MENU is either a symbol, which have earlier been used as the first
argument in a call to `easy-menu-define', or the value of such a symbol
-i.e. a menu, or nil which stands for the current menubar.
+i.e. a menu, or nil, which stands for the current menubar.
PATH is a list of strings for locating the submenu where ITEM is to be
added. If PATH is nil, MENU itself is used. Otherwise, the first
element should be the name of a submenu directly under MENU. This
ITEM is either defined as in `easy-menu-define', a menu defined earlier
by `easy-menu-define' or `easy-menu-create-menu' or an item returned
from `easy-menu-item-present-p' or `easy-menu-remove-item'."
- (add-menu-button path item before (easy-menu-normalize menu)))
+ (when (featurep 'menubar)
+ (add-menu-button path item before (easy-menu-normalize menu))))
(defun easy-menu-item-present-p (menu path name)
"In submenu of MENU with path PATH, return true iff item NAME is present.
MENU and PATH are defined as in `easy-menu-add-item'.
NAME should be a string, the name of the element to be looked for.
-The return value can be used as as an argument to `easy-menu-add-item'."
- (car (find-menu-item (or (easy-menu-normalize menu) current-menubar)
- (append path (list name)))))
+The return value can be used as an argument to `easy-menu-add-item'."
+ (if (featurep 'menubar)
+ (car (find-menu-item (or (easy-menu-normalize menu) current-menubar)
+ (append path (list name))))
+ nil))
(defun easy-menu-remove-item (menu path name)
- "From submenu of MENU with path PATH remove item NAME.
+ "From submenu of MENU with path PATH, remove item NAME.
MENU and PATH are defined as in `easy-menu-add-item'.
NAME should be a string, the name of the element to be removed.
-The return value can be used as as an argument to `easy-menu-add-item'."
- (delete-menu-item (append path (list name))
- (easy-menu-normalize menu)))
-
+The return value can be used as an argument to `easy-menu-add-item'."
+ (when (featurep 'menubar)
+ (delete-menu-item (append path (list name))
+ (easy-menu-normalize menu))))
+
;;; extents.el --- miscellaneous extent functions not written in C
;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 2000 Ben Wing.
;; Keywords: internal, dumped
;;; Commentary:
-;; some help from stig@hackvan.com here.
+;;; Authorship:
+
+;; Created 1995 Ben Wing.
+;; mapcar-extents (and extent-list?) from stig@hackvan.com, c. 1996.
;;; Code:
buffer-or-string from to nil flags property value)
(nreverse *result*)))
-(defun extent-list (&optional buffer-or-string from to flags)
+(defun extent-list (&optional buffer-or-string from to flags property value)
"Return a list of the extents in BUFFER-OR-STRING.
BUFFER-OR-STRING defaults to the current buffer if omitted.
FROM and TO can be used to limit the range over which extents are
end of BUFFER-OR-STRING, respectively.
FLAGS controls how end cases are treated. For a discussion of this,
-and exactly what ``overlap'' means, see `map-extents'.
+and exactly what ``overlap'' means, see `map-extents'. PROPERTY and VALUE
+are also as in `map-extents'.
If you want to map a function over the extents in a buffer or string,
-consider using `map-extents' or `mapcar-extents' instead."
- (mapcar-extents 'identity nil buffer-or-string from to flags))
+consider using `map-extents' or `mapcar-extents' instead.
+
+See also `extents-at'."
+ (mapcar-extents 'identity nil buffer-or-string from to flags property value))
+
+(defun extent-at-event (event &optional property before at-flag)
+ "Return the smallest extent under EVENT, if any.
+PROPERTY, BEFORE, and AT-FLAG are as in `extent-at'."
+ (let* ((win (event-window event))
+ (p (event-point event)))
+ (and win p (extent-at p (window-buffer win) property before at-flag))))
+
+(defun extents-at-event (event &optional property before at-flag)
+ "Return a list of all extents under EVENT.
+PROPERTY, BEFORE, and AT-FLAG are as in `extent-at'."
+ (let* ((win (event-window event))
+ (p (event-point event)))
+ (and win p (extents-at p (window-buffer win) property before at-flag))))
(defun extent-string (extent)
"Return the string delimited by the bounds of EXTENT."
The specifications in a specifier determine what the value of
PROPERTY will be in a particular \"domain\" or set of circumstances,
which is typically a particular Emacs window along with the buffer
- it contains and the frame and device it lies within. The value
- is derived from the instantiator associated with the most specific
+ it contains and the frame and device it lies within. The value is
+ derived from the instantiator associated with the most specific
locale (in the order buffer, window, frame, device, and 'global)
that matches the domain in question. In other words, given a domain
- (i.e. an Emacs window, usually), the specifier for PROPERTY will first
- be searched for a specification whose locale is the buffer contained
- within that window; then for a specification whose locale is the window
- itself; then for a specification whose locale is the frame that the
- window is contained within; etc. The first instantiator that is
- valid for the domain (usually this means that the instantiator is
- recognized by the device [i.e. the X server or TTY device] that the
- domain is on. The function `face-property-instance' actually does
- all this, and is used to determine how to display the face.
+ (i.e. an Emacs window, usually), the specifier for PROPERTY will
+ first be searched for a specification whose locale is the buffer
+ contained within that window; then for a specification whose locale
+ is the window itself; then for a specification whose locale is the
+ frame that the window is contained within; etc. The first
+ instantiator that is valid for the domain (usually this means that
+ the instantiator is recognized by the device [i.e. MS Windows, the X
+ server or TTY device] that the domain is on. The function
+ `face-property-instance' actually does all this, and is used to
+ determine how to display the face.
See `set-face-property' for the built-in property-names."
This should be a vector of 256 elements.
background-pixmap The pixmap displayed in the background of the face.
- Only used by faces on X devices.
+ Only used by faces on X and MS Windows devices.
For valid instantiators, see `make-image-specifier'.
underline Underline all text covered by this face.
;; WE DEMAND LEXICAL SCOPING!!!
;; WE DEMAND LEXICAL SCOPING!!!
;; WE DEMAND LEXICAL SCOPING!!!
-(defun frob-face-property (face property func &optional locale tags)
+(defun frob-face-property (face property func device-tags &optional
+locale tags)
"Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE.
This function is ugly and messy and is primarily used as an internal
helper function for `make-face-bold' et al., so you probably don't
first valid instantiator is used), and that result substituted for
the specification; otherwise, the process just outlined is
iterated over each existing device and the concatenated results
-substituted for the specification."
+substituted for the specification.
+
+DEVICE-TAGS is a list of tags that each device must match in order for
+the function to be called on it."
(let ((sp (face-property face property))
temp-sp)
(if (valid-specifier-domain-p locale)
;; this is easy.
(let* ((inst (face-property-instance face property locale))
- (name (and inst (funcall func inst (dfw-device locale)))))
+ (name (and inst
+ (device-matches-specifier-tag-set-p
+ (dfw-device locale) device-tags)
+ (funcall func inst (dfw-device locale)))))
(when name
(add-spec-to-specifier sp name locale tags)))
;; otherwise, map over all specifications ...
;; Otherwise map frob-face-property-1 over each device.
(result
(if device
- (list (frob-face-property-1 sp-arg device inst-list func))
+ (list (and (device-matches-specifier-tag-set-p
+ device device-tags)
+ (frob-face-property-1 sp-arg device inst-list
+ func)))
(mapcar (lambda (device)
- (frob-face-property-1 sp-arg device
- inst-list func))
+ (and (device-matches-specifier-tag-set-p
+ device device-tags)
+ (frob-face-property-1 sp-arg device
+ inst-list func)))
(device-list))))
new-result)
;; remove duplicates and nils from the obtained list of
(setq arg (cons tags arg))
(setcar arg (append tags (delete 'default
(car arg))))))
- (when (and arg (not (member arg new-result)))
+ (when (and arg (not (member arg new-result)))
(setq new-result (cons arg new-result))))
result)
;; add back in.
(or result first-valid)))
(defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
- tty-thunk x-thunk standard-face-mapping)
+ tty-thunk ws-thunk standard-face-mapping)
;; another kludge to make things more intuitive. If we're
;; inheriting from a standard face in this locale, frob the
- ;; inheritance as appropriate. Else, if, after the first X frobbing
- ;; pass, the face hasn't changed and still looks like the standard
- ;; unfrobbed face (e.g. 'default), make it inherit from the standard
- ;; frobbed face (e.g. 'bold). Regardless of things, do the TTY
- ;; frobbing.
+ ;; inheritance as appropriate. Else, if, after the first
+ ;; window-system frobbing pass, the face hasn't changed and still
+ ;; looks like the standard unfrobbed face (e.g. 'default), make it
+ ;; inherit from the standard frobbed face (e.g. 'bold). Regardless
+ ;; of things, do the TTY frobbing.
;; yuck -- The LOCALE argument to make-face-bold is not actually a locale,
;; but is a "locale, locale-type, or nil for all". So ... do our extra
(t nil)))
(inst (and domain (face-property-instance face 'font domain))))
(funcall tty-thunk)
- (funcall x-thunk)
+ (funcall ws-thunk)
;; If it's reasonable to do the inherit-from-standard-face trick,
;; and it's called for, then do it now.
(or (null domain)
(defun make-face-bold (face &optional locale tags)
"Make FACE bold in LOCALE, if possible.
-This will attempt to make the font bold for X locales and will set the
+This will attempt to make the font bold for X/MSW locales and will set the
highlight flag for TTY locales.
If LOCALE is nil, omitted, or `all', this will attempt to frob all
(when (featurep 'tty)
(set-face-highlight-p face t locale (cons 'tty tags))))
(lambda ()
- ;; handle X specific entries
+ ;; handle X/MS Windows specific entries
(when (featurep 'x)
- (frob-face-property face 'font 'x-make-font-bold locale tags))
+ (frob-face-property face 'font 'x-make-font-bold
+ '(x) locale tags))
(when (featurep 'mswindows)
- (frob-face-property face 'font 'mswindows-make-font-bold locale tags))
+ (frob-face-property face 'font 'mswindows-make-font-bold
+ '(mswindows) locale tags))
)
'(([default] . [bold])
([bold] . t)
(defun make-face-italic (face &optional locale tags)
"Make FACE italic in LOCALE, if possible.
-This will attempt to make the font italic for X locales and will set
-the underline flag for TTY locales.
-See `make-face-bold' for the semantics of the LOCALE argument and
-for more specifics on exactly how this function works."
+This will attempt to make the font italic for X/MS Windows locales and
+will set the underline flag for TTY locales. See `make-face-bold' for
+the semantics of the LOCALE argument and for more specifics on exactly
+how this function works."
(interactive (list (read-face-name "Make which face italic: ")))
(frob-face-font-2
face locale tags 'default 'italic
(lambda ()
;; handle X specific entries
(when (featurep 'x)
- (frob-face-property face 'font 'x-make-font-italic locale tags))
+ (frob-face-property face 'font 'x-make-font-italic
+ '(x) locale tags))
(when (featurep 'mswindows)
- (frob-face-property face 'font 'mswindows-make-font-italic locale tags))
+ (frob-face-property face 'font 'mswindows-make-font-italic
+ '(mswindows) locale tags))
)
'(([default] . [italic])
([bold] . [bold-italic])
(defun make-face-bold-italic (face &optional locale tags)
"Make FACE bold and italic in LOCALE, if possible.
-This will attempt to make the font bold-italic for X locales and will
-set the highlight and underline flags for TTY locales.
-See `make-face-bold' for the semantics of the LOCALE argument and
-for more specifics on exactly how this function works."
+This will attempt to make the font bold-italic for X/MS Windows
+locales and will set the highlight and underline flags for TTY
+locales. See `make-face-bold' for the semantics of the LOCALE
+argument and for more specifics on exactly how this function works."
(interactive (list (read-face-name "Make which face bold-italic: ")))
(frob-face-font-2
face locale tags 'default 'bold-italic
(lambda ()
;; handle X specific entries
(when (featurep 'x)
- (frob-face-property face 'font 'x-make-font-bold-italic locale tags))
+ (frob-face-property face 'font 'x-make-font-bold-italic
+ '(x) locale tags))
(when (featurep 'mswindows)
- (frob-face-property face 'font 'mswindows-make-font-bold-italic locale tags))
+ (frob-face-property face 'font 'mswindows-make-font-bold-italic
+ '(mswindows) locale tags))
)
'(([default] . [italic])
([bold] . [bold-italic])
(defun make-face-unbold (face &optional locale tags)
"Make FACE non-bold in LOCALE, if possible.
-This will attempt to make the font non-bold for X locales and will
-unset the highlight flag for TTY locales.
-See `make-face-bold' for the semantics of the LOCALE argument and
-for more specifics on exactly how this function works."
+This will attempt to make the font non-bold for X/MS Windows locales
+and will unset the highlight flag for TTY locales. See
+`make-face-bold' for the semantics of the LOCALE argument and for more
+specifics on exactly how this function works."
(interactive (list (read-face-name "Make which face non-bold: ")))
(frob-face-font-2
face locale tags 'bold 'default
(lambda ()
;; handle X specific entries
(when (featurep 'x)
- (frob-face-property face 'font 'x-make-font-unbold locale tags))
+ (frob-face-property face 'font 'x-make-font-unbold
+ '(x) locale tags))
(when (featurep 'mswindows)
- (frob-face-property face 'font 'mswindows-make-font-unbold locale tags))
+ (frob-face-property face 'font 'mswindows-make-font-unbold
+ '(mswindows) locale tags))
)
'(([default] . t)
([bold] . [default])
(defun make-face-unitalic (face &optional locale tags)
"Make FACE non-italic in LOCALE, if possible.
-This will attempt to make the font non-italic for X locales and will
-unset the underline flag for TTY locales.
-See `make-face-bold' for the semantics of the LOCALE argument and
-for more specifics on exactly how this function works."
+This will attempt to make the font non-italic for X/MS Windows locales
+and will unset the underline flag for TTY locales. See
+`make-face-bold' for the semantics of the LOCALE argument and for more
+specifics on exactly how this function works."
(interactive (list (read-face-name "Make which face non-italic: ")))
(frob-face-font-2
face locale tags 'italic 'default
(lambda ()
;; handle X specific entries
(when (featurep 'x)
- (frob-face-property face 'font 'x-make-font-unitalic locale tags))
+ (frob-face-property face 'font 'x-make-font-unitalic
+ '(x) locale tags))
(when (featurep 'mswindows)
- (frob-face-property face 'font 'mswindows-make-font-unitalic locale tags))
+ (frob-face-property face 'font 'mswindows-make-font-unitalic
+ '(mswindows) locale tags))
)
'(([default] . t)
([bold] . t)
(interactive (list (read-face-name "Shrink which face: ")))
;; handle X specific entries
(when (featurep 'x)
- (frob-face-property face 'font 'x-find-smaller-font locale))
+ (frob-face-property face 'font 'x-find-smaller-font
+ '(x) locale))
(when (featurep 'mswindows)
- (frob-face-property face 'font 'mswindows-find-smaller-font locale)))
+ (frob-face-property face 'font 'mswindows-find-smaller-font
+ '(mswindows) locale)))
(defun make-face-larger (face &optional locale)
"Make the font of FACE be larger, if possible.
(interactive (list (read-face-name "Enlarge which face: ")))
;; handle X specific entries
(when (featurep 'x)
- (frob-face-property face 'font 'x-find-larger-font locale))
+ (frob-face-property face 'font 'x-find-larger-font
+ '(x) locale))
(when (featurep 'mswindows)
- (frob-face-property face 'font 'mswindows-find-larger-font locale)))
+ (frob-face-property face 'font 'mswindows-find-larger-font
+ '(mswindows) locale)))
(defun invert-face (face &optional locale)
"Swap the foreground and background colors of the face."
(defvar default-custom-frame-properties nil
"The frame properties used for the global faces.
-Frames not matching these propertiess should have frame local faces.
+Frames not matching these properties should have frame local faces.
The value should be nil, if uninitialized, or a plist otherwise.
See `defface' for a list of valid keys and values for the plist.")
(defun paths-decode-directory-path (string &optional drop-empties)
"Split STRING at path separators into a directory list.
-Non-\"\" comonents are converted into directory form.
+Non-\"\" components are converted into directory form.
If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output.
Otherwise, they are left alone."
(let* ((components (split-path string))
`(
(abbrev . "abbreviation handling, typing shortcuts, macros")
(bib . "code related to the `bib' bibliography processor")
+ (build . "code used to build XEmacs")
(c . "C, C++, and Objective-C language support")
(calendar . "calendar and time management support")
(comm . "communications, networking, remote access to files")
+ (content . "contains content (menu/dialog box descs, text, images, &c)")
(data . "support for editing files of data")
- (docs . "support for Emacs documentation")
- (dumped . "files preloaded into Emacs")
+ (docs . "support for XEmacs documentation")
+ (dumped . "files preloaded into XEmacs")
(emulations . "emulations of other editors")
(extensions . "Emacs Lisp language extensions")
(faces . "support for multiple fonts")
- (frames . "support for Emacs frames and window systems")
+ (frames . "support for XEmacs frames and window systems")
(games . "games, jokes and amusements")
+ (gui . "support for menubars, dialog boxes, and other GUI features")
(hardware . "support for interfacing with exotic hardware")
(help . "support for on-line help systems")
(hypermedia . "support for links between text or other media types")
(i18n . "internationalization and alternate character-set support")
- (internal . "code for Emacs internals, build process, defaults")
+ (internal . "code implementing core functionality in XEmacs")
(languages . "specialized modes for editing programming languages")
(lisp . "Lisp support, including Emacs Lisp")
(local . "code local to your site")
- (maint . "maintenance aids for the Emacs development group")
(mail . "modes for electronic-mail handling")
+ (maint . "maintenance aids for the Emacs development group")
(matching . "various sorts of searching and matching")
(mouse . "mouse support")
+ (mswin . "support for anything running on MS Windows")
,(when (featurep 'mule)
(cons 'mule "multi-language extensions"))
(news . "support for netnews reading and posting")
(oop . "support for object-oriented programming")
(outlines . "support for hierarchical outlining")
(processes . "process, subshell, compilation, and job control support")
+ (services . "provides services for use by other programs (cf `user')")
(terminals . "support for terminal types")
(tex . "code related to the TeX formatter")
(tools . "programming tools")
(unix . "front-ends/assistants for, or emulators of, UNIX features")
+ (user . "program interacts directly with the user (cf `services'")
(vms . "support code for vms")
(wp . "word processing")
+ (www . "support for the Web (WWW, the World Wide Web)")
))
(defvar finder-mode-map nil)
(setq dirs (cdr dirs)))
found)))
+;;;###autoload
(defun finder-commentary (file)
"Display FILE's commentary section.
FILE should be in a form suitable for passing to `locate-library'."
"\\<finder-mode-map>\\[finder-select] = select, \\[finder-list-keywords] = keywords, \\[finder-edit] = edit, \\[finder-view] = view, \\[finder-exit] = quit, \\[finder-summary] = help")))
(defun finder-exit ()
- "Exit Finder mode and kill the buffer"
+ "Exit Finder mode and kill the buffer."
(interactive)
;; XEmacs change
(or (one-window-p t 0)
;; Copyright (C) 1992-1995, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Amdahl Corporation.
-;; Copyright (C) 1996 Ben Wing.
+;; Copyright (C) 1996, 2000 Ben Wing.
;; Author: Jamie Zawinski <jwz@jwz.org>, for the LISPM Preservation Society.
;; Minimally merged with FSF 19.34 by Barry Warsaw <bwarsaw@python.org>
((or (null maximum-size) (<= (buffer-size) maximum-size))
(font-lock-fontify-buffer))
(font-lock-verbose
- (lprogress-display 'font-lock
- "Fontifying %s... buffer too big." 'abort
- (buffer-name)))))
+ (progress-feedback-with-label
+ 'font-lock
+ "Fontifying %s... buffer too big." 'abort
+ (buffer-name)))))
(font-lock-fontified
(setq font-lock-fontified nil)
(font-lock-unfontify-region (point-min) (point-max))
(font-lock-mode 0)))
(set (make-local-variable 'font-lock-fontified) t)
(when (and aborted font-lock-verbose)
- (lprogress-display 'font-lock "Fontifying %s... aborted."
- 'abort (buffer-name))))
+ (progress-feedback-with-label 'font-lock "Fontifying %s... aborted."
+ 'abort (buffer-name))))
(run-hooks 'font-lock-after-fontify-buffer-hook)))
(defun font-lock-default-unfontify-buffer ()
(defun font-lock-default-unfontify-region (beg end &optional maybe-loudly)
(when (and maybe-loudly font-lock-verbose
(>= (- end beg) font-lock-message-threshold))
- (lprogress-display 'font-lock "Fontifying %s..." 0 (buffer-name)))
+ (progress-feedback-with-label 'font-lock "Fontifying %s..." 0
+ (buffer-name)))
(let ((modified (buffer-modified-p))
(buffer-undo-list t) (inhibit-read-only t)
buffer-file-name buffer-file-truename)
nil
(when (and font-lock-verbose
(>= (- end start) font-lock-message-threshold))
- (lprogress-display 'font-lock "Fontifying %s... (syntactically)" 5
- (buffer-name)))
+ (progress-feedback-with-label 'font-lock
+ "Fontifying %s... (syntactically)" 5
+ (buffer-name)))
(font-lock-unfontify-region start end loudly)
(goto-char start)
(if (> end (point-max)) (setq end (point-max)))
(+ (/ (* (- (point) start) 95) (* (- end start) nkeywords))
(/ (* iter 95) nkeywords) 5))
(when (and loudly (> progress old-progress))
- (lprogress-display 'font-lock "Fontifying %s... (regexps)"
- progress bufname))
+ (progress-feedback-with-label 'font-lock
+ "Fontifying %s... (regexps)"
+ progress bufname))
(setq old-progress progress)
;; Apply each highlight to this instance of `matcher', which may be
;; specific highlights or more keywords anchored to `matcher'.
(setq highlights (cdr highlights))))
(setq iter (1+ iter))
(setq keywords (cdr keywords))))
- (if loudly (lprogress-display 'font-lock "Fontifying %s... " 100 (buffer-name)))))
+ (if loudly
+ (progress-feedback-with-label 'font-lock "Fontifying %s... " 100
+ (buffer-name)))))
\f
;; Various functions.
;;
;; Control structures. ELisp and CLisp combined.
;;
- ;;(regexp-opt
- ;; '("cond" "if" "while" "let" "let*" "prog" "progn" "prog1"
- ;; "prog2" "progv" "catch" "throw" "save-restriction"
- ;; "save-excursion" "save-window-excursion"
- ;; "save-current-buffer" "with-current-buffer"
- ;; "with-temp-file" "with-temp-buffer" "with-output-to-string"
- ;; "with-string-as-buffer-contents"
- ;; "save-selected-window" "save-match-data" "unwind-protect"
- ;; "condition-case" "track-mouse" "autoload"
- ;; "eval-after-load" "eval-and-compile" "eval-when-compile"
- ;; "when" "unless" "do" "dolist" "dotimes" "flet" "labels"
- ;; "lambda" "return" "return-from"))
(cons
(concat
"(\\("
- "autoload\\|c\\(atch\\|ond\\(ition-case\\)?\\)\\|do\\(list\\|"
- "times\\)?\\|eval-\\(a\\(fter-load\\|nd-compile\\)\\|when-compile\\)\\|"
- "flet\\|if\\|l\\(a\\(bels\\|mbda\\)\\|et\\*?\\)\\|"
- "prog[nv12\\*]?\\|return\\(-from\\)?\\|save-\\(current-buffer\\|"
- "excursion\\|match-data\\|restriction\\|selected-window\\|"
- "window-excursion\\)\\|t\\(hrow\\|rack-mouse\\)\\|un\\(less\\|"
- "wind-protect\\)\\|w\\(h\\(en\\|ile\\)\\|ith-\\(current-buffer\\|"
- "output-to-string\\|string-as-buffer-contents\\|temp-\\(buffer\\|"
- "file\\)\\)\\)"
+ ;; beginning of generated stuff
+ ;; to regenerate, use the regexp-opt below, then delete the outermost
+ ;; grouping, then use the macro below to break up the string.
+ ;; (regexp-opt
+ ;; '("cond" "if" "while" "let" "let*" "prog" "progn" "prog1"
+ ;; "prog2" "progv" "catch" "throw" "save-restriction"
+ ;; "save-excursion" "save-window-excursion"
+ ;; "save-current-buffer" "with-current-buffer"
+ ;; "save-selected-window" "with-selected-window"
+ ;; "save-selected-frame" "with-selected-frame"
+ ;; "with-temp-file" "with-temp-buffer" "with-output-to-string"
+ ;; "with-string-as-buffer-contents"
+ ;; "save-match-data" "unwind-protect" "call-with-condition-handler"
+ ;; "condition-case" "track-mouse" "autoload"
+ ;; "eval-after-load" "eval-and-compile" "eval-when-compile"
+ ;; "when" "unless" "do" "dolist" "dotimes" "flet" "labels"
+ ;; "lambda" "block" "return" "return-from" "loop") t)
+ ;; (setq last-kbd-macro
+ ;; (read-kbd-macro "\" C-7 C-1 <right> C-r \\\\| 3*<right> \" RET"))
+ "autoload\\|block\\|c\\(?:a\\(?:ll-with-condition-handler\\|tch\\)\\|"
+ "ond\\(?:ition-case\\)?\\)\\|do\\(?:list\\|times\\)?\\|"
+ "eval-\\(?:a\\(?:fter-load\\|nd-compile\\)\\|when-compile\\)\\|flet\\|"
+ "if\\|l\\(?:a\\(?:bels\\|mbda\\)\\|et\\*?\\|oop\\)\\|prog[12nv]?\\|"
+ "return\\(?:-from\\)?\\|save-\\(?:current-buffer\\|excursion\\|"
+ "match-data\\|restriction\\|selected-\\(?:frame\\|window\\)\\|"
+ "window-excursion\\)\\|t\\(?:hrow\\|rack-mouse\\)\\|un\\(?:less\\|"
+ "wind-protect\\)\\|w\\(?:h\\(?:en\\|ile\\)\\|ith-\\(?:current-buffer\\|"
+ "output-to-string\\|s\\(?:elected-\\(?:frame\\|window\\)\\|"
+ "tring-as-buffer-contents\\)\\|temp-\\(?:buffer\\|file\\)\\)\\)"
+ ;; end of generated stuff
"\\)\\>") 1)
;;
;; Feature symbols as references.
"\\|long\\|short\\|void\\)\\>")
"Regexp which should match a primitive type.")
-(let ((capital-letter "A-Z\300-\326\330-\337")
- (letter "a-zA-Z_$\300-\326\330-\366\370-\377")
- (digit "0-9"))
(defvar java-font-lock-identifier-regexp
- (concat "\\<\\([" letter "][" letter digit "]*\\)\\>")
+ (let ((letter "a-zA-Z_$\300-\326\330-\366\370-\377")
+ (digit "0-9"))
+ (concat "\\<\\([" letter "][" letter digit "]*\\)\\>"))
"Regexp which should match all Java identifiers.")
(defvar java-font-lock-class-name-regexp
- (concat "\\<\\([" capital-letter "][" letter digit "]*\\)\\>")
+ (let ((capital-letter "A-Z\300-\326\330-\337")
+ (letter "a-zA-Z_$\300-\326\330-\366\370-\377")
+ (digit "0-9"))
+ (concat "\\<\\([" capital-letter "][" letter digit "]*\\)\\>"))
"Regexp which should match a class or an interface name.
The name is assumed to begin with a capital letter.")
-)
-
(let ((java-modifier-regexp
(concat "\\<\\(abstract\\|const\\|final\\|native\\|"
See `glyph-property-instance' for more information."
(glyph-property-instance glyph 'image domain default no-fallback))
+(defun glyph-image-property (glyph prop &optional domain default no-fallback)
+ "Return property PROP of the instance of GLYPH's image in DOMAIN.
+
+Normally DOMAIN will be a window or nil (meaning the selected window).
+The value returned is dependent on the image instance type."
+ (image-instance-property
+ (glyph-image-instance glyph domain default no-fallback) prop))
+
(defun set-glyph-image (glyph spec &optional locale tag-set how-to-add)
"Change the image of GLYPH in LOCALE.
`modeline-pointer-glyph' for the pointer used over the modeline, etc.
Do an apropos over `*-pointer-glyph' to find all of them. (Note also
that you can temporarily set the mouse pointer to some specific shape
- by using `set-frame-pointer', which takes an image instace, as obtained
+ by using `set-frame-pointer', which takes an image instance, as obtained
from calling `glyph-image-instance' on a glyph of type `pointer' --
either one of the above-mentioned variables or one you created yourself.
(See below for what it means to create a glyph of type `pointer'.)
otherwise it is killed."
(interactive)
(let ((buf (current-buffer)))
- (cond ((frame-property (selected-frame) 'help-window-config)
- (set-window-configuration
- (frame-property (selected-frame) 'help-window-config))
- (set-frame-property (selected-frame) 'help-window-config nil))
+ (cond (help-window-config
+ (set-window-configuration help-window-config))
((not (one-window-p))
(delete-window)))
(if bury
;; another name (which is a shame, because w-d-h-b is a perfect name
;; for a macro) that uses with-displaying-help-buffer internally.
+(defcustom mode-for-help 'help-mode
+ "*Mode that help buffers are put into.")
+
+(defvar help-sticky-window nil
+;; Window into which help buffers will be displayed, rather than
+;; always searching for a new one. This is INTERNAL and liable to
+;; change its interface and/or name at any moment. It should be
+;; bound, not set.
+)
+
+(defvar help-window-config nil)
+
+(make-variable-buffer-local 'help-window-config)
+(put 'help-window-config 'permanent-local t)
+
(defun with-displaying-help-buffer (thunk &optional name)
"Form which makes a help buffer with given NAME and evaluates BODY there.
The actual name of the buffer is generated by the function `help-buffer-name'."
(mapcar 'window-frame
(windows-of-buffer buffer-name)))))))
(help-register-and-maybe-prune-excess buffer-name)
- (prog1 (with-output-to-temp-buffer buffer-name
- (prog1 (funcall thunk)
- (save-excursion
- (set-buffer standard-output)
- (help-mode))))
+ ;; if help-sticky-window is bogus or deleted, get rid of it.
+ (if (and help-sticky-window (or (not (windowp help-sticky-window))
+ (not (window-live-p help-sticky-window))))
+ (setq help-sticky-window nil))
+ (prog1
+ (let ((temp-buffer-show-function
+ (if help-sticky-window
+ #'(lambda (buffer)
+ (set-window-buffer help-sticky-window buffer))
+ temp-buffer-show-function)))
+ (with-output-to-temp-buffer buffer-name
+ (prog1 (funcall thunk)
+ (save-excursion
+ (set-buffer standard-output)
+ (funcall mode-for-help)))))
(let ((helpwin (get-buffer-window buffer-name)))
(when helpwin
- (with-current-buffer (window-buffer helpwin)
- ;; If the *Help* buffer is already displayed on this
- ;; frame, don't override the previous configuration
- (when help-not-visible
- (set-frame-property (selected-frame)
- 'help-window-config winconfig)))
+ ;; If the *Help* buffer is already displayed on this
+ ;; frame, don't override the previous configuration
+ (when help-not-visible
+ (with-current-buffer (window-buffer helpwin)
+ (setq help-window-config winconfig)))
(when help-selects-help-window
(select-window helpwin))
(cond ((eq helpwin (selected-window))
(defun xemacs-www-page ()
"Go to the XEmacs World Wide Web page."
(interactive)
- (if (boundp 'browse-url-browser-function)
- (funcall browse-url-browser-function "http://www.xemacs.org/")
+ (if (fboundp 'browse-url)
+ (browse-url "http://www.xemacs.org/")
(error "xemacs-www-page requires browse-url")))
(defun xemacs-www-faq ()
"View the latest and greatest XEmacs FAQ using the World Wide Web."
(interactive)
- (if (boundp 'browse-url-browser-function)
- (funcall browse-url-browser-function
- "http://www.xemacs.org/faq/index.html")
+ (if (fboundp 'browse-url)
+ (browse-url "http://www.xemacs.org/faq/index.html")
(error "xemacs-www-faq requires browse-url")))
(defun xemacs-local-faq ()
(setq obj (read (current-buffer)))
(and (symbolp obj) (fboundp obj) obj)))))))
+(defun function-at-event (event)
+ "Return the function whose name is around the position of EVENT.
+EVENT should be a mouse event. When calling from a popup or context menu,
+use `last-popup-menu-event' to find out where the mouse was clicked.
+\(You cannot use (interactive \"e\"), unfortunately. This returns a
+misc-user event.)
+
+If the event contains no position, or the position is not over text, or
+there is no function around that point, nil is returned."
+ (if (and event (event-buffer event) (event-point event))
+ (save-excursion
+ (set-buffer (event-buffer event))
+ (goto-char (event-point event))
+ (function-at-point))))
+
;; Default to nil for the non-hackers? Not until we find a way to
;; distinguish hackers from non-hackers automatically!
(defcustom describe-function-show-arglist t
(string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc))
(setq doc (substring doc 0 (match-beginning 0))))
doc))
+; (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]"))
+; (list
+; ;;
+; ;; The symbol itself.
+; (list (concat "\\`\\(" name-char "+\\)\\(:\\)?")
+; '(1 (if (match-beginning 2)
+; 'font-lock-function-name-face
+; 'font-lock-variable-name-face)
+; nil t))
+; ;;
+; ;; Words inside `' which tend to be symbol names.
+; (list (concat "`\\(" sym-char sym-char "+\\)'")
+; 1 '(prog1
+; 'font-lock-reference-face
+; (add-list-mode-item (match-beginning 1)
+; (match-end 1)
+; nil
+; 'help-follow-reference))
+; t)
+; ;;
+; ;; CLisp `:' keywords as references.
+; (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t)))
+
+(defvar help-symbol-regexp
+ (let ((sym-char "[+a-zA-Z0-9_:*]")
+ (sym-char-no-dash "[-+a-zA-Z0-9_:*]"))
+ (concat "\\("
+ ;; a symbol with a - in it.
+ "\\<\\(" sym-char-no-dash "+\\(-" sym-char-no-dash "+\\)+\\)\\>"
+ "\\|"
+ "`\\(" sym-char "+\\)'"
+ "\\)")))
+
+(defun help-symbol-run-function-1 (ev ex fun)
+ (let ((help-sticky-window
+ ;; if we were called from a help buffer, make sure the new help
+ ;; goes in the same window.
+ (if (and (event-buffer ev)
+ (symbol-value-in-buffer 'help-window-config
+ (event-buffer ev)))
+ (event-window ev)
+ help-sticky-window)))
+ (funcall fun (extent-property ex 'help-symbol))))
+
+(defun help-symbol-run-function (fun)
+ (let ((ex (extent-at-event last-popup-menu-event 'help-symbol)))
+ (when ex
+ (help-symbol-run-function-1 last-popup-menu-event ex fun))))
+
+(defvar help-symbol-function-context-menu
+ '("---"
+ ["View %_Documentation" (help-symbol-run-function 'describe-function)]
+ ["Find %_Function Source" (help-symbol-run-function 'find-function)]
+ ))
+
+(defvar help-symbol-variable-context-menu
+ '("---"
+ ["View %_Documentation" (help-symbol-run-function 'describe-variable)]
+ ["Find %_Variable Source" (help-symbol-run-function 'find-variable)]
+ ))
+
+(defvar help-symbol-function-and-variable-context-menu
+ '("---"
+ ["View Function %_Documentation" (help-symbol-run-function
+ 'describe-function)]
+ ["View Variable D%_ocumentation" (help-symbol-run-function
+ 'describe-variable)]
+ ["Find %_Function Source" (help-symbol-run-function 'find-function)]
+ ["Find %_Variable Source" (help-symbol-run-function 'find-variable)]
+ ))
+
+(defun frob-help-extents (buffer)
+ ;; Look through BUFFER, starting at the buffer's point and continuing
+ ;; till end of file, and find documented functions and variables.
+ ;; any such symbol found is tagged with an extent, that sets up these
+ ;; properties:
+ ;; 1. mouse-face is 'highlight (so the extent gets highlighted on mouse over)
+ ;; 2. help-symbol is the name of the symbol.
+ ;; 3. context-menu is a list of context menu items, specific to whether
+ ;; the symbol is a function, variable, or both.
+ ;; 4. activate-function will cause the function or variable to be described,
+ ;; replacing the existing help contents.
+ (save-excursion
+ (set-buffer buffer)
+ (let (b e name)
+ (while (re-search-forward help-symbol-regexp nil t)
+ (setq b (or (match-beginning 2) (match-beginning 4)))
+ (setq e (or (match-end 2) (match-end 4)))
+ (setq name (buffer-substring b e))
+ (let* ((sym (intern-soft name))
+ (var (and sym (boundp sym)
+ (documentation-property sym
+ 'variable-documentation t)))
+ (fun (and sym (fboundp sym)
+ (documentation sym t))))
+ (when (or var fun)
+ (let ((ex (make-extent b e)))
+ (set-extent-property ex 'mouse-face 'highlight)
+ (set-extent-property ex 'help-symbol sym)
+ (set-extent-property
+ ex 'context-menu
+ (cond ((and var fun)
+ help-symbol-function-and-variable-context-menu)
+ (var help-symbol-variable-context-menu)
+ (fun help-symbol-function-context-menu)))
+ (set-extent-property
+ ex 'activate-function
+ (if fun
+ #'(lambda (ev ex)
+ (help-symbol-run-function-1 ev ex 'describe-function))
+ #'(lambda (ev ex)
+ (help-symbol-run-function-1 ev ex 'describe-variable))))
+ ))))))) ;; 11 parentheses!
(defun describe-function-1 (function &optional nodoc)
"This function does the work for `describe-function'."
(unless (and obsolete aliases)
(let ((doc (function-documentation function t)))
(princ "Documentation:\n")
- (princ doc)
+ (let ((oldp (point standard-output))
+ newp)
+ (princ doc)
+ (setq newp (point standard-output))
+ (goto-char oldp standard-output)
+ (frob-help-extents standard-output)
+ (goto-char newp standard-output))
(unless (or (equal doc "")
(eq ?\n (aref doc (1- (length doc)))))
(terpri)))))))))
(message nil)
(message (function-arglist function)))
-
(defun variable-at-point ()
(ignore-errors
(with-syntax-table emacs-lisp-mode-syntax-table
(let ((obj (read (current-buffer))))
(and (symbolp obj) (boundp obj) obj))))))
+(defun variable-at-event (event)
+ "Return the variable whose name is around the position of EVENT.
+EVENT should be a mouse event. When calling from a popup or context menu,
+use `last-popup-menu-event' to find out where the mouse was clicked.
+\(You cannot use (interactive \"e\"), unfortunately. This returns a
+misc-user event.)
+
+If the event contains no position, or the position is not over text, or
+there is no variable around that point, nil is returned."
+ (if (and event (event-buffer event) (event-point event))
+ (save-excursion
+ (set-buffer (event-buffer event))
+ (goto-char (event-point event))
+ (variable-at-point))))
+
(defun variable-obsolete-p (variable)
"Return non-nil if VARIABLE is obsolete."
(not (null (get variable 'byte-obsolete-variable))))
(when (or (not obsolete) (not aliases))
(if doc
;; note: documentation-property calls substitute-command-keys.
- (princ doc)
+ (let ((oldp (point standard-output))
+ newp)
+ (princ doc)
+ (setq newp (point standard-output))
+ (goto-char oldp standard-output)
+ (frob-help-extents standard-output)
+ (goto-char newp standard-output))
(princ "not documented as a variable."))))
(terpri)))
(format "variable `%s'" variable)))
(with-displaying-help-buffer
(insert string)))))
-
;;; help.el ends here
(defvar Info-current-node nil
"Name of node that Info is now looking at, or nil.")
-(defvar Info-tag-table-marker (make-marker)
+(defvar Info-tag-table-marker nil
"Marker pointing at beginning of current Info file's tag table.
Marker points nowhere if file has no tag table.")
+(defvar Info-tag-table-buffer nil)
+
(defvar Info-current-file-completions nil
"Cached completion list for current Info file.")
;; should be locked up where they can't do any more harm.
;; Go into info buffer.
- (switch-to-buffer "*info*")
+ (or (eq major-mode 'Info-mode)
+ (switch-to-buffer "*info*"))
(buffer-disable-undo (current-buffer))
(run-hooks 'Info-startup-hook)
(or (eq major-mode 'Info-mode)
(equal Info-current-file filename)
(not Info-novice)
(string= "dir" (file-name-nondirectory Info-current-file))
- (if (y-or-n-p-maybe-dialog-box
+ (if (y-or-n-p
(format "Leave Info file `%s'? "
(file-name-nondirectory Info-current-file)))
(message "")
(looking-at "(Indirect)\n"))
;; It is indirect. Copy it to another buffer
;; and record that the tag table is in that buffer.
- (save-excursion
- (let ((buf (current-buffer)))
- (set-buffer
- (get-buffer-create " *info tag table*"))
- (buffer-disable-undo (current-buffer))
- (setq case-fold-search t)
- (erase-buffer)
- (insert-buffer-substring buf)
- (set-marker Info-tag-table-marker
- (match-end 0))))
+ (let ((buf (current-buffer))
+ (m Info-tag-table-marker))
+ (or
+ Info-tag-table-buffer
+ (setq
+ Info-tag-table-buffer
+ (generate-new-buffer " *info tag table*")))
+ (save-excursion
+ (set-buffer Info-tag-table-buffer)
+ (buffer-disable-undo (current-buffer))
+ (setq case-fold-search t)
+ (erase-buffer)
+ (insert-buffer-substring buf)
+ (set-marker m (match-end 0))))
(set-marker Info-tag-table-marker pos))))
(setq Info-current-file
(file-name-sans-versions buffer-file-name))))
;; Also, if this is an indirect info file,
;; read the proper subfile into this buffer.
(if (marker-position Info-tag-table-marker)
- (save-excursion
- (set-buffer (marker-buffer Info-tag-table-marker))
- (goto-char Info-tag-table-marker)
- (if (re-search-forward regexp nil t)
- (progn
- (setq guesspos (read (current-buffer)))
- ;; If this is an indirect file,
- ;; determine which file really holds this node
- ;; and read it in.
- (if (not (eq (current-buffer) (get-buffer "*info*")))
- (setq guesspos
- (Info-read-subfile guesspos)))))))
+ (let (foun found-mode (m Info-tag-table-marker))
+ (save-excursion
+ (set-buffer (marker-buffer Info-tag-table-marker))
+ (goto-char m)
+ (setq foun (re-search-forward regexp nil t))
+ (if foun
+ (setq guesspos (read (current-buffer))))
+ (setq found-mode major-mode))
+ (if foun
+ ;; If this is an indirect file,
+ ;; determine which file really holds this node
+ ;; and read it in.
+ (if (not (eq major-mode found-mode))
+ (setq guesspos
+ (Info-read-subfile guesspos))))))
(goto-char (max (point-min) (- guesspos 1000)))
;; Now search from our advised position (or from beg of buffer)
;; to find the actual node.
(if p (file-name-nondirectory file) file)))
(defun Info-read-subfile (nodepos)
- (set-buffer (marker-buffer Info-tag-table-marker))
- (goto-char (point-min))
- (search-forward "\n\^_")
(let (lastfilepos
lastfilename)
- (forward-line 2)
- (catch 'foo
- (while (not (looking-at "\^_"))
- (if (not (eolp))
- (let ((beg (point))
- thisfilepos thisfilename)
- (search-forward ": ")
- (setq thisfilename (buffer-substring beg (- (point) 2)))
- (setq thisfilepos (read (current-buffer)))
- ;; read in version 19 stops at the end of number.
- ;; Advance to the next line.
- (if (eolp)
- (forward-line 1))
- (if (> thisfilepos nodepos)
- (throw 'foo t))
- (setq lastfilename thisfilename)
- (setq lastfilepos thisfilepos))
- (throw 'foo t))))
- (set-buffer (get-buffer "*info*"))
+ (save-excursion
+ (set-buffer (marker-buffer Info-tag-table-marker))
+ (goto-char (point-min))
+ (search-forward "\n\^_")
+ (forward-line 2)
+ (catch 'foo
+ (while (not (looking-at "\^_"))
+ (if (not (eolp))
+ (let ((beg (point))
+ thisfilepos thisfilename)
+ (search-forward ": ")
+ (setq thisfilename (buffer-substring beg (- (point) 2)))
+ (setq thisfilepos (read (current-buffer)))
+ ;; read in version 19 stops at the end of number.
+ ;; Advance to the next line.
+ (if (eolp)
+ (forward-line 1))
+ (if (> thisfilepos nodepos)
+ (throw 'foo t))
+ (setq lastfilename thisfilename)
+ (setq lastfilepos thisfilepos))
+ (throw 'foo t)))))
(or (equal Info-current-subfile lastfilename)
(let ((buffer-read-only nil))
(setq buffer-file-name nil)
(defun Info-build-node-completions ()
(or Info-current-file-completions
- (let ((compl (Info-build-annotation-completions)))
+ (let ((m Info-tag-table-marker)
+ (compl (Info-build-annotation-completions)))
(save-excursion
(save-restriction
(widen)
(if (marker-buffer Info-tag-table-marker)
(progn
(set-buffer (marker-buffer Info-tag-table-marker))
- (goto-char Info-tag-table-marker)
+ (goto-char m)
(while (re-search-forward "\nNode: \\(.*\\)\177" nil t)
(setq compl
(cons (list (buffer-substring (match-beginning 1)
(if (not found) ;can only happen in subfile case -- else would have erred
(unwind-protect
(let ((list ()))
- (set-buffer (marker-buffer Info-tag-table-marker))
- (goto-char (point-min))
- (search-forward "\n\^_\nIndirect:")
- (save-restriction
- (narrow-to-region (point)
- (progn (search-forward "\n\^_")
- (1- (point))))
- (goto-char (point-min))
- (search-forward (concat "\n" osubfile ": "))
- (beginning-of-line)
- (while (not (eobp))
- (re-search-forward "\\(^.*\\): [0-9]+$")
- (goto-char (+ (match-end 1) 2))
- (setq list (cons (cons (read (current-buffer))
- (buffer-substring (match-beginning 1)
- (match-end 1)))
- list))
- (goto-char (1+ (match-end 0))))
- (setq list (nreverse list)
- list (cdr list)))
+ (save-excursion
+ (set-buffer (marker-buffer Info-tag-table-marker))
+ (goto-char (point-min))
+ (search-forward "\n\^_\nIndirect:")
+ (save-restriction
+ (narrow-to-region (point)
+ (progn (search-forward "\n\^_")
+ (1- (point))))
+ (goto-char (point-min))
+ (search-forward (concat "\n" osubfile ": "))
+ (beginning-of-line)
+ (while (not (eobp))
+ (re-search-forward "\\(^.*\\): [0-9]+$")
+ (goto-char (+ (match-end 1) 2))
+ (setq list (cons (cons (read (current-buffer))
+ (buffer-substring (match-beginning 1)
+ (match-end 1)))
+ list))
+ (goto-char (1+ (match-end 0))))
+ (setq list (nreverse list)
+ list (cdr list))))
(while list
(message "Searching subfile %s..." (cdr (car list)))
(Info-read-subfile (car (car list)))
(make-local-variable 'Info-current-subfile)
(make-local-variable 'Info-current-node)
(make-local-variable 'Info-tag-table-marker)
+ (setq Info-tag-table-marker (make-marker))
+ (make-local-variable 'Info-tag-table-buffer)
+ (setq Info-tag-table-buffer nil)
(make-local-variable 'Info-current-file-completions)
(make-local-variable 'Info-current-annotation-completions)
(make-local-variable 'Info-index-alternatives)
(interactive)
;; Do this first, so nothing has changed if user C-g's at query.
(and (buffer-modified-p)
- (y-or-n-p-maybe-dialog-box "Save the file? ")
+ (y-or-n-p "Save the file? ")
(save-buffer))
(use-local-map Info-mode-map)
(setq major-mode 'Info-mode)
(set yank-pointer-name
(setq yank-pointer
(mod (+ (or yank-pointer 0)
- (if advance -1 1))
+ ;; XEmacs change
+ (if advance -1 (if yank-pointer 1 0)))
length)))
(setq isearch-string (nth yank-pointer ring)
isearch-message (mapconcat 'isearch-text-char-description
(define-key global-map "\M-\C-t" 'transpose-sexps)
(define-key global-map "\C-x\C-t" 'transpose-lines)
+;; XEmacs: much more reasonable and useful key definitions.
+(define-key global-map '(control T) 'transpose-line-down)
+(define-key global-map '(meta T) 'transpose-line-up)
+
(define-key global-map "\M-;" 'indent-for-comment)
(define-key global-map "\M-j" 'indent-new-comment-line)
(define-key global-map "\M-\C-j" 'indent-new-comment-line)
;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
;; Created: Jan 1998
-;; Version: $Revision: 1.7.2.7 $
+;; Version: $Revision: 1.7.2.8 $
;; Keywords: help comm
;; This file is part of XEmacs
(if decoder
(cons name (mapcar decoder values))
attr)))
-
+
+(defun ldap-decode-entry (entry)
+ "Decode the attributes of ENTRY according to LDAP rules."
+ (let (dn decoded)
+ (setq dn (car entry))
+ (if (stringp dn)
+ (setq entry (cdr entry))
+ (setq dn nil))
+ (setq decoded (mapcar 'ldap-decode-attribute entry))
+ (if dn
+ (cons dn decoded)
+ decoded)))
+
(defun ldap-search (arg1 &rest args)
"Perform an LDAP search."
(apply (if (ldapp arg1)
(ldap-close ldap)
(if ldap-ignore-attribute-codings
result
- (mapcar (function
- (lambda (record)
- (mapcar 'ldap-decode-attribute record)))
- result))))
+ (mapcar 'ldap-decode-entry result))))
(defun ldap-add-entries (entries &optional host binddn passwd)
"Add entries to an LDAP directory.
(defvar emacs-lisp-mode-syntax-table nil)
(defvar lisp-mode-abbrev-table nil)
-;; XEmacs change
-(defvar lisp-interaction-mode-popup-menu
- (purecopy '("Lisp-Interaction"
- ["Evaluate Last %_S-expression" eval-last-sexp]
- ["Evaluate %_Whole Buffer" eval-current-buffer]
- ["Evaluate Re%_gion" eval-region
- :active (region-exists-p)]
- "---"
- ["%_Evaluate This Defun" eval-defun]
- ["%_Instrument This Defun for Debugging" edebug-defun]
- "---"
- ["Find %_Function Source..." find-function
+(defun construct-lisp-mode-menu (popup-p emacs-lisp-p)
+ (flet ((popup-wrap (form)
+ (if popup-p `(menu-call-at-event ',form) form)))
+ `(,@(if emacs-lisp-p
+ `(["%_Byte-Compile This File" ,(popup-wrap
+ 'emacs-lisp-byte-compile)]
+ ["B%_yte-Compile/Load This File"
+ ,(popup-wrap 'emacs-lisp-byte-compile-and-load)]
+ ["Byte-%_Recompile Directory..."
+ ,(popup-wrap 'byte-recompile-directory)]
+ "---"))
+ ["%_Evaluate Region or Defun"
+ ,(popup-wrap '(if (region-exists-p)
+ (call-interactively 'eval-region)
+ (call-interactively 'eval-defun)))]
+ ["Evaluate %_Whole Buffer" ,(popup-wrap 'eval-current-buffer)]
+ ["Evaluate Last %_S-expression" ,(popup-wrap 'eval-last-sexp)]
+ "---"
+ ,@(if popup-p
+ '(["%_Find Function"
+ (find-function (menu-call-at-event '(function-at-point)))
+ :suffix (let ((fun (menu-call-at-event '(function-at-point))))
+ (if fun (symbol-name fun) ""))
+ :active (and (fboundp 'find-function)
+ (menu-call-at-event '(function-at-point)))]
+ ["%_Find Variable"
+ (find-variable (menu-call-at-event '(variable-at-point)))
+ :suffix (let ((fun (menu-call-at-event '(variable-at-point))))
+ (if fun (symbol-name fun) ""))
+ :active (and (fboundp 'find-variable)
+ (menu-call-at-event '(variable-at-point)))]
+ ["%_Help on Function"
+ (describe-function (menu-call-at-event '(function-at-point)))
+ :suffix (let ((fun (menu-call-at-event '(function-at-point))))
+ (if fun (symbol-name fun) ""))
+ :active (and (fboundp 'describe-function)
+ (menu-call-at-event '(function-at-point)))]
+ ["%_Help on Variable"
+ (describe-variable (menu-call-at-event '(variable-at-point)))
+ :suffix (let ((fun (menu-call-at-event '(variable-at-point))))
+ (if fun (symbol-name fun) ""))
+ :active (and (fboundp 'describe-variable)
+ (menu-call-at-event '(variable-at-point)))])
+ '(["Find %_Function..." find-function
:active (fboundp 'find-function)]
- ["Find %_Variable Source..." find-variable
+ ["Find %_Variable..." find-variable
:active (fboundp 'find-variable)]
- ["%_Trace Function..." trace-function-background]
- ["%_Untrace All Functions" untrace-all
- :active (fboundp 'untrace-all)]
- "---"
- ["%_Comment Out Region" comment-region
- :active (region-exists-p)]
- "---"
- ["Indent %_Line or Region"
- (if (region-exists-p)
- (call-interactively 'indent-region)
- (call-interactively 'lisp-indent-line))]
- ["Indent B%_alanced Expression" indent-sexp]
- ["Indent %_Defun"
- (progn
- (beginning-of-defun)
- (indent-sexp))]
- "---"
- "Look for debug-on-error under Options->General"
- )))
+ ["%_Help on Function..." describe-function
+ :active (fboundp 'describe-function)]
+ ["Hel%_p on Variable..." describe-variable
+ :active (fboundp 'describe-variable)]))
+ "---"
+ ["Instrument This Defun for %_Debugging" ,(popup-wrap 'edebug-defun)]
+ ["%_Trace Function..." trace-function-background]
+ ["%_Untrace All Functions" untrace-all
+ :active (fboundp 'untrace-all)]
+ "---"
+ ["%_Comment Out Region" comment-region :active (region-exists-p)]
+ "---"
+ ["%_Indent Region or Balanced Expression"
+ ,(popup-wrap '(if (region-exists-p)
+ (call-interactively 'indent-region)
+ (call-interactively 'indent-sexp)))]
+ ["I%_ndent Defun"
+ ,(popup-wrap '(progn
+ (beginning-of-defun)
+ (indent-sexp)))]
+ "---"
+ "Look for debug-on-error under Options->Troubleshooting"
+ )))
+
+(defvar lisp-interaction-mode-popup-menu
+ (cons "Lisp-Interaction" (construct-lisp-mode-menu t nil)))
(defvar emacs-lisp-mode-popup-menu
- (purecopy
- (nconc
- '("Emacs-Lisp"
- ["%_Byte-Compile This File" emacs-lisp-byte-compile]
- ["B%_yte-Compile/Load This File" emacs-lisp-byte-compile-and-load]
- ["Byte-%_Recompile Directory..." byte-recompile-directory]
- "---")
- (cdr lisp-interaction-mode-popup-menu))))
+ (cons "Emacs-Lisp" (construct-lisp-mode-menu t t)))
;Don't have a menubar entry in Lisp Interaction mode. Otherwise, the
;*scratch* buffer has a Lisp menubar item! Very confusing.
;Jan Vroonhof really wants this, so it's back. --ben
(defvar lisp-interaction-mode-menubar-menu
- (purecopy (cons "%_Lisp" (cdr lisp-interaction-mode-popup-menu))))
+ (cons "%_Lisp" (construct-lisp-mode-menu nil nil)))
(defvar emacs-lisp-mode-menubar-menu
- (purecopy (cons "%_Lisp" (cdr emacs-lisp-mode-popup-menu))))
+ (cons "%_Lisp" (construct-lisp-mode-menu nil t)))
(if (not emacs-lisp-mode-syntax-table)
(let ((i 0))
(let ((function (buffer-substring (point)
(progn (forward-sexp 1) (point))))
method)
- (setq method (or (get (intern-soft function) 'lisp-indent-function)
- (get (intern-soft function) 'lisp-indent-hook)))
+ (if (condition-case nil
+ (save-excursion
+ (backward-up-list 1)
+ (backward-up-list 1)
+ (backward-up-list 1)
+ (looking-at "(flet\\s-"))
+ (error nil))
+ (setq method 'defun)
+ (setq method (or (get (intern-soft function) 'lisp-indent-function)
+ (get (intern-soft function) 'lisp-indent-hook))))
(cond ((or (eq method 'defun)
(and (null method)
(> (length function) 3)
(put 'save-excursion 'lisp-indent-function 0)
(put 'save-window-excursion 'lisp-indent-function 0)
(put 'save-selected-window 'lisp-indent-function 0)
+(put 'with-selected-window 'lisp-indent-function 1)
(put 'save-selected-frame 'lisp-indent-function 0)
(put 'with-selected-frame 'lisp-indent-function 1)
(put 'save-restriction 'lisp-indent-function 0)
;;; Code:
-;;; Warning-free compile
-(eval-when-compile
- (defvar language-environment-list)
- (defvar bookmark-alist)
- (defvar language-info-alist)
- (defvar current-language-environment)
- (defvar tutorial-supported-languages))
-
(defun menu-truncate-list (list n)
(if (<= (length list) n)
list
["Save %_As..." write-file]
["Save So%_me Buffers" save-some-buffers]
"-----"
- ["%_Print Buffer" generic-print-buffer
+ ["%_Print" generic-print-buffer
:active (or (valid-specifier-tag-p 'msprinter)
(and (not (eq system-type 'windows-nt))
(fboundp 'lpr-buffer)))
- :suffix (if put-buffer-names-in-file-menu (buffer-name) "")]
- ["Prett%_y-Print Buffer" ps-print-buffer-with-faces
+ :suffix (if put-buffer-names-in-file-menu (concat (buffer-name) "...")
+ "...")]
+ ["Prett%_y-Print" ps-print-buffer-with-faces
:active (fboundp 'ps-print-buffer-with-faces)
:suffix (if put-buffer-names-in-file-menu (buffer-name) "")]
"-----"
:active (selection-owner-p)]
"----"
["Select %_All" mark-whole-buffer]
- ["Select %_Page" mark-page]
- "----"
- ["%_Search..." make-search-dialog]
- ["%_1 Replace..." query-replace]
+ ["Select Pa%_ge" mark-page]
"----"
- ["%_2 Search (Regexp)..." isearch-forward-regexp]
- ["%_3 Search Backward (Regexp)..." isearch-backward-regexp]
- ["%_4 Replace (Regexp)..." query-replace-regexp]
-
+ ["%_Find..." make-search-dialog]
+ ["R%_eplace..." query-replace]
+ ["Replace (Rege%_xp)..." query-replace-regexp]
+ ["%_List Matching Lines..." list-matching-lines]
,@(when (featurep 'mule)
'("----"
("%_Multilingual (\"Mule\")"
:style toggle :selected mouse-track-rectangle-p]
)
("%_Sort"
- ["%_Lines" sort-lines :active (region-exists-p)]
- ["%_Paragraphs" sort-paragraphs :active (region-exists-p)]
- ["P%_ages" sort-pages :active (region-exists-p)]
- ["%_Columns" sort-columns :active (region-exists-p)]
+ ["%_Lines in Region" sort-lines :active (region-exists-p)]
+ ["%_Paragraphs in Region" sort-paragraphs :active (region-exists-p)]
+ ["P%_ages in Region" sort-pages :active (region-exists-p)]
+ ["%_Columns in Region" sort-columns :active (region-exists-p)]
["%_Regexp..." sort-regexp-fields :active (region-exists-p)]
)
- ("%_Center"
+ ("%_Change Case"
+ ["%_Upcase Region" upcase-region :active (region-exists-p)]
+ ["%_Downcase Region" downcase-region :active (region-exists-p)]
+ ["%_Capitalize Region" capitalize-region :active (region-exists-p)]
+ ["%_Title-Case Region" capitalize-region-as-title
+ :active (region-exists-p)]
+ )
+ ("Ce%_nter"
["%_Line" center-line]
["%_Paragraph" center-paragraph]
["%_Region" center-region :active (region-exists-p)]
)
("%_Tools"
+ ("%_Packages"
+ ("%_Add Download Site"
+ :filter (lambda (&rest junk)
+ (submenu-generate-accelerator-spec
+ (package-get-download-menu))))
+ ["%_Update Package Index" package-get-update-base]
+ ["%_List and Install" pui-list-packages]
+ ["U%_pdate Installed Packages" package-get-update-all]
+ ;; hack-o-matic, we can't force a load of package-base here
+ ;; since it triggers dialog box interactions which we can't
+ ;; deal with while using a menu
+ ("Using %_Custom"
+ :filter (lambda (&rest junk)
+ (if package-get-base
+ (submenu-generate-accelerator-spec
+ (cdr (custom-menu-create 'packages)))
+ '("Please load Package Index"))))
+
+ ["%_Help" (Info-goto-node "(xemacs)Packages")])
("%_Internet"
["Read Mail %_1 (VM)..." vm
:active (fboundp 'vm)]
["Se%_t..." customize-customized]
["%_Apropos..." customize-apropos]
["%_Browse..." customize-browse])
- ("Manage %_Packages"
- ("%_Add Download Site"
- :filter (lambda (&rest junk)
- (submenu-generate-accelerator-spec
- (package-get-download-menu))))
- ["%_Update Package Index" package-get-update-base]
- ["%_List and Install" pui-list-packages]
- ["U%_pdate Installed Packages" package-get-update-all]
- ;; hack-o-matic, we can't force a load of package-base here
- ;; since it triggers dialog box interactions which we can't
- ;; deal with while using a menu
- ("Using %_Custom"
- :filter (lambda (&rest junk)
- (if package-get-base
- (submenu-generate-accelerator-spec
- (cdr (custom-menu-create 'packages)))
- '(["Please load Package Index"
- (lamda (&rest junk) ()) nil]))))
-
- ["%_Help" (Info-goto-node "(xemacs)Packages")])
"---"
- ("%_Keyboard and Mouse"
- ["%_Abbrev Mode"
- (customize-set-variable 'abbrev-mode
- (not (default-value 'abbrev-mode)))
- :style toggle
- :selected (default-value 'abbrev-mode)]
- ["%_Delete Key Deletes Selection"
- (customize-set-variable 'pending-delete-mode (not pending-delete-mode))
- :style toggle
- :selected (and (boundp 'pending-delete-mode) pending-delete-mode)
- :active (boundp 'pending-delete-mode)]
+ ("%_Editing"
+ ["This Buffer %_Read Only" (toggle-read-only)
+ :style toggle :selected buffer-read-only]
["%_Yank/Kill Interact With Clipboard"
(if (eq interprogram-cut-function 'own-clipboard)
(progn
(setq overwrite-mode (if overwrite-mode nil 'overwrite-mode-textual))
(customize-set-variable 'overwrite-mode overwrite-mode))
:style toggle :selected overwrite-mode]
- ("`%_kill-line' Behavior..."
- ["Kill %_Whole Line"
- (customize-set-variable 'kill-whole-line 'always)
- :style radio :selected (eq kill-whole-line 'always)]
- ["Kill to %_End of Line"
- (customize-set-variable 'kill-whole-line nil)
- :style radio :selected (eq kill-whole-line nil)]
- ["Kill Whole Line at %_Beg, Otherwise to End"
- (customize-set-variable 'kill-whole-line t)
- :style radio :selected (eq kill-whole-line t)])
- ["Size for %_Block-Movement Commands..."
- (customize-set-variable 'block-movement-size
- (read-number "Block Movement Size: "
- t block-movement-size))]
- ["%_VI Emulation"
- (progn
- (toggle-viper-mode)
- (customize-set-variable 'viper-mode viper-mode))
- :style toggle :selected (and (boundp 'viper-mode) viper-mode)
- :active (fboundp 'toggle-viper-mode)]
+ ["%_Abbrev Mode"
+ (customize-set-variable 'abbrev-mode
+ (not (default-value 'abbrev-mode)))
+ :style toggle
+ :selected (default-value 'abbrev-mode)]
["Active Re%_gions"
(customize-set-variable 'zmacs-regions (not zmacs-regions))
:style toggle :selected zmacs-regions]
- "----"
- ["%_Set Key..." global-set-key]
- ["%_Unset Key..." global-unset-key]
"---"
["%_Case Sensitive Search"
(customize-set-variable 'case-fold-search
(setq case-fold-search (not case-fold-search)))
:style toggle :selected (not case-fold-search)]
- ["Case Matching %_Replace"
+ ["Case %_Matching Replace"
(customize-set-variable 'case-replace (not case-replace))
:style toggle :selected case-replace]
"---"
["Add Newline When Moving Past %_End"
(customize-set-variable 'next-line-add-newlines
(not next-line-add-newlines))
- :style toggle :selected next-line-add-newlines]
+ :style toggle :selected next-line-add-newlines])
+ ("%_Keyboard and Mouse"
+ ["%_Delete Key Deletes Selection"
+ (customize-set-variable 'pending-delete-mode (not pending-delete-mode))
+ :style toggle
+ :selected (and (boundp 'pending-delete-mode) pending-delete-mode)
+ :active (boundp 'pending-delete-mode)]
+ ("`%_kill-line' Behavior..."
+ ["Kill %_Whole Line"
+ (customize-set-variable 'kill-whole-line 'always)
+ :style radio :selected (eq kill-whole-line 'always)]
+ ["Kill to %_End of Line"
+ (customize-set-variable 'kill-whole-line nil)
+ :style radio :selected (eq kill-whole-line nil)]
+ ["Kill Whole Line at %_Beg, Otherwise to End"
+ (customize-set-variable 'kill-whole-line t)
+ :style radio :selected (eq kill-whole-line t)])
+ ["Size for %_Block-Movement Commands..."
+ (customize-set-variable 'block-movement-size
+ (read-number "Block Movement Size: "
+ t block-movement-size))]
+ ["%_VI Emulation"
+ (progn
+ (toggle-viper-mode)
+ (customize-set-variable 'viper-mode viper-mode))
+ :style toggle :selected (and (boundp 'viper-mode) viper-mode)
+ :active (fboundp 'toggle-viper-mode)]
+ "----"
+ ["%_Set Key..." global-set-key]
+ ["%_Unset Key..." global-unset-key]
"---"
- ["%_Mouse Paste at Text Cursor"
+ ["%_Mouse Paste at Text Cursor (not Clicked Location)"
(customize-set-variable 'mouse-yank-at-point (not mouse-yank-at-point))
:style toggle :selected mouse-yank-at-point]
- ["A%_void Text..."
- (customize-set-variable 'mouse-avoidance-mode
- (if mouse-avoidance-mode nil 'banish))
- :style toggle
- :selected (and (boundp 'mouse-avoidance-mode) mouse-avoidance-mode)
- :active (and (boundp 'mouse-avoidance-mode)
- (device-on-window-system-p))]
- ["%_Strokes Mode"
- (customize-set-variable 'strokes-mode (not strokes-mode))
- :style toggle
- :selected (and (boundp 'strokes-mode) strokes-mode)
- :active (and (boundp 'strokes-mode)
- (device-on-window-system-p))]
- )
- ("%_General"
- ["This Buffer %_Read Only" (toggle-read-only)
- :style toggle :selected buffer-read-only]
+ "---"
["%_Teach Extended Commands"
(customize-set-variable 'teach-extended-commands-p
(not teach-extended-commands-p))
:style toggle :selected teach-extended-commands-p]
- ["Debug on %_Error"
- (customize-set-variable 'debug-on-error (not debug-on-error))
- :style toggle :selected debug-on-error]
- ["Debug on %_Quit"
- (customize-set-variable 'debug-on-quit (not debug-on-quit))
- :style toggle :selected debug-on-quit]
- ["Debug on %_Signal"
- (customize-set-variable 'debug-on-signal (not debug-on-signal))
- :style toggle :selected debug-on-signal]
)
-
("%_Printing"
["Set Printer %_Name for Generic Print Support..."
(customize-set-variable
(eq browse-url-browser-function 'browse-url-kfm))
:active (and (boundp 'browse-url-browser-function)
(fboundp 'browse-url-kfm))]
- ))
-
-
+ ))
+ ("%_Troubleshooting"
+ ["%_Debug on Error"
+ (customize-set-variable 'debug-on-error (not debug-on-error))
+ :style toggle :selected debug-on-error]
+ ["Debug on %_Quit"
+ (customize-set-variable 'debug-on-quit (not debug-on-quit))
+ :style toggle :selected debug-on-quit]
+ ["Debug on S%_ignal"
+ (customize-set-variable 'debug-on-signal (not debug-on-signal))
+ :style toggle :selected debug-on-signal]
+ ["%_Stack Trace on Error"
+ (customize-set-variable 'stack-trace-on-error
+ (not stack-trace-on-error))
+ :style toggle :selected stack-trace-on-error]
+ ["Stack Trace on Si%_gnal"
+ (customize-set-variable 'stack-trace-on-signal
+ (not stack-trace-on-signal))
+ :style toggle :selected stack-trace-on-signal]
+ )
"-----"
- ("Display"
+ ("%_Display"
,@(if (featurep 'scrollbar)
'(["%_Scrollbars"
(customize-set-variable 'scrollbars-visible-p
(not scrollbars-visible-p))
:style toggle
:selected scrollbars-visible-p]))
- ;; I don't think this is of any interest. - dverna apr. 98
- ;; #### I beg to differ! Many FSFmacs converts hate the 3D
- ;; modeline, and it was perfectly fine to be able to turn them
- ;; off through the Options menu. I would have uncommented this
- ;; source, but the code for saving options would not save the
- ;; modeline 3D-ness. Grrr. --hniksic
- ;; ["%_3D Modeline"
- ;; (progn
- ;; (if (zerop (specifier-instance modeline-shadow-thickness))
- ;; (set-specifier modeline-shadow-thickness 2)
- ;; (set-specifier modeline-shadow-thickness 0))
- ;; (redraw-modeline t))
- ;; :style toggle
- ;; :selected (let ((thickness
- ;; (specifier-instance modeline-shadow-thickness)))
- ;; (and (integerp thickness)
- ;; (> thickness 0)))]
- ["%_Truncate Lines"
+ ["%_3D Modeline"
+ (customize-set-variable 'modeline-3d-p
+ (not modeline-3d-p))
+ :style toggle
+ :selected modeline-3d-p]
+ ["%_Wrap Long Lines"
(progn;; becomes buffer-local
(setq truncate-lines (not truncate-lines))
(customize-set-variable 'truncate-lines truncate-lines))
:style toggle
- :selected truncate-lines]
+ :selected (not truncate-lines)]
+ ,@(if (featurep 'toolbar)
+ '("---"
+ ["%_Toolbars Visible"
+ (customize-set-variable 'toolbar-visible-p
+ (not toolbar-visible-p))
+ :style toggle
+ :selected toolbar-visible-p]
+ ["Toolbars Ca%_ptioned"
+ (customize-set-variable 'toolbar-captioned-p
+ (not toolbar-captioned-p))
+ :style toggle
+ :active toolbar-visible-p
+ :selected toolbar-captioned-p]
+ ("Default Toolba%_r Location"
+ ["%_Top"
+ (customize-set-variable 'default-toolbar-position 'top)
+ :style radio
+ :active toolbar-visible-p
+ :selected (eq default-toolbar-position 'top)]
+ ["%_Bottom"
+ (customize-set-variable 'default-toolbar-position 'bottom)
+ :style radio
+ :active toolbar-visible-p
+ :selected (eq default-toolbar-position 'bottom)]
+ ["%_Left"
+ (customize-set-variable 'default-toolbar-position 'left)
+ :style radio
+ :active toolbar-visible-p
+ :selected (eq default-toolbar-position 'left)]
+ ["%_Right"
+ (customize-set-variable 'default-toolbar-position 'right)
+ :style radio
+ :active toolbar-visible-p
+ :selected (eq default-toolbar-position 'right)]
+ )
+ ))
+ ,@(if (featurep 'gutter)
+ '("---"
+ ["B%_uffers Tab Visible"
+ (customize-set-variable 'gutter-buffers-tab-visible-p
+ (not gutter-buffers-tab-visible-p))
+ :style toggle
+ :selected gutter-buffers-tab-visible-p]
+ ("Default %_Gutter Location"
+ ["%_Top"
+ (customize-set-variable 'default-gutter-position 'top)
+ :style radio
+ :selected (eq default-gutter-position 'top)]
+ ["%_Bottom"
+ (customize-set-variable 'default-gutter-position 'bottom)
+ :style radio
+ :selected (eq default-gutter-position 'bottom)]
+ ["%_Left"
+ (customize-set-variable 'default-gutter-position 'left)
+ :style radio
+ :selected (eq default-gutter-position 'left)]
+ ["%_Right"
+ (customize-set-variable 'default-gutter-position 'right)
+ :style radio
+ :selected (eq default-gutter-position 'right)]
+ )
+ ))
+ "-----"
["%_Blinking Cursor"
(customize-set-variable 'blink-cursor-mode (not blink-cursor-mode))
:style toggle
:selected (and (boundp 'blink-cursor-mode) blink-cursor-mode)
:active (boundp 'blink-cursor-mode)]
- "-----"
["Bl%_ock Cursor"
(progn
(customize-set-variable 'bar-cursor nil)
(force-cursor-redisplay))
:style radio
:selected (and bar-cursor (not (eq bar-cursor t)))]
+ "----"
+ ("Pa%_ren Highlighting"
+ ["%_None"
+ (customize-set-variable 'paren-mode nil)
+ :style radio
+ :selected (and (boundp 'paren-mode) (not paren-mode))
+ :active (boundp 'paren-mode)]
+ ["%_Blinking Paren"
+ (customize-set-variable 'paren-mode 'blink-paren)
+ :style radio
+ :selected (and (boundp 'paren-mode) (eq paren-mode 'blink-paren))
+ :active (boundp 'paren-mode)]
+ ["%_Steady Paren"
+ (customize-set-variable 'paren-mode 'paren)
+ :style radio
+ :selected (and (boundp 'paren-mode) (eq paren-mode 'paren))
+ :active (boundp 'paren-mode)]
+ ["%_Expression"
+ (customize-set-variable 'paren-mode 'sexp)
+ :style radio
+ :selected (and (boundp 'paren-mode) (eq paren-mode 'sexp))
+ :active (boundp 'paren-mode)]
+ ;; ["Nes%_ted Shading"
+ ;; (customize-set-variable 'paren-mode 'nested)
+ ;; :style radio
+ ;; :selected (and (boundp 'paren-mode) (eq paren-mode 'nested))
+ ;; :active (boundp 'paren-mode)]
+ )
"------"
["%_Line Numbers"
(progn
:style radio
:selected (null get-frame-for-buffer-default-instance-limit)]
["Other Frame (%_2 Frames Max)"
- (customize-set-variable 'get-frame-for-buffer-default-instance-limit 2)
+ (customize-set-variable 'get-frame-for-buffer-default-instance-limit
+ 2)
:style radio
:selected (eq 2 get-frame-for-buffer-default-instance-limit)]
["Other Frame (%_3 Frames Max)"
- (customize-set-variable 'get-frame-for-buffer-default-instance-limit 3)
+ (customize-set-variable 'get-frame-for-buffer-default-instance-limit
+ 3)
:style radio
:selected (eq 3 get-frame-for-buffer-default-instance-limit)]
["Other Frame (%_4 Frames Max)"
- (customize-set-variable 'get-frame-for-buffer-default-instance-limit 4)
+ (customize-set-variable 'get-frame-for-buffer-default-instance-limit
+ 4)
:style radio
:selected (eq 4 get-frame-for-buffer-default-instance-limit)]
["Other Frame (%_5 Frames Max)"
- (customize-set-variable 'get-frame-for-buffer-default-instance-limit 5)
+ (customize-set-variable 'get-frame-for-buffer-default-instance-limit
+ 5)
:style radio
:selected (eq 5 get-frame-for-buffer-default-instance-limit)]
["Always Create %_New Frame"
- (customize-set-variable 'get-frame-for-buffer-default-instance-limit 0)
+ (customize-set-variable 'get-frame-for-buffer-default-instance-limit
+ 0)
:style radio
:selected (eq 0 get-frame-for-buffer-default-instance-limit)]
"-----"
:selected (null temp-buffer-show-function)]
"-----"
["%_Make Current Frame Gnuserv Target"
- (customize-set-variable 'gnuserv-frame (if (eq gnuserv-frame t) nil t))
+ (customize-set-variable 'gnuserv-frame (if (eq gnuserv-frame t) nil
+ t))
:style toggle
:selected (and (boundp 'gnuserv-frame) (eq gnuserv-frame t))
:active (boundp 'gnuserv-frame)]
:selected (and (boundp 'font-menu-ignore-scaled-fonts)
font-menu-ignore-scaled-fonts)]
)
- ,@(if (featurep 'toolbar)
- '(("%_Toolbars"
- ["%_Visible"
- (customize-set-variable 'toolbar-visible-p
- (not toolbar-visible-p))
- :style toggle
- :selected toolbar-visible-p]
- ["%_Captioned"
- (customize-set-variable 'toolbar-captioned-p
- (not toolbar-captioned-p))
- :style toggle
- :selected toolbar-captioned-p]
- ("%_Default Location"
- ["%_Top"
- (customize-set-variable 'default-toolbar-position 'top)
- :style radio
- :selected (eq default-toolbar-position 'top)]
- ["%_Bottom"
- (customize-set-variable 'default-toolbar-position 'bottom)
- :style radio
- :selected (eq default-toolbar-position 'bottom)]
- ["%_Left"
- (customize-set-variable 'default-toolbar-position 'left)
- :style radio
- :selected (eq default-toolbar-position 'left)]
- ["%_Right"
- (customize-set-variable 'default-toolbar-position 'right)
- :style radio
- :selected (eq default-toolbar-position 'right)]
- )
- )))
- ,@(if (featurep 'gutter)
- '(("G%_utters"
- ["Buffers Tab %_Visible"
- (customize-set-variable 'gutter-buffers-tab-visible-p
- (not gutter-buffers-tab-visible-p))
- :style toggle
- :selected gutter-buffers-tab-visible-p]
- ("%_Default Location"
- ["%_Top"
- (customize-set-variable 'default-gutter-position 'top)
- :style radio
- :selected (eq default-gutter-position 'top)]
- ["%_Bottom"
- (customize-set-variable 'default-gutter-position 'bottom)
- :style radio
- :selected (eq default-gutter-position 'bottom)]
- ["%_Left"
- (customize-set-variable 'default-gutter-position 'left)
- :style radio
- :selected (eq default-gutter-position 'left)]
- ["%_Right"
- (customize-set-variable 'default-gutter-position 'right)
- :style radio
- :selected (eq default-gutter-position 'right)]
- )
- )))
- "-----"
("S%_yntax Highlighting"
["%_In This Buffer"
(progn;; becomes buffer local
:selected (and (boundp 'font-lock-auto-fontify) font-lock-auto-fontify)
:active (fboundp 'font-lock-mode)]
"-----"
+ ["Force %_Rehighlight in this Buffer"
+ (customize-set-variable 'font-lock-auto-fontify
+ (not font-lock-auto-fontify))
+ :style toggle
+ :selected (and (boundp 'font-lock-auto-fontify) font-lock-auto-fontify)
+ :active (fboundp 'font-lock-mode)]
+ "-----"
["%_Fonts"
(progn
(require 'font-lock)
:selected (and (boundp 'font-lock-use-colors) font-lock-use-colors)
:active (boundp 'font-lock-mode)]
"-----"
- ["%_Least"
+ ["%_1 Least"
(progn
(require 'font-lock)
(if (or (and (not (integerp font-lock-maximum-decoration))
(font-lock-recompute-variables)))
:style radio
:active (fboundp 'font-lock-mode)
- :selected (and (boundp 'font-lock-maximium-decoration)
+ :selected (and (boundp 'font-lock-maximum-decoration)
(or (and (not (integerp font-lock-maximum-decoration))
(not (eq t font-lock-maximum-decoration)))
(and (integerp font-lock-maximum-decoration)
(<= font-lock-maximum-decoration 0))))]
- ["M%_ore"
+ ["%_2 More"
(progn
(require 'font-lock)
(if (and (integerp font-lock-maximum-decoration)
(font-lock-recompute-variables)))
:style radio
:active (fboundp 'font-lock-mode)
- :selected (and (boundp 'font-lock-maximium-decoration)
+ :selected (and (boundp 'font-lock-maximum-decoration)
(integerp font-lock-maximum-decoration)
(= 1 font-lock-maximum-decoration))]
- ["%_Even More"
+ ["%_3 Even More"
(progn
(require 'font-lock)
(if (and (integerp font-lock-maximum-decoration)
:selected (and (boundp 'font-lock-maximum-decoration)
(integerp font-lock-maximum-decoration)
(= 2 font-lock-maximum-decoration))]
- ["%_Most"
+ ["%_4 Most"
(progn
(require 'font-lock)
(if (or (eq font-lock-maximum-decoration t)
(and (integerp font-lock-maximum-decoration)
(>= font-lock-maximum-decoration 3))))]
"-----"
- ["La%_zy"
+ ["Lazy %_Lock"
+ (progn;; becomes buffer local
+ (lazy-lock-mode)
+ (customize-set-variable 'lazy-lock-mode lazy-lock-mode)
+ ;; this shouldn't be necessary so there has to
+ ;; be a redisplay bug lurking somewhere (or
+ ;; possibly another event handler bug)
+ (redraw-modeline))
+ :active (and (boundp 'font-lock-mode) (boundp 'lazy-lock-mode)
+ font-lock-mode)
+ :style toggle
+ :selected (and (boundp 'lazy-lock-mode) lazy-lock-mode)]
+ ["Lazy %_Shot"
(progn;; becomes buffer local
(lazy-shot-mode)
(customize-set-variable 'lazy-shot-mode lazy-shot-mode)
:style toggle
:selected (and (boundp 'fast-lock-mode) fast-lock-mode)]
)
- ("Pa%_ren Highlighting"
- ["%_None"
- (customize-set-variable 'paren-mode nil)
- :style radio
- :selected (and (boundp 'paren-mode) (not paren-mode))
- :active (boundp 'paren-mode)]
- ["%_Blinking Paren"
- (customize-set-variable 'paren-mode 'blink-paren)
- :style radio
- :selected (and (boundp 'paren-mode) (eq paren-mode 'blink-paren))
- :active (boundp 'paren-mode)]
- ["%_Steady Paren"
- (customize-set-variable 'paren-mode 'paren)
- :style radio
- :selected (and (boundp 'paren-mode) (eq paren-mode 'paren))
- :active (boundp 'paren-mode)]
- ["%_Expression"
- (customize-set-variable 'paren-mode 'sexp)
- :style radio
- :selected (and (boundp 'paren-mode) (eq paren-mode 'sexp))
- :active (boundp 'paren-mode)]
- ;; ["Nes%_ted Shading"
- ;; (customize-set-variable 'paren-mode 'nested)
- ;; :style radio
- ;; :selected (and (boundp 'paren-mode) (eq paren-mode 'nested))
- ;; :active (boundp 'paren-mode)]
- )
- "-----"
+ ("%_Font" :filter font-menu-family-constructor)
+ ("Font Si%_ze" :filter font-menu-size-constructor)
+ ;; ("Font Weig%_ht" :filter font-menu-weight-constructor)
["Edit Fa%_ces..." (customize-face nil)]
- ("Fo%_nt" :filter font-menu-family-constructor)
- ("Si%_ze" :filter font-menu-size-constructor)
- ;; ("Weig%_ht" :filter font-menu-weight-constructor)
"-----"
- ["%_Edit Init (.emacs) File"
+ ["Edit I%_nit File"
;; #### there should be something that holds the name that the init
;; file should be created as, when it's not present.
- (progn (find-file (or user-init-file "~/.emacs"))
+ (progn (find-file (or user-init-file "~/.xemacs/init.el"))
(or (eq major-mode 'emacs-lisp-mode)
(emacs-lisp-mode)))]
- ["%_Save Options to .emacs File" customize-save-customized]
+ ["%_Save Options to Init File" customize-save-customized]
)
("%_Buffers"
("XEmacs %_FAQ"
["%_FAQ (local)" xemacs-local-faq]
["FAQ via %_WWW" xemacs-www-faq
- :active (boundp 'browse-url-browser-function)]
+ :active (fboundp 'browse-url)]
["%_Home Page" xemacs-www-page
- :active (boundp 'browse-url-browser-function)])
+ :active (fboundp 'browse-url)])
("%_Tutorials"
:filter tutorials-menu-filter)
("%_Samples"
;;; The Bookmarks menu
(defun bookmark-menu-filter (&rest ignore)
+ (declare (special bookmark-alist))
(let ((definedp (and (boundp 'bookmark-alist)
bookmark-alist
t)))
`(,(if definedp
'("%_Jump to Bookmark"
:filter (lambda (&rest junk)
- (mapcar #'(lambda (bmk)
- `[,bmk (bookmark-jump ',bmk)])
- (bookmark-all-names))))
+ (submenu-generate-accelerator-spec
+ (mapcar #'(lambda (bmk)
+ `[,bmk (bookmark-jump ',bmk)])
+ (bookmark-all-names)))))
["%_Jump to Bookmark" nil nil])
["Set %_Bookmark" bookmark-set
:active (fboundp 'bookmark-set)]
,(if definedp
'("%_Delete Bookmark"
:filter (lambda (&rest junk)
- (mapcar #'(lambda (bmk)
- `[,bmk (bookmark-delete ',bmk)])
- (bookmark-all-names))))
+ (submenu-generate-accelerator-spec
+ (mapcar #'(lambda (bmk)
+ `[,bmk (bookmark-delete ',bmk)])
+ (bookmark-all-names)))))
["%_Delete Bookmark" nil nil])
["%_Edit Bookmark List" bookmark-bmenu-list ,definedp]
"---"
"Customization of `Buffers' menu."
:group 'menu)
-(defvar buffers-menu-omit-chars-list '(?b ?p ?l))
+(defvar buffers-menu-omit-chars-list '(?b ?p ?l ?d))
(defcustom buffers-menu-max-size 25
"*Maximum number of entries which may appear on the \"Buffers\" menu.
(defun language-environment-menu-filter (menu)
"This is the menu filter for the \"Language Environment\" submenu."
+ (declare (special language-environment-list))
(let ((n 0))
(mapcar (lambda (env-sym)
(setq n (1+ n))
;;; The Help menu
(defun tutorials-menu-filter (menu-items)
- (append
+ (declare (special language-info-alist
+ current-language-environment
+ tutorial-supported-languages))
+ (append
+ (if (featurep 'mule)
+ (if (assq 'tutorial
+ (assoc current-language-environment language-info-alist))
+ `([,(concat "%_Default (" current-language-environment ")")
+ help-with-tutorial]))
+ '(["%_English" help-with-tutorial]))
+ (submenu-generate-accelerator-spec
(if (featurep 'mule)
- (if (assq 'tutorial
- (assoc current-language-environment language-info-alist))
- `([,(concat "%_Default (" current-language-environment ")")
- help-with-tutorial]))
- '(["%_English" help-with-tutorial]))
- (submenu-generate-accelerator-spec
- (if (featurep 'mule)
- ;; Mule tutorials.
- (mapcan #'(lambda (lang)
- (let ((tut (assq 'tutorial lang)))
- (and tut
- (not (string= (car lang) "ASCII"))
- ;; skip current language, since we already
- ;; included it first
- (not (string= (car lang)
- current-language-environment))
- `([,(car lang)
- (help-with-tutorial nil ,(cdr tut))]))))
- language-info-alist)
- ;; Non mule tutorials.
- (mapcar #'(lambda (lang)
- `[,(car lang)
- (help-with-tutorial ,(format "TUTORIAL.%s"
- (cadr lang)))])
- tutorial-supported-languages)))))
+ ;; Mule tutorials.
+ (mapcan #'(lambda (lang)
+ (let ((tut (assq 'tutorial lang)))
+ (and tut
+ (not (string= (car lang) "ASCII"))
+ ;; skip current language, since we already
+ ;; included it first
+ (not (string= (car lang)
+ current-language-environment))
+ `([,(car lang)
+ (help-with-tutorial nil ,(cdr tut))]))))
+ language-info-alist)
+ ;; Non mule tutorials.
+ (mapcar #'(lambda (lang)
+ `[,(car lang)
+ (help-with-tutorial ,(format "TUTORIAL.%s"
+ (cadr lang)))])
+ tutorial-supported-languages)))))
-\f
(set-menubar default-menubar)
\f
["U%_nsplit Window" delete-other-windows]
))
-(defvar global-popup-menu nil
- "The global popup menu. This is present in all modes.
-See the function `popup-menu' for a description of menu syntax.")
-
-(defvar mode-popup-menu nil
- "The mode-specific popup menu. Automatically buffer local.
-This is appended to the default items in `global-popup-menu'.
-See the function `popup-menu' for a description of menu syntax.")
-(make-variable-buffer-local 'mode-popup-menu)
-
;; In an effort to avoid massive menu clutter, this mostly worthless menu is
;; superseded by any local popup menu...
(setq-default mode-popup-menu default-popup-menu)
-(defvar activate-popup-menu-hook nil
- "Function or functions run before a mode-specific popup menu is made visible.
-These functions are called with no arguments, and should interrogate and
-modify the value of `global-popup-menu' or `mode-popup-menu' as desired.
-Note: this hook is only run if you use `popup-mode-menu' for activating the
-global and mode-specific commands; if you have your own binding for button3,
-this hook won't be run.")
-
-(defun popup-mode-menu ()
- "Pop up a menu of global and mode-specific commands.
-The menu is computed by combining `global-popup-menu' and `mode-popup-menu'."
- (interactive "@_")
- (run-hooks 'activate-popup-menu-hook)
- (popup-menu
- (cond ((and global-popup-menu mode-popup-menu)
- ;; Merge global-popup-menu and mode-popup-menu
- (check-menu-syntax mode-popup-menu)
- (let* ((title (car mode-popup-menu))
- (items (cdr mode-popup-menu))
- mode-filters)
- ;; Strip keywords from local menu for attaching them at the top
- (while (and items
- (keywordp (car items)))
- ;; Push both keyword and its argument.
- (push (pop items) mode-filters)
- (push (pop items) mode-filters))
- (setq mode-filters (nreverse mode-filters))
- ;; If mode-filters contains a keyword already present in
- ;; `global-popup-menu', you will probably lose.
- (append (list (car global-popup-menu))
- mode-filters
- (cdr global-popup-menu)
- '("---" "---")
- (if popup-menu-titles (list title))
- (if popup-menu-titles '("---" "---"))
- items)))
- (t
- (or mode-popup-menu
- global-popup-menu
- (error "No menu defined in this buffer"))))))
-
-(defun popup-buffer-menu (event)
- "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked."
- (interactive "e")
- (let ((window (and (event-over-text-area-p event) (event-window event)))
- (bmenu nil))
- (or window
- (error "Pointer must be in a normal window"))
- (select-window window)
- (if current-menubar
- (setq bmenu (assoc "%_Buffers" current-menubar)))
- (if (null bmenu)
- (setq bmenu (assoc "%_Buffers" default-menubar)))
- (if (null bmenu)
- (error "Can't find the Buffers menu"))
- (popup-menu bmenu)))
-
-(defun popup-menubar-menu (event)
- "Pop up a copy of menu that also appears in the menubar."
- (interactive "e")
- (let ((window (and (event-over-text-area-p event) (event-window event)))
- popup-menubar)
- (or window
- (error "Pointer must be in a normal window"))
- (select-window window)
- (and current-menubar (run-hooks 'activate-menubar-hook))
- ;; #### Instead of having to copy this just to safely get rid of
- ;; any nil what we should really do is fix up the internal menubar
- ;; code to just ignore nil if generating a popup menu
- (setq popup-menubar (delete nil (copy-sequence (or current-menubar
- default-menubar))))
- (popup-menu (cons "%_Menubar Menu" popup-menubar))
- ))
-
-(global-set-key 'button3 'popup-mode-menu)
-;; shift button3 and shift button2 are reserved for Hyperbole
-(global-set-key '(meta control button3) 'popup-buffer-menu)
-;; The following command is way too dangerous with Custom.
-;; (global-set-key '(meta shift button3) 'popup-menubar-menu)
-
-;; Here's a test of the cool new menu features (from Stig).
-
-;;(setq mode-popup-menu
-;; '("Test Popup Menu"
-;; :filter cdr
-;; ["this item won't appear because of the menu filter" ding t]
-;; "--:singleLine"
-;; "singleLine"
-;; "--:doubleLine"
-;; "doubleLine"
-;; "--:singleDashedLine"
-;; "singleDashedLine"
-;; "--:doubleDashedLine"
-;; "doubleDashedLine"
-;; "--:noLine"
-;; "noLine"
-;; "--:shadowEtchedIn"
-;; "shadowEtchedIn"
-;; "--:shadowEtchedOut"
-;; "shadowEtchedOut"
-;; "--:shadowDoubleEtchedIn"
-;; "shadowDoubleEtchedIn"
-;; "--:shadowDoubleEtchedOut"
-;; "shadowDoubleEtchedOut"
-;; "--:shadowEtchedInDash"
-;; "shadowEtchedInDash"
-;; "--:shadowEtchedOutDash"
-;; "shadowEtchedOutDash"
-;; "--:shadowDoubleEtchedInDash"
-;; "shadowDoubleEtchedInDash"
-;; "--:shadowDoubleEtchedOutDash"
-;; "shadowDoubleEtchedOutDash"
-;; ))
+\f
+;; misc
(defun xemacs-splash-buffer ()
"Redisplay XEmacs splash screen in a buffer."
(enable-menu-item-1 path t nil))
\f
+
+;;;;;;; popup menus
+
+(defvar global-popup-menu nil
+ "The global popup menu. This is present in all modes.
+See the function `popup-menu' for a description of menu syntax.")
+
+(defvar mode-popup-menu nil
+ "The mode-specific popup menu. Automatically buffer local.
+This is appended to the default items in `global-popup-menu'.
+See the function `popup-menu' for a description of menu syntax.")
+(make-variable-buffer-local 'mode-popup-menu)
+
+(defvar activate-popup-menu-hook nil
+ "Function or functions run before a mode-specific popup menu is made visible.
+These functions are called with no arguments, and should interrogate and
+modify the value of `global-popup-menu' or `mode-popup-menu' as desired.
+Note: this hook is only run if you use `popup-mode-menu' for activating the
+global and mode-specific commands; if you have your own binding for button3,
+this hook won't be run.")
+
+(defvar last-popup-menu-event nil
+ "The mouse event that invoked the last popup menu.
+NOTE: This is EXPERIMENTAL and may change at any time.")
+
+(defun popup-mode-menu (&optional event)
+ "Pop up a menu of global and mode-specific commands.
+The menu is computed by combining `global-popup-menu' and `mode-popup-menu'
+with any items derived from the `context-menu' property of the extent where the
+button was clicked."
+ (interactive "_e")
+ (setq last-popup-menu-event
+ (or (and event (button-event-p event) event)
+ (let* ((mouse-pos (mouse-position))
+ (win (car mouse-pos))
+ (x (cadr mouse-pos))
+ (y (cddr mouse-pos))
+ (edges (window-pixel-edges win))
+ (winx (first edges))
+ (winy (second edges))
+ (x (+ x winx))
+ (y (+ y winy)))
+ (make-event 'button-press
+ `(button 3 x ,x y ,y channel ,(window-frame win)
+ timestamp ,(current-event-timestamp
+ (cdfw-console win)))))))
+ (run-hooks 'activate-popup-menu-hook)
+ (let* ((context-window (and event (event-window event)))
+ (context-point (and event (event-point event)))
+ (context-extents (and context-window
+ context-point
+ (extents-at context-point
+ (window-buffer context-window)
+ 'context-menu)))
+ (context-menu-items
+ (apply 'append (mapcar #'(lambda (extent)
+ (extent-property extent 'context-menu))
+ context-extents))))
+ (popup-menu
+ (cond ((and global-popup-menu mode-popup-menu)
+ ;; Merge global-popup-menu and mode-popup-menu
+ (check-menu-syntax mode-popup-menu)
+ (let* ((title (car mode-popup-menu))
+ (items (cdr mode-popup-menu))
+ mode-filters)
+ ;; Strip keywords from local menu for attaching them at the top
+ (while (and items
+ (keywordp (car items)))
+ ;; Push both keyword and its argument.
+ (push (pop items) mode-filters)
+ (push (pop items) mode-filters))
+ (setq mode-filters (nreverse mode-filters))
+ ;; If mode-filters contains a keyword already present in
+ ;; `global-popup-menu', you will probably lose.
+ (append (list (car global-popup-menu))
+ mode-filters
+ (cdr global-popup-menu)
+ '("---" "---")
+ (if popup-menu-titles (list title))
+ (if popup-menu-titles '("---" "---"))
+ items
+ context-menu-items)))
+ (t
+ (append
+ (or mode-popup-menu
+ global-popup-menu
+ (error "No menu defined in this buffer"))
+ context-menu-items))))
+
+ (while (popup-up-p)
+ (dispatch-event (next-event)))
+
+ ))
+
+(defun popup-buffer-menu (event)
+ "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked."
+ (interactive "e")
+ (let ((window (and (event-over-text-area-p event) (event-window event)))
+ (bmenu nil))
+ (or window
+ (error "Pointer must be in a normal window"))
+ (select-window window)
+ (if current-menubar
+ (setq bmenu (assoc "%_Buffers" current-menubar)))
+ (if (null bmenu)
+ (setq bmenu (assoc "%_Buffers" default-menubar)))
+ (if (null bmenu)
+ (error "Can't find the Buffers menu"))
+ (popup-menu bmenu)))
+
+(defun popup-menubar-menu (event)
+ "Pop up a copy of menu that also appears in the menubar."
+ (interactive "e")
+ (let ((window (and (event-over-text-area-p event) (event-window event)))
+ popup-menubar)
+ (or window
+ (error "Pointer must be in a normal window"))
+ (select-window window)
+ (and current-menubar (run-hooks 'activate-menubar-hook))
+ ;; #### Instead of having to copy this just to safely get rid of
+ ;; any nil what we should really do is fix up the internal menubar
+ ;; code to just ignore nil if generating a popup menu
+ (setq popup-menubar (delete nil (copy-sequence (or current-menubar
+ default-menubar))))
+ (popup-menu (cons "%_Menubar Menu" popup-menubar))
+ ))
+
+(defun menu-call-at-event (form &optional event default-behavior-fallback)
+ "Call FORM while temporarily setting point to the position in EVENT.
+NOTE: This is EXPERIMENTAL and may change at any time.
+
+FORM is called the way forms in menu specs are: i.e. if a symbol, it's called
+with `call-interactively', otherwise with `eval'. EVENT defaults to
+`last-popup-menu-event', making this function especially useful in popup
+menus. The buffer and point are set temporarily within a `save-excursion'.
+If EVENT is not a mouse event, or was not over a buffer, nothing
+happens unless DEFAULT-BEHAVIOR-FALLBACK is non-nil, in which case the
+FORM is called normally."
+ (or event (setq event last-popup-menu-event))
+ (let ((buf (event-buffer event))
+ (p (event-closest-point event)))
+ (cond ((and buf p (> p 0))
+ (save-excursion
+ (set-buffer buf)
+ (goto-char p)
+ (if (symbolp form)
+ (call-interactively form)
+ (eval form))))
+ (default-behavior-fallback
+ (if (symbolp form)
+ (call-interactively form)
+ (eval form))))))
+
+(global-set-key 'button3 'popup-mode-menu)
+;; shift button3 and shift button2 are reserved for Hyperbole
+(global-set-key '(meta control button3) 'popup-buffer-menu)
+;; The following command is way too dangerous with Custom.
+;; (global-set-key '(meta shift button3) 'popup-menubar-menu)
+
+;; Here's a test of the cool new menu features (from Stig).
+
+;;(setq mode-popup-menu
+;; '("Test Popup Menu"
+;; :filter cdr
+;; ["this item won't appear because of the menu filter" ding t]
+;; "--:singleLine"
+;; "singleLine"
+;; "--:doubleLine"
+;; "doubleLine"
+;; "--:singleDashedLine"
+;; "singleDashedLine"
+;; "--:doubleDashedLine"
+;; "doubleDashedLine"
+;; "--:noLine"
+;; "noLine"
+;; "--:shadowEtchedIn"
+;; "shadowEtchedIn"
+;; "--:shadowEtchedOut"
+;; "shadowEtchedOut"
+;; "--:shadowDoubleEtchedIn"
+;; "shadowDoubleEtchedIn"
+;; "--:shadowDoubleEtchedOut"
+;; "shadowDoubleEtchedOut"
+;; "--:shadowEtchedInDash"
+;; "shadowEtchedInDash"
+;; "--:shadowEtchedOutDash"
+;; "shadowEtchedOutDash"
+;; "--:shadowDoubleEtchedInDash"
+;; "shadowDoubleEtchedInDash"
+;; "--:shadowDoubleEtchedOutDash"
+;; "shadowDoubleEtchedOutDash"
+;; ))
+
(defun get-popup-menu-response (menu-desc &optional event)
"Pop up the given menu and wait for a response.
This blocks until the response is received, and returns the misc-user
(defcustom minibuffer-history-uniquify t
"*Non-nil means when adding an item to a minibuffer history, remove
-previous occurances of the same item from the history list first,
+previous occurrences of the same item from the history list first,
rather than just consing the new element onto the front of the list."
:type 'boolean
:group 'minibuffer)
current-minibuffer-point (point)))
(let ((narg (- minibuffer-history-position n))
(minimum (if minibuffer-default -1 0)))
+ ;; a weird special case here; when in repeat-complex-command, we're
+ ;; trying to edit the top command, and minibuffer-history-position
+ ;; points to 1, the next-to-top command. in this case, the top
+ ;; command in the history is suppressed in favor of the one being
+ ;; edited, and there is no more command below it, except maybe the
+ ;; default.
+ (if (and (zerop narg) (eq minibuffer-history-position
+ initial-minibuffer-history-position))
+ (setq minimum (1+ minimum)))
(cond ((< narg minimum)
(error (if minibuffer-default
"No following item in %s"
(progn
(insert current-minibuffer-contents)
(goto-char current-minibuffer-point))
- (let ((elt (if (>= narg 0)
+ (let ((elt (if (> narg 0)
(nth (1- minibuffer-history-position)
(symbol-value minibuffer-history-variable))
minibuffer-default)))
must-match initial-contents
completer)
(if (should-use-dialog-box-p)
- ;; this calls read-file-name-2
- (mouse-read-file-name-1 history prompt dir default must-match
- initial-contents completer)
+ (condition-case nil
+ (let ((file
+ (apply #'make-dialog-box
+ 'file `(:title ,(capitalize-string-as-title
+ ;; Kludge: Delete ": " off the end.
+ (replace-in-string prompt ": $" ""))
+ ,@(and dir (list :initial-directory
+ dir))
+ :file-must-exist ,must-match
+ ,@(and initial-contents
+ (list :initial-filename
+ initial-contents))))))
+ ;; hack -- until we implement reading a directory properly,
+ ;; allow a file as indicating the directory it's in
+ (if (and (eq completer 'read-directory-name-internal)
+ (not (file-directory-p file)))
+ (file-name-directory file)
+ file))
+ (unimplemented
+ ;; this calls read-file-name-2
+ (mouse-read-file-name-1 history prompt dir default must-match
+ initial-contents completer)
+ ))
(add-one-shot-hook
'minibuffer-setup-hook
(lambda ()
;; a specifier would be nice.
(set (make-local-variable 'frame-title-format)
(capitalize-string-as-title
- ;; Delete ": " off the end. There must be an easier way!
- (let ((end-pos (length prompt)))
- (if (and (> end-pos 0) (eq (aref prompt (1- end-pos)) ? ))
- (setq end-pos (1- end-pos)))
- (if (and (> end-pos 0) (eq (aref prompt (1- end-pos)) ?:))
- (setq end-pos (1- end-pos)))
- (substring prompt 0 end-pos))))
+ ;; Kludge: Delete ": " off the end.
+ (replace-in-string prompt ": $" "")))
;; ensure that killing the frame works right,
;; instead of leaving us in the minibuffer.
(add-local-hook 'delete-frame-hook
"Modeline customizations."
:group 'environment)
+(defcustom modeline-3d-p ;; added for the options menu
+ (let ((thickness
+ (specifier-instance modeline-shadow-thickness)))
+ (and (integerp thickness)
+ (> thickness 0)))
+ "Whether the default toolbar is globally visible. This option can be
+customized through the options menu."
+ :group 'display
+ :type 'boolean
+ :set #'(lambda (var val)
+ (if val
+ (set-specifier modeline-shadow-thickness 2)
+ (set-specifier modeline-shadow-thickness 0))
+ (redraw-modeline t)
+ (setq modeline-3d-p val))
+ )
+
(defcustom drag-divider-event-lag 150
"*The pause (in msecs) between divider drag events before redisplaying.
If this value is too small, dragging will be choppy because redisplay cannot
;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems
-;; Copyright (C) 1995, 1996 Ben Wing.
+;; Copyright (C) 1995, 1996, 2000 Ben Wing.
;; Maintainer: XEmacs Development Team
;; Keywords: mouse, dumped
;; This file is dumped with XEmacs (when window system support is compiled in).
+;;; Authorship:
+
+;; Probably originally derived from FSF 19 pre-release.
+;; much hacked upon by Jamie Zawinski and crew, pre-1994.
+;; (only mouse-motion stuff currently remains from that era)
+;; all mouse-track stuff completely rewritten by Ben Wing, 1995-1996.
+;; mouse-eval-sexp and *-inside-extent-p from Stig, 1995.
+;; vertical divider code c. 1998 from ?.
+
;;; Code:
(provide 'mouse)
(global-set-key '(control button1) 'mouse-track-insert)
(global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
(global-set-key '(meta button1) 'mouse-track-do-rectangle)
-
-;; drops are now handled in dragdrop.el (ograf@fga.de)
-
-;; enable drag regions (ograf@fga.de)
-;; if button2 is dragged from within a region, this becomes a drop
-;;
-;; this must be changed to the new api
-(if (featurep '(or offix cde mswindows))
- (global-set-key 'button2 'mouse-drag-or-yank)
- (global-set-key 'button2 'mouse-yank))
+(global-set-key 'button2 'mouse-track)
(defgroup mouse nil
"Window system-independent mouse support."
(defun click-inside-extent-p (click extent)
"Return non-nil if the button event is within the primary selection-extent.
Return nil otherwise."
- ;; stig@hackvan.com
(let ((ewin (event-window click))
(epnt (event-point click)))
(and ewin
"Return t if point is within the bounds of the primary selection extent.
Return t is point is at the end position of the extent.
Return nil otherwise."
- ;; stig@hackvan.com
(and extent
(eq (current-buffer)
(extent-object extent))
(>= (extent-end-position extent) (point))))
(defun point-inside-selection-p ()
- ;; by Stig@hackvan.com
(or (point-inside-extent-p primary-selection-extent)
(point-inside-extent-p zmacs-region-extent)))
-(defun mouse-drag-or-yank (event)
- "Either drag or paste the current selection.
-If the variable `mouse-yank-at-point' is non-nil,
-move the cursor to the location of the click before pasting.
-This functions has to be improved. Currently it is just a (working) test."
- ;; by Oliver Graf <ograf@fga.de>
- (interactive "e")
- (if (click-inside-extent-p event zmacs-region-extent)
- ;; okay, this is a drag
- (cond ((featurep 'offix)
- (offix-start-drag-region
- event
- (extent-start-position zmacs-region-extent)
- (extent-end-position zmacs-region-extent)))
- ((featurep 'cde)
- ;; should also work with CDE
- (cde-start-drag-region event
- (extent-start-position zmacs-region-extent)
- (extent-end-position zmacs-region-extent)))
- (t (error "No offix or CDE support compiled in")))
- ;; no drag, call region-funct
- (and (not mouse-yank-at-point)
- (mouse-set-point event))
- (funcall mouse-yank-function))
- )
+(defun mouse-begin-drag-n-drop (event)
+ "Begin a drag-n-drop operation.
+EVENT should be the button event that initiated the drag.
+Returns whether a drag was begun."
+ ;; #### barely implemented.
+ (when (click-inside-selection-p event)
+ (cond ((featurep 'offix)
+ (offix-start-drag-region
+ event
+ (extent-start-position zmacs-region-extent)
+ (extent-end-position zmacs-region-extent))
+ t)
+ ((featurep 'cde)
+ ;; should also work with CDE
+ (cde-start-drag-region event
+ (extent-start-position zmacs-region-extent)
+ (extent-end-position zmacs-region-extent))
+ t))))
(defun mouse-eval-sexp (click force-window)
"Evaluate the sexp under the mouse. Usually, this is the last sexp before
you can use `mouse-eval-sexp' to interactively test code that acts upon a
buffer...something you cannot do with the standard `eval-last-sexp' function.
It's also fantastic for debugging regular expressions."
- ;; by Stig@hackvan.com
(interactive "e\nP")
(let (exp val result-str)
(setq exp (save-window-excursion
:type '(choice integer (const :tag "Disabled" nil))
:group 'mouse)
+(defcustom mouse-track-activate-strokes '(button1-double-click button2-click)
+ "List of mouse strokes that can cause \"activation\" of the text extent
+under the mouse. The exact meaning of \"activation\" is dependent on the
+text clicked on and the mode of the buffer, but typically entails actions
+such as following a hyperlink or selecting an entry in a completion buffer.
+
+Possible list entries are
+
+button1-click
+button1-double-click
+button1-triple-click
+button1-down
+button2-click
+button2-double-click
+button2-triple-click
+button2-down
+
+As a general rule, you should not use the \"-down\" values, because this
+makes it impossible to have other simultaneous actions, such as selection."
+ :type '(set
+ button1-click
+ button1-double-click
+ button1-triple-click
+ button1-down
+ button2-click
+ button2-double-click
+ button2-triple-click
+ button2-down)
+ :group 'mouse)
+
(defvar mouse-track-x-threshold '(face-width 'default)
"Minimum number of pixels in the X direction for a drag to be initiated.
If the mouse is moved more than either the X or Y threshold while the
'mouse-track-scroll-undefined
(copy-event event)))))
+(defun mouse-track-do-activate (event)
+ "Execute the activate function under EVENT, if any.
+Return true if the function was activated."
+ (let ((ex (extent-at-event event 'activate-function)))
+ (when ex
+ (funcall (extent-property ex 'activate-function)
+ event ex)
+ t)))
+
(defun mouse-track-run-hook (hook event &rest args)
;; ugh, can't use run-hook-with-args-until-success because we have
;; to get the value using symbol-value-in-buffer. Doing a
)
(defun mouse-track (event)
- "Make a selection with the mouse. This should be bound to a mouse button.
-The behavior of XEmacs during mouse selection is customizable using various
-hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
+ "Generalized mouse-button handler. This should be bound to a mouse button.
+The behavior of this function is customizable using various hooks and
+variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
`mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
`mouse-track-cleanup-hook', `mouse-track-multi-click-time',
`mouse-track-scroll-delay', `mouse-track-x-threshold', and
(disown-selection)))))
(setq default-mouse-track-down-event nil))))
+;; return t if the button or motion event involved the specified button.
+(defun default-mouse-track-event-is-with-button (event n)
+ (cond ((button-event-p event)
+ (= n (event-button event)))
+ ((motion-event-p event)
+ (memq (cdr
+ (assq n '((1 . button1) (2 . button2) (3 . button3)
+ (4 . button4) (5 . button5))))
+ (event-modifiers event)))))
+
(defun default-mouse-track-down-hook (event click-count)
- (setq default-mouse-track-down-event (copy-event event))
- nil)
+ (cond ((default-mouse-track-event-is-with-button event 1)
+ (if (and (memq 'button1-down mouse-track-activate-strokes)
+ (mouse-track-do-activate event))
+ t
+ (setq default-mouse-track-down-event (copy-event event))
+ nil))
+ ((default-mouse-track-event-is-with-button event 2)
+ (and (memq 'button2-down mouse-track-activate-strokes)
+ (mouse-track-do-activate event)))))
(defun default-mouse-track-cleanup-extents-hook ()
(remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
(if (consp extent) ; rectangle-p
(mapcar func extent)
(if extent
- (funcall func extent))))))
+ (funcall func extent)))))
+ t)
(defun default-mouse-track-cleanup-extent ()
(let ((dead-func
(setq default-mouse-track-extent nil)))))
(defun default-mouse-track-drag-hook (event click-count was-timeout)
- (default-mouse-track-deal-with-down-event click-count)
- (default-mouse-track-set-point event default-mouse-track-window)
- (default-mouse-track-cleanup-extent)
- (default-mouse-track-next-move default-mouse-track-min-anchor
- default-mouse-track-max-anchor
- default-mouse-track-extent)
- t)
+ (cond ((default-mouse-track-event-is-with-button event 1)
+ (default-mouse-track-deal-with-down-event click-count)
+ (default-mouse-track-set-point event default-mouse-track-window)
+ (default-mouse-track-cleanup-extent)
+ (default-mouse-track-next-move default-mouse-track-min-anchor
+ default-mouse-track-max-anchor
+ default-mouse-track-extent)
+ t)
+ ((default-mouse-track-event-is-with-button event 2)
+ (mouse-begin-drag-n-drop event))))
(defun default-mouse-track-return-dragged-selection (event)
(default-mouse-track-cleanup-extent)
result))
(defun default-mouse-track-drag-up-hook (event click-count)
- (let ((result (default-mouse-track-return-dragged-selection event)))
- (if result
- (default-mouse-track-maybe-own-selection result 'PRIMARY)))
- t)
+ (when (default-mouse-track-event-is-with-button event 1)
+ (let ((result (default-mouse-track-return-dragged-selection event)))
+ (if result
+ (default-mouse-track-maybe-own-selection result 'PRIMARY)))
+ t))
(defun default-mouse-track-click-hook (event click-count)
- (default-mouse-track-drag-hook event click-count nil)
- (default-mouse-track-drag-up-hook event click-count)
- t)
+ (cond ((default-mouse-track-event-is-with-button event 1)
+ (if (and
+ (or (and (= click-count 1)
+ (memq 'button1-click
+ mouse-track-activate-strokes))
+ (and (= click-count 2)
+ (memq 'button1-double-click
+ mouse-track-activate-strokes))
+ (and (= click-count 3)
+ (memq 'button1-triple-click
+ mouse-track-activate-strokes)))
+ (mouse-track-do-activate event))
+ t
+ (default-mouse-track-drag-hook event click-count nil)
+ (default-mouse-track-drag-up-hook event click-count)
+ t))
+ ((default-mouse-track-event-is-with-button event 2)
+ (if (and
+ (or (and (= click-count 1)
+ (memq 'button2-click
+ mouse-track-activate-strokes))
+ (and (= click-count 2)
+ (memq 'button2-double-click
+ mouse-track-activate-strokes))
+ (and (= click-count 3)
+ (memq 'button2-triple-click
+ mouse-track-activate-strokes)))
+ (mouse-track-do-activate event))
+ t
+ (mouse-yank event)
+ t))))
+
(add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
(add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
;;
(defun drag-window-divider (event)
"Handle resizing windows by dragging window dividers.
-This is an intenal function, normally bound to button1 event in
+This is an internal function, normally bound to button1 event in
window-divider-map. You would not call it, but you may bind it to
other mouse buttons."
(interactive "e")
;; (setq args (cdr args)))))
\f
-;;; CCL dump staffs
-
-;; To avoid byte-compiler warning.
-(defvar ccl-code)
+;;; CCL dump stuff
;;;###autoload
(defun ccl-dump (ccl-code)
;; Return a CCL code in `ccl-code' at `ccl-current-ic'.
(defun ccl-get-next-code ()
+ (declare (special ccl-code))
(prog1
(aref ccl-code ccl-current-ic)
(setq ccl-current-ic (1+ ccl-current-ic))))
;; Delete empty directories.
(if dirs
(let ( (orig-default-directory default-directory)
- directory files file )
+ ;; directory files file
+ )
;; Make sure we preserve the existing `default-directory'.
;; JV, why does this change the default directory? Does it indeed?
(unwind-protect
(mapcar
#'(lambda (reqd)
(let* ((reqd-package (package-get-package-provider reqd))
- (reqd-version (cadr reqd-package))
(reqd-name (car reqd-package)))
(if (null reqd-name)
(error "Unable to find a provider for %s" reqd))
(error "No package under cursor!")))
)))
-;;; "Why is there no standard function to do this?"
-(defun pui-popup-context-sensitive (event)
- (interactive "e")
- (save-excursion
- (set-buffer (event-buffer event))
- (goto-char (event-point event))
- (popup-menu pui-menu event)
- ;; I agree with dired.el - this is seriously bogus.
- (while (popup-menu-up-p)
- (dispatch-event (next-event)))))
-
(defvar pui-menu
'("Packages"
["Toggle install " pui-toggle-package-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
["Help" pui-help t]
["Quit" pui-quit t]))
+;;; "Why is there no standard function to do this?"
+(defun pui-popup-context-sensitive (event)
+ (interactive "e")
+ (save-excursion
+ (set-buffer (event-buffer event))
+ (goto-char (event-point event))
+ (popup-menu pui-menu event)
+ ;; I agree with dired.el - this is seriously bogus.
+ (while (popup-up-p)
+ (dispatch-event (next-event)))))
(defun list-packages-mode ()
"Symbols in the leftmost column:
;Go to a local news spool if its value is nil, in which case `gnus-nntp-server'
;should be set to `(system-name)'.")
-(defvar gnus-local-domain nil
- "*Your domain name without a host name: for example, \"ai.mit.edu\".
-The DOMAINNAME environment variable is used instead if defined.
-If the function `system-name' returns a fully qualified domain name,
-there is no need to set this variable.")
-
-(defvar gnus-local-organization nil
- "*The name of your organization, as a string.
-The `ORGANIZATION' environment variable is used instead if defined.")
-
(defvar mh-progs nil
"Directory containing MH commands.")
(defvar rmail-file-name (purecopy "~/RMAIL")
"Name of user's primary mail file.")
-(defvar gnus-startup-file (purecopy "~/.newsrc")
- "The file listing groups to which user is subscribed.
-Will use `gnus-startup-file'-SERVER instead if exists.")
-
(defconst rmail-spool-directory nil
"Name of directory used by system mailer for delivering new mail.
Its name should end with a slash.")
(Transmission Control Protocol) and 'udp (User Datagram Protocol) are
supported. When omitted, 'tcp is assumed.
-Ouput via `process-send-string' and input via buffer or filter (see
+Output via `process-send-string' and input via buffer or filter (see
`set-process-filter') are stream-oriented. That means UDP datagrams are
not guaranteed to be sent and received in discrete packets. (But small
datagrams around 500 bytes that are not truncated by `process-send-string'
(defun shell-quote-argument (argument)
"Quote an argument for passing as argument to an inferior shell."
(if (and (eq system-type 'windows-nt)
- ;; #### this is a temporary hack. a better solution needs
- ;; futzing with the c code. i'll do this shortly.
(let ((progname (downcase (file-name-nondirectory
shell-file-name))))
(or (equal progname "command.com")
(equal progname "cmd.exe"))))
- argument
+ ;; the expectation is that you can take the result of
+ ;; shell-quote-argument and pass it to as an arg to
+ ;; (start-process shell-quote-argument ...) and have it end
+ ;; up as-is in the program's argv[] array. to do this, we
+ ;; need to protect against both the shell's and the program's
+ ;; quoting conventions (and our own conventions in
+ ;; mswindows-construct-process-command-line!). Putting quotes
+ ;; around shell metachars gets through the last two, and applying
+ ;; the normal VC runtime quoting works with practically all apps.
+ (mswindows-quote-one-vc-runtime-arg argument t)
;; Quote everything except POSIX filename characters.
;; This should be safe enough even for really weird shells.
(let ((result "") (start 0) end)
;; XEmacs
(defun perform-replace-next-event (event)
- (if isearch-highlight
+ (if search-highlight
(let ((aborted t))
(unwind-protect
(progn
The argument TYPE (default `PRIMARY') says which selection,
and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
says how to convert the data. Returns NIL if there is no selection"
- (condition-case err (get-selection type data-type) (t nil)))
+ (condition-case nil (get-selection type data-type) (t nil)))
(defun get-selection (&optional type data-type)
"Return the value of a window-system selection.
that can be converted using the function corresponding to DATA-TYPE
in `select-converter-alist'---strings are the usual choice, but
other types may be permissible depending on the DATA-TYPE parameter
-(if DATA-TYPE is not supplied, the default behaviour is window
+(if DATA-TYPE is not supplied, the default behavior is window
system specific, but strings are always accepted).
HOW-TO-ADD may be any of the following:
or an overlay. In these cases, the selection is considered to be the text
between the markers *at whatever time the selection is examined* (note
that the window system clipboard does not necessarily duplicate this
-behaviour - it doesn't on mswindows for example).
+behavior - it doesn't on mswindows for example).
Thus, editing done in the buffer after you specify the selection
can alter the effective value of the selection.
;;; Functions to convert the selection into various other selection
;;; types.
-;; These two functions get called by C code...
+;; These next three functions get called by C code...
(defun select-convert-in (selection type value)
"Attempt to convert the specified external VALUE to the specified DATA-TYPE,
for the specified SELECTION. Return nil if this is impossible, or a
(when handler-fn
(apply handler-fn (list selection type value))))))
+(defun select-coerce (selection type value)
+ "Attempt to convert the specified internal VALUE to a representation
+suitable for return from `get-selection' in the specified DATA-TYPE. Return
+nil if this is impossible, or a suitable representation otherwise."
+ (when value
+ (let ((handler-fn (cdr (assq type selection-coercion-alist))))
+ (when handler-fn
+ (apply handler-fn (list selection type value))))))
+
;; The rest of the functions on this "page" are conversion handlers,
;; append handlers and buffer-kill handlers.
(defun select-convert-to-text (selection type value)
(buffer-substring (car value) (cdr value)))))
(t nil)))
+(defun select-coerce-to-text (selection type value)
+ (select-convert-to-text selection type value))
+
(defun select-convert-from-text (selection type value)
(when (stringp value)
value))
(defun select-convert-to-string (selection type value)
(let ((outval (select-convert-to-text selection type value)))
- ;; force the string to be not in Compound Text format.
+ ;; force the string to be not in Compound Text format. This grubby
+ ;; hack will go soon, to be replaced by a more general mechanism.
(if (stringp outval)
(cons 'STRING outval)
outval)))
(user-full-name))
(defun select-convert-to-class (selection type size)
- x-emacs-application-class)
+ (symbol-value 'x-emacs-application-class))
;; We do not try to determine the name Emacs was invoked with,
;; because it is not clean for a program's behavior to depend on that.
;;; Buffer kill handlers
-;; #### Should this function take the text *out* of the buffer that's
-;; being killed? Or should it do what the original code did and just
-;; destroy the selection?
(defun select-buffer-killed-default (selection type value buffer)
;; This handler gets used if the type is "nil".
(cond ((extentp value)
- (unless (eq (extent-object value) buffer)
+ (if (eq (extent-object value) buffer)
+ ; If this selection is on the clipboard, grab it quick
+ (when (eq selection 'CLIPBOARD)
+ (save-excursion
+ (set-buffer (extent-object value))
+ (save-restriction
+ (widen)
+ (buffer-substring (extent-start-position value)
+ (extent-end-position value)))))
value))
((markerp value)
(unless (eq (marker-buffer value) buffer)
((and (consp value)
(markerp (car value))
(markerp (cdr value)))
- (unless (or (eq (marker-buffer (car value)) buffer)
- (eq (marker-buffer (cdr value)) buffer))
- value))
+ (if (or (eq (marker-buffer (car value)) buffer)
+ (eq (marker-buffer (cdr value)) buffer))
+ ; If this selection is on the clipboard, grab it quick
+ (when (eq selection 'CLIPBOARD)
+ (save-excursion
+ (set-buffer (marker-buffer (car value)))
+ (save-restriction
+ (widen)
+ (buffer-substring (car value) (cdr value)))))
+ value))
(t value)))
(defun select-buffer-killed-text (selection type value buffer)
(CF_TEXT . select-convert-from-cf-text)
))
+;; Types listed here have special coercion functions that can munge
+;; other types. This can also be used to add special features - e.g.
+;; being able to pass a region or a cons of markers to own-selection,
+;; but getting the *current* text in the region back when calling
+;; get-selection.
+;;
+;; Any function listed in here *will be called* whenever a value of
+;; its type is retrieved from the internal selection cache, or when
+;; no suitable values could be found in which case XEmacs looks for
+;; values with types listed in selection-coercible-types.
+(setq selection-coercion-alist
+ '((TEXT . select-coerce-to-text)
+ (STRING . select-coerce-to-text)
+ (COMPOUND_TEXT . select-coerce-to-text)
+ (CF_TEXT . select-coerce-to-text)))
+
;; Types listed here can be appended by own-selection
(setq selection-appender-alist
'((nil . select-append-default)
(forward-line arg)))
arg))
-(eval-when-compile
- ;; avoid byte-compiler warnings...
- (defvar start1)
- (defvar start2)
- (defvar end1)
- (defvar end2))
+(defun transpose-line-up (arg)
+ "Move current line one line up, leaving point at beginning of that line.
+This can be run repeatedly to move to current line up a number of lines."
+ (interactive "*p")
+ ;; Move forward over a line,
+ ;; but create a newline if none exists yet.
+ (end-of-line)
+ (if (eobp)
+ (newline)
+ (forward-char 1))
+ (transpose-lines (- arg))
+ (forward-line -1))
+
+(defun transpose-line-down (arg)
+ "Move current line one line down, leaving point at beginning of that line.
+This can be run repeatedly to move to current line down a number of lines."
+ (interactive "*p")
+ ;; Move forward over a line,
+ ;; but create a newline if none exists yet.
+ (end-of-line)
+ (if (eobp)
+ (newline)
+ (forward-char 1))
+ (transpose-lines arg)
+ (forward-line -1))
-; start[12] and end[12] used in transpose-subr-1 below
(defun transpose-subr (mover arg)
(let (start1 end1 start2 end2)
- (if (= arg 0)
- (progn
- (save-excursion
- (funcall mover 1)
- (setq end2 (point))
- (funcall mover -1)
- (setq start2 (point))
- (goto-char (mark t)) ; XEmacs
- (funcall mover 1)
- (setq end1 (point))
- (funcall mover -1)
- (setq start1 (point))
- (transpose-subr-1))
- (exchange-point-and-mark t))) ; XEmacs
- (while (> arg 0)
- (funcall mover -1)
- (setq start1 (point))
- (funcall mover 1)
- (setq end1 (point))
- (funcall mover 1)
- (setq end2 (point))
- (funcall mover -1)
- (setq start2 (point))
- (transpose-subr-1)
- (goto-char end2)
- (setq arg (1- arg)))
- (while (< arg 0)
- (funcall mover -1)
- (setq start2 (point))
- (funcall mover -1)
- (setq start1 (point))
- (funcall mover 1)
- (setq end1 (point))
- (funcall mover 1)
- (setq end2 (point))
- (transpose-subr-1)
- (setq arg (1+ arg)))))
-
-; start[12] and end[12] used free
-(defun transpose-subr-1 ()
- (if (> (min end1 end2) (max start1 start2))
- (error "Don't have two things to transpose"))
- (let ((word1 (buffer-substring start1 end1))
- (word2 (buffer-substring start2 end2)))
- (delete-region start2 end2)
- (goto-char start2)
- (insert word1)
- (goto-char (if (< start1 start2) start1
- (+ start1 (- (length word1) (length word2)))))
- (delete-char (length word1))
- (insert word2)))
+ ;; XEmacs -- use flet instead of defining a separate function and
+ ;; relying on dynamic scope!!!
+ (flet ((transpose-subr-1 ()
+ (if (> (min end1 end2) (max start1 start2))
+ (error "Don't have two things to transpose"))
+ (let ((word1 (buffer-substring start1 end1))
+ (word2 (buffer-substring start2 end2)))
+ (delete-region start2 end2)
+ (goto-char start2)
+ (insert word1)
+ (goto-char (if (< start1 start2) start1
+ (+ start1 (- (length word1) (length word2)))))
+ (delete-char (length word1))
+ (insert word2))))
+ (if (= arg 0)
+ (progn
+ (save-excursion
+ (funcall mover 1)
+ (setq end2 (point))
+ (funcall mover -1)
+ (setq start2 (point))
+ (goto-char (mark t)) ; XEmacs
+ (funcall mover 1)
+ (setq end1 (point))
+ (funcall mover -1)
+ (setq start1 (point))
+ (transpose-subr-1))
+ (exchange-point-and-mark t))) ; XEmacs
+ (while (> arg 0)
+ (funcall mover -1)
+ (setq start1 (point))
+ (funcall mover 1)
+ (setq end1 (point))
+ (funcall mover 1)
+ (setq end2 (point))
+ (funcall mover -1)
+ (setq start2 (point))
+ (transpose-subr-1)
+ (goto-char end2)
+ (setq arg (1- arg)))
+ (while (< arg 0)
+ (funcall mover -1)
+ (setq start2 (point))
+ (funcall mover -1)
+ (setq start1 (point))
+ (funcall mover 1)
+ (setq end1 (point))
+ (funcall mover 1)
+ (setq end2 (point))
+ (transpose-subr-1)
+ (setq arg (1+ arg))))))
+
\f
(defcustom comment-column 32
"*Column to indent right-margin comments to.
;Turned off because it makes dbx bomb out.
(setq blink-paren-function 'blink-matching-open)
\f
-(eval-when-compile (defvar myhelp)) ; suppress compiler warning
;; XEmacs: Some functions moved to cmdloop.el:
;; keyboard-quit
(let* ((var (read-variable "Set variable: "))
;; #### - yucky code replication here. This should use something
;; from help.el or hyper-apropos.el
- (minibuffer-help-form
- '(funcall myhelp))
(myhelp
#'(lambda ()
(with-output-to-temp-buffer "*Help*"
(save-excursion
(set-buffer standard-output)
(help-mode))
- nil))))
+ nil)))
+ (minibuffer-help-form
+ '(funcall myhelp)))
(list var
(let ((prop (get var 'variable-interactive)))
(if prop
(setq warning-marker (make-marker))
(set-marker warning-marker 1 buffer))
(if temp-buffer-show-function
- (let ((show-buffer (get-buffer-create "*Warnings-Show*")))
- (save-excursion
- (set-buffer show-buffer)
- (setq buffer-read-only nil)
- (erase-buffer))
- (save-excursion
- (set-buffer buffer)
- (copy-to-buffer show-buffer
- (marker-position warning-marker)
- (point-max)))
- (funcall temp-buffer-show-function show-buffer))
+ (progn
+ (funcall temp-buffer-show-function buffer)
+ (mapc #'(lambda (win) (set-window-start win warning-marker))
+ (windows-of-buffer buffer nil t)))
(set-window-start (display-buffer buffer) warning-marker))
(set-marker warning-marker (point-max buffer) buffer)))
(cond ((featurep 'infodock) "InfoDock")
((featurep 'xemacs) "XEmacs")
(t "Emacs")))
+
+(defun debug-print (format &rest args)
+ "Send a string to the debugging output.
+The string is formatted using (apply #'format FORMAT ARGS)."
+ (princ (apply #'format format args) 'external-debugging-output))
;;; simple.el ends here
(setplist new (copy-list (symbol-plist symbol))))
new))
+(defun set-symbol-value-in-buffer (sym val buffer)
+ "Set the value of SYM to VAL in BUFFER. Useful with buffer-local variables.
+If SYM has a buffer-local value in BUFFER, or will have one if set, this
+function allows you to set the local value.
+
+NOTE: At some point, this will be moved into C and will be very fast."
+ (with-current-buffer buffer
+ (set sym val)))
+
;;;; String functions.
;; XEmacs
"Replace all matches in STR for REGEXP with NEWTEXT string,
and returns the new string.
Optional LITERAL non-nil means do a literal replacement.
-Otherwise treat \\ in NEWTEXT string as special:
- \\& means substitute original matched text,
- \\N means substitute match for \(...\) number N,
- \\\\ means insert one \\."
+Otherwise treat `\\' in NEWTEXT as special:
+ `\\&' in NEWTEXT means substitute original matched text.
+ `\\N' means substitute what matched the Nth `\\(...\\)'.
+ If Nth parens didn't match, substitute nothing.
+ `\\\\' means insert one `\\'.
+ `\\u' means upcase the next character.
+ `\\l' means downcase the next character.
+ `\\U' means begin upcasing all following characters.
+ `\\L' means begin downcasing all following characters.
+ `\\E' means terminate the effect of any `\\U' or `\\L'."
(check-argument-type 'stringp str)
(check-argument-type 'stringp newtext)
- (let ((rtn-str "")
- (start 0)
- (special)
- match prev-start)
- (while (setq match (string-match regexp str start))
- (setq prev-start start
- start (match-end 0)
- rtn-str
- (concat
- rtn-str
- (substring str prev-start match)
- (cond (literal newtext)
- (t (mapconcat
- (lambda (c)
- (if special
- (progn
- (setq special nil)
- (cond ((eq c ?\\) "\\")
- ((eq c ?&)
- (substring str
- (match-beginning 0)
- (match-end 0)))
- ((and (>= c ?0) (<= c ?9))
- (if (> c (+ ?0 (length
- (match-data))))
- ;; Invalid match num
- (error "Invalid match num: %c" c)
- (setq c (- c ?0))
- (substring str
- (match-beginning c)
- (match-end c))))
- (t (char-to-string c))))
- (if (eq c ?\\) (progn (setq special t) nil)
- (char-to-string c))))
- newtext ""))))))
- (concat rtn-str (substring str start))))
+ (if (> (length str) 50)
+ (with-temp-buffer
+ (insert str)
+ (goto-char 1)
+ (while (re-search-forward regexp nil t)
+ (replace-match newtext t literal))
+ (buffer-string))
+ (let ((start 0) newstr)
+ (while (string-match regexp str start)
+ (setq newstr (replace-match newtext t literal str)
+ start (+ (match-end 0) (- (length newstr) (length str)))
+ str newstr))
+ str)))
(defun split-string (string &optional pattern)
"Return a list of substrings of STRING which are separated by PATTERN.
\f
;;; Error functions
-(defun error (&rest args)
- "Signal an error, making error message by passing all args to `format'.
-This error is not continuable: you cannot continue execution after the
-error using the debugger `r' command. See also `cerror'."
- (while t
- (apply 'cerror args)))
+(defun error (datum &rest args)
+ "Signal a non-continuable error.
+DATUM should normally be an error symbol, i.e. a symbol defined using
+`define-error'. ARGS will be made into a list, and DATUM and ARGS passed
+as the two arguments to `signal', the most basic error handling function.
-(defun cerror (&rest args)
+This error is not continuable: you cannot continue execution after the
+error using the debugger `r' command. See also `cerror'.
+
+The correct semantics of ARGS varies from error to error, but for most
+errors that need to be generated in Lisp code, the first argument
+should be a string describing the *context* of the error (i.e. the
+exact operation being performed and what went wrong), and the remaining
+arguments or \"frobs\" (most often, there is one) specify the
+offending object(s) and/or provide additional details such as the exact
+error when a file error occurred, e.g.:
+
+-- the buffer in which an editing error occurred.
+-- an invalid value that was encountered. (In such cases, the string
+ should describe the purpose or \"semantics\" of the value [e.g. if the
+ value is an argument to a function, the name of the argument; if the value
+ is the value corresponding to a keyword, the name of the keyword; if the
+ value is supposed to be a list length, say this and say what the purpose
+ of the list is; etc.] as well as specifying why the value is invalid, if
+ that's not self-evident.)
+-- the file in which an error occurred. (In such cases, there should be a
+ second frob, probably a string, specifying the exact error that occurred.
+ This does not occur in the string that precedes the first frob, because
+ that frob describes the exact operation that was happening.
+
+For historical compatibility, DATUM can also be a string. In this case,
+DATUM and ARGS are passed together as the arguments to `format', and then
+an error is signalled using the error symbol `error' and formatted string.
+Although this usage of `error' is very common, it is deprecated because it
+totally defeats the purpose of having structured errors. There is now
+a rich set of defined errors you can use:
+
+error
+ syntax-error
+ invalid-read-syntax
+ list-formation-error
+ malformed-list
+ malformed-property-list
+ circular-list
+ circular-property-list
+
+ invalid-argument
+ wrong-type-argument
+ args-out-of-range
+ wrong-number-of-arguments
+ invalid-function
+ no-catch
+
+ invalid-state
+ void-function
+ cyclic-function-indirection
+ void-variable
+ cyclic-variable-indirection
+
+ invalid-operation
+ invalid-change
+ setting-constant
+ editing-error
+ beginning-of-buffer
+ end-of-buffer
+ buffer-read-only
+ io-error
+ end-of-file
+ arith-error
+ range-error
+ domain-error
+ singularity-error
+ overflow-error
+ underflow-error
+
+The five most common errors you will probably use or base your new
+errors off of are `syntax-error', `invalid-argument', `invalid-state',
+`invalid-operation', and `invalid-change'. Note the semantic differences:
+
+-- `syntax-error' is for errors in complex structures: parsed strings, lists,
+ and the like.
+-- `invalid-argument' is for errors in a simple value. Typically, the entire
+ value, not just one part of it, is wrong.
+-- `invalid-state' means that some settings have been changed in such a way
+ that their current state is unallowable. More and more, code is being
+ written more carefully, and catches the error when the settings are being
+ changed, rather than afterwards. This leads us to the next error:
+-- `invalid-change' means that an attempt is being made to change some settings
+ into an invalid state. `invalid-change' is a type of `invalid-operation'.
+-- `invalid-operation' refers to all cases where code is trying to do something
+ that's disallowed. This includes file errors, buffer errors (e.g. running
+ off the end of a buffer), `invalid-change' as just mentioned, and
+ arithmetic errors.
+
+See also `cerror', `signal', and `signal-error'."
+ (while t (apply
+ 'cerror datum args)))
+
+(defun cerror (datum &rest args)
"Like `error' but signals a continuable error."
- (signal 'error (list (apply 'format args))))
+ (cond ((stringp datum)
+ (signal 'error (list (apply 'format datum args))))
+ ((defined-error-p datum)
+ (signal datum args))
+ (t
+ (error 'invalid-argument "datum not string or error symbol" datum))))
(defmacro check-argument-type (predicate argument)
"Check that ARGUMENT satisfies PREDICATE.
-If not, signal a continuable `wrong-type-argument' error until the
-returned value satisfies PREDICATE, and assign the returned value
-to ARGUMENT."
- `(if (not (,(eval predicate) ,argument))
- (setq ,argument
- (wrong-type-argument ,predicate ,argument))))
+This is a macro, and ARGUMENT is not evaluated. If ARGUMENT is an lvalue,
+this function signals a continuable `wrong-type-argument' error until the
+returned value satisfies PREDICATE, and assigns the returned value
+to ARGUMENT. Otherwise, this function signals a non-continuable
+`wrong-type-argument' error if the returned value does not satisfy PREDICATE."
+ (if (symbolp argument)
+ `(if (not (,(eval predicate) ,argument))
+ (setq ,argument
+ (wrong-type-argument ,predicate ,argument)))
+ `(if (not (,(eval predicate) ,argument))
+ (signal-error 'wrong-type-argument (list ,predicate ,argument)))))
(defun signal-error (error-symbol data)
"Signal a non-continuable error. Args are ERROR-SYMBOL, and associated DATA.
(or conds (signal-error 'error (list "Not an error symbol" error-sym)))
(put error-sym 'error-conditions (cons error-sym conds))))
+(defun defined-error-p (sym)
+ "Returns non-nil if SYM names a currently-defined error."
+ (and (symbolp sym) (not (null (get sym 'error-conditions)))))
+
;;;; Miscellanea.
;; This is now in C.
(require 'gdbsrc)
(call-interactively 'gdbsrc)))
-(defvar compile-command)
-(defvar toolbar-compile-already-run nil)
-
(defun toolbar-compile ()
"Run compile without having to touch the keyboard."
(interactive)
+ (declare (special compile-command toolbar-compile-already-run))
(require 'compile)
- (if toolbar-compile-already-run
+ (if (boundp 'toolbar-compile-already-run)
(compile compile-command)
(setq toolbar-compile-already-run t)
(if (should-use-dialog-box-p)
- (popup-dialog-box
- `(,(concat "Compile:\n " compile-command)
- ["Compile" (compile compile-command) t]
- ["Edit command" compile t]
- nil
- ["Cancel" (message "Quit") t]))
+ (make-dialog-box 'question
+ :question (concat "Compile:\n " compile-command)
+ :buttons
+ '(["Compile" (compile compile-command) t]
+ ["Edit command" compile t]
+ nil
+ ["Cancel" (message "Quit") t]))
(compile compile-command))))
;;
;;; dialog-box versions [XEmacs]
(defun ask-user-about-lock-dbox (fn opponent)
- (let ((echo-keystrokes 0)
- (dbox
- (cons
- (format "%s is locking %s\n
+ (let ((echo-keystrokes 0))
+ (make-dialog-box
+ 'question
+ :question (format "%s is locking %s\n
It has been detected that you want to modify a file that
someone else has already started modifying in XEmacs."
- opponent fn)
- '(["Steal Lock\n\nThe other user will\nbecome the intruder" steal t]
- ["Proceed\n\nEdit file at your own\n\(and the other user's) risk"
- proceed t]
- nil
- ["Abort\n\nDon't modify the buffer\n" yield t]))))
- (popup-dialog-box dbox)
+ opponent fn)
+ :buttons
+ '(["Steal Lock\n\nThe other user will\nbecome the intruder" steal t]
+ ["Proceed\n\nEdit file at your own\n\(and the other user's) risk"
+ proceed t]
+ nil
+ ["Abort\n\nDon't modify the buffer\n" yield t]))
(catch 'aual-done
(while t
(let ((event (next-command-event)))
- (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed))
+ (cond ((and (misc-user-event-p event)
+ (eq (event-object event) 'proceed))
(throw 'aual-done nil))
- ((and (misc-user-event-p event) (eq (event-object event) 'steal))
+ ((and (misc-user-event-p event)
+ (eq (event-object event) 'steal))
(throw 'aual-done t))
- ((and (misc-user-event-p event) (eq (event-object event) 'yield))
+ ((and (misc-user-event-p event)
+ (eq (event-object event) 'yield))
(signal 'file-locked (list "File is locked" fn opponent)))
((and (misc-user-event-p event)
(eq (event-object event) 'menu-no-selection-hook))
(signal 'quit nil))
+ ;; safety check, so we're not endlessly stuck when no
+ ;; dialog box up
+ ((not (popup-up-p))
+ (signal 'quit nil))
((button-release-event-p event) ;; don't beep twice
nil)
(t
(message "please answer the dialog box"))))))))
(defun ask-user-about-supersession-threat-dbox (fn)
- (let ((echo-keystrokes 0)
- (dbox
- (cons
- (format "File %s has changed on disk
+ (let ((echo-keystrokes 0))
+ (make-dialog-box
+ 'question
+ :question
+ (format "File %s has changed on disk
since its buffer was last read in or saved.
Do you really want to edit the buffer? " fn)
- '(["Yes\n\nEdit the buffer anyway,\nignoring the disk file"
- proceed t]
- ["No\n\nDon't modify the buffer\n" yield t]
- nil
- ["No\n\nDon't modify the buffer\nbut revert it" revert t]
- ))))
- (popup-dialog-box dbox)
+ :buttons
+ '(["Yes\n\nEdit the buffer anyway,\nignoring the disk file"
+ proceed t]
+ ["No\n\nDon't modify the buffer\n" yield t]
+ nil
+ ["No\n\nDon't modify the buffer\nbut revert it" revert t]
+ ))
(catch 'auast-done
(while t
(let ((event (next-command-event)))
((and (misc-user-event-p event)
(eq (event-object event) 'menu-no-selection-hook))
(signal 'quit nil))
+ ;; safety check, so we're not endlessly stuck when no
+ ;; dialog box up
+ ((not (popup-up-p))
+ (signal 'quit nil))
((button-release-event-p event) ;; don't beep twice
nil)
(t
return nil (edit the file even though it is locked).
You can rewrite it to use any criterion you like to choose which one to do."
(discard-input)
- (if (and (fboundp 'popup-dialog-box)
- (or (button-press-event-p last-command-event)
- (button-release-event-p last-command-event)
- (misc-user-event-p last-command-event)))
+ (if (should-use-dialog-box-p)
(ask-user-about-lock-dbox fn opponent)
(ask-user-about-lock-minibuf fn opponent)))
You can rewrite this to use any criterion you like to choose which one to do.
The buffer in question is current when this function is called."
(discard-input)
- (if (and (fboundp 'popup-dialog-box)
- (or (button-press-event-p last-command-event)
- (button-release-event-p last-command-event)
- (misc-user-event-p last-command-event)))
+ (if (should-use-dialog-box-p)
(ask-user-about-supersession-threat-dbox fn)
(ask-user-about-supersession-threat-minibuf fn)))
(defun widget-url-link-action (widget &optional event)
"Open the url specified by WIDGET."
- (if (boundp 'browse-url-browser-function)
- (funcall browse-url-browser-function (widget-value widget))
+ (if (fboundp 'browse-url)
+ (browse-url (widget-value widget))
(error "Cannot follow URLs in this XEmacs")))
;;; The `function-link' Widget.
\f
;;;;;;;;;;;;; display-buffer, moved here from C. Hallelujah.
+(make-variable-buffer-local '__buffer-dedicated-frame)
+
+(defun buffer-dedicated-frame (&optional buffer)
+ "Return the frame dedicated to this BUFFER, or nil if there is none.
+No argument or nil as argument means use current buffer as BUFFER."
+ (let ((buffer (decode-buffer buffer)))
+ (let ((frame (symbol-value-in-buffer '__buffer-dedicated-frame buffer)))
+ ;; XEmacs addition: if the frame is dead, silently make it go away.
+ (when (and (framep frame) (not (frame-live-p frame)))
+ (with-current-buffer buffer
+ (setq __buffer-dedicated-frame nil))
+ (setq frame nil))
+ frame)))
+
+(defun set-buffer-dedicated-frame (buffer frame)
+ "For this BUFFER, set the FRAME dedicated to it.
+FRAME must be a frame or nil."
+ (let ((buffer (decode-buffer buffer)))
+ (and frame
+ (check-argument-type #'frame-live-p frame))
+ (with-current-buffer buffer
+ (setq __buffer-dedicated-frame frame))))
+
(defvar display-buffer-function nil
"If non-nil, function to call to handle `display-buffer'.
It will receive three args: the same as those to `display-buffer'.")
(defmacro save-selected-window (&rest body)
"Execute BODY, then select the window that was selected before BODY."
- (list 'let
- '((save-selected-window-window (selected-window)))
- (list 'unwind-protect
- (cons 'progn body)
- (list 'and ; XEmacs
- (list 'window-live-p 'save-selected-window-window)
- (list 'select-window 'save-selected-window-window)))))
+ `(let ((save-selected-window-window (selected-window)))
+ (unwind-protect
+ (progn ,@body)
+ (when (window-live-p save-selected-window-window)
+ (select-window save-selected-window-window)))))
+
+(defmacro with-selected-window (window &rest body)
+ "Execute forms in BODY with WINDOW as the selected window.
+The value returned is the value of the last form in BODY."
+ `(save-selected-window
+ (select-window ,window)
+ ,@body))
+
\f
(defun count-windows (&optional minibuf)
"Return the number of visible windows.
(if (and (not (eobp))
(eq ?\n (char-after (1- (point-max)))))
1 0)))
- (mini (frame-property (window-frame window) 'minibuffer))
- (edges (window-pixel-edges (selected-window))))
+ (mini (frame-property (window-frame window) 'minibuffer)))
(if (and (< 1 (let ((frame (selected-frame)))
(select-frame (window-frame window))
(unwind-protect
;; of the frame
(window-leftmost-p window)
(window-rightmost-p window)
- (zerop (nth 0 edges))
;; The whole buffer must be visible.
(pos-visible-in-window-p (point-min) window)
;; The frame must not be minibuffer-only.
"Given an X font specification, this attempts to make a `bold-italic' font.
If it fails, it returns nil."
;; This is haired up to avoid loading the "intermediate" fonts.
- (if *try-oblique-before-italic-fonts*
+ (if try-oblique-before-italic-fonts
(or (try-font-name
(x-frob-font-slant (x-frob-font-weight font "bold") "o") device)
(try-font-name
;; get the truename and use the possibly suboptimal data from that.
;;;###autoload
(defun* x-font-menu-font-data (face dcache)
+ (defvar x-font-regexp)
+ (defvar x-font-regexp-foundry-and-family)
(let* ((case-fold-search t)
(domain (if font-menu-this-frame-only-p
(selected-frame)
(defun x-activate-region-as-selection ()
(if (marker-buffer (mark-marker t))
- (x-own-selection (cons (point-marker t) (mark-marker t)))))
+ (own-selection (cons (point-marker t) (mark-marker t)))))
;; OpenWindows-like "find" processing. These functions are really Sunisms,
;; but we put them here instead of in x-win-sun.el in case someone wants
(defun ow-find (&optional backward-p)
"Search forward the next occurrence of the text of the selection."
(interactive)
- (let ((sel (condition-case () (x-get-selection) (error nil)))
- (clip (condition-case () (x-get-clipboard) (error nil)))
+ (let ((sel (ignore-errors (get-selection)))
+ (clip (ignore-errors (get-clipboard)))
text)
(setq text (cond
(sel)
(add-hook 'zmacs-deactivate-region-hook
(lambda ()
(when (console-on-window-system-p)
- (x-disown-selection))))
+ (disown-selection))))
(add-hook 'zmacs-activate-region-hook
(lambda ()
(when (console-on-window-system-p)
+2000-10-04 Martin Buchholz <martin@xemacs.org>
+
+ * XEmacs 21.2.36 is released.
+
+2000-09-19 Martin Buchholz <martin@xemacs.org>
+
+ * *: Spelling mega-patch
+
+2000-09-16 Martin Buchholz <martin@xemacs.org>
+
+ * lwlib.c (ascii_strcasecmp): New.
+ * lwlib.c (find_in_table): Use ascii_strcasecmp.
+ Avoid using non-standard non-portable strcasecmp.
+
+2000-08-02 Stephen J. Turnbull <stephen@xemacs.org>
+
+ * xlwmenu.c (XlwMenuInitialize): make comment on algorithm for
+ setting fontList match code. Suggest using same algorithm for
+ X Font Set resources in native lw code.
+
+2000-07-30 Ben Wing <ben@xemacs.org>
+
+ * lwlib-Xaw.c (xaw_update_one_widget):
+ Remove accelerator specs from buttons, since Athena doesn't handle
+ them.
+
+ * lwlib.c (lw_remove_accelerator_spec):
+ * lwlib.h:
+ Define function and prototype to do this.
+
+2000-07-15 Ben Wing <ben@xemacs.org>
+
+ * xlwradioP.h:
+ Remove duplicate definition of streq().
+
2000-07-19 Martin Buchholz <martin@xemacs.org>
* XEmacs 21.2.35 is released.
}
#endif /* ! LWLIB_DIALOGS_ATHENA3D */
+ lw_remove_accelerator_spec (val->value);
XtSetArg (al [0], XtNlabel, val->value);
XtSetArg (al [1], XtNsensitive, val->enabled);
/* Force centered button text. See above. */
{
name_string =
XmStringCreateLtoR (res_name, XmSTRING_DEFAULT_CHARSET);
-
+
value_name = XtMalloc (strlen (val->value) + 2);
*value_name = 0;
strcat (value_name, " ");
strcat (value_name, val->value);
-
+
val_string =
XmStringCreateLtoR (value_name, XmSTRING_DEFAULT_CHARSET);
-
+
built_string =
XmStringConcat (name_string, val_string);
-
+
XtFree (value_name);
}
}
val->edited = True;
}
}
- else if (class == xmListWidgetClass
+ else if (class == xmListWidgetClass
#if defined (LWLIB_WIDGETS_MOTIF) && XmVERSION > 1
|| class == xmComboBoxWidgetClass
#endif
n_children++;
}
- /* invisible seperator button */
+ /* invisible separator button */
ac = 0;
XtSetArg (al[ac], XmNmappedWhenManaged, FALSE); ac++;
children [n_children] = XmCreateLabel (row, "separator_button",
XtSetArg(al[ac], XmNrightOffset, 13); ac++;
value = XmCreateScrolledList (form, "list", al, ac);
- /* this is the easiest way I found to have the dble click in the
+ /* this is the easiest way I found to have the double click in the
list activate the default button */
XtAddCallback (value, XmNdefaultActionCallback, activate_button, button);
}
} widget_creation_entry;
/* update all other instances of a widget. Can be used in a callback when
- a wiget has been used by the user */
+ a widget has been used by the user */
void
lw_internal_update_other_instances (Widget widget, XtPointer closure,
XtPointer call_data);
/* Make a complete copy of a widget_value tree. Store CHANGE into
the widget_value tree's `change' field. */
-static widget_value *
+widget_value *
copy_widget_value_tree (widget_value *val, change_type change)
{
widget_value *copy;
val->change = NO_CHANGE;
}
+/* strcasecmp() is not sufficiently portable or standard,
+ and it's easier just to write our own. */
+static int
+ascii_strcasecmp (const char *s1, const char *s2)
+{
+ while (1)
+ {
+ char c1 = *s1++;
+ char c2 = *s2++;
+ if (c1 >= 'A' && c1 <= 'Z') c1 += 'a' - 'A';
+ if (c2 >= 'A' && c2 <= 'Z') c2 += 'a' - 'A';
+ if (c1 != c2) return c1 - c2;
+ if (c1 == '\0') return 0;
+ }
+}
static widget_creation_function
find_in_table (const char *type, widget_creation_entry *table)
{
widget_creation_entry *cur;
for (cur = table; cur->type; cur++)
- if (!strcasecmp (type, cur->type))
+ if (!ascii_strcasecmp (type, cur->type))
return cur->function;
return NULL;
}
}
}
+/* Remove %_ and convert %% to %. We can do this in-place because we
+ are always shortening, never lengthening, the string. */
+void
+lw_remove_accelerator_spec (char *val)
+{
+ char *foo = val, *bar = val;
+
+ while (*bar)
+ {
+ if (*bar == '%' && *(bar+1) == '_')
+ bar += 2;
+ else if (*bar == '%' && *(bar+1) == '%')
+ {
+ *foo++ = *bar++;
+ bar++;
+ }
+ else
+ *foo++ = *bar++;
+ }
+ *foo = '\0';
+}
void lw_add_value_args_to_args (widget_value* wv, ArgList addto, int* offset);
void lw_add_widget_value_arg (widget_value* wv, String name, XtArgVal value);
void lw_copy_widget_value_args (widget_value* copy, widget_value* val);
+widget_value * copy_widget_value_tree (widget_value *val, change_type change);
widget_value *malloc_widget_value (void);
void free_widget_value (widget_value *);
/* Silly Energize hack to invert the "sheet" button */
void lw_show_busy (Widget w, Boolean busy);
+void lw_remove_accelerator_spec (char *val);
+
#endif /* INCLUDED_lwlib_h_ */
#include <dmalloc.h>
#endif
-/* simple, naieve integer maximum */
+/* simple, naive integer maximum */
#ifndef max
#define max(a,b) ((a)>(b)?(a):(b))
#endif
{XtNfont, XtCFont, XtRFontStruct, sizeof(XFontStruct *),
offset(menu.font), XtRString, (XtPointer) "XtDefaultFont"},
# ifdef USE_XFONTSET
+ /* #### Consider using the same method as for Motif; see the comment in
+ XlwMenuInitialize(). */
{XtNfontSet, XtCFontSet, XtRFontSet, sizeof(XFontSet),
offset(menu.font_set), XtRString, (XtPointer) "XtDefaultFontSet"},
# endif
/* Unused */
#if 0
-/* These two routines should be a seperate file..djw */
+/* These two routines should be a separate file..djw */
static char *
xlw_create_localized_string (Widget w,
char *name,
else
return TEXT_TYPE;
#else
- else
+ else
abort();
return UNSPECIFIED_TYPE; /* Not reached */
#endif
mw->menu.old_depth = new_depth;
- /* refresh the last seletion */
+ /* refresh the last selection */
selection_position.x = 0;
selection_position.y = 0;
display_menu (mw, last_same, new_selection == old_selection,
gray_width, gray_height, 1, 0, 1);
#ifdef NEED_MOTIF
+ /* #### Even if it's a kludge!!!, we should consider doing the same for
+ X Font Sets. */
/* The menu.font_list slot came from the *fontList resource (Motif standard.)
The menu.font_list_2 slot came from the *font resource, for backward
compatibility with older versions of this code, and consistency with the
- rest of emacs. If both font and fontList are specified, we use font.
+ rest of emacs. If both font and fontList are specified, we use fontList.
If only one is specified, we use that. If neither are specified, we
use the "fallback" value. What a kludge!!!
+2000-10-04 Martin Buchholz <martin@xemacs.org>
+
+ * XEmacs 21.2.36 is released.
+
+2000-09-27 Martin Buchholz <martin@xemacs.org>
+
+ * lispref/processes.texi (Signals to Processes): Many corrections.
+
+2000-09-20 Martin Buchholz <martin@xemacs.org>
+
+ * xemacs/startup.texi (Startup Paths): Minor fixes.
+
+2000-09-19 Martin Buchholz <martin@xemacs.org>
+
+ * *: Spelling mega-patch
+
+2000-09-16 Martin Buchholz <martin@xemacs.org>
+
+ * internals/internals.texi (Low-Level Modules):
+ Correct the list of source files.
+
+2000-08-24 Adrian Aichner <aichner@ecf.teradyne.com>
+
+ * emodules.texi (Introduction): Trivial typo fix.
+
+2000-08-24 Martin Buchholz <martin@xemacs.org>
+
+ * emodules.texi (Initialization Mode): Spell-Check.
+
+2000-08-24 Martin Buchholz <martin@xemacs.org>
+
+ * lispref/databases.texi (Connecting to a Database):
+ s/berkeley_db/berkeley-db/. Too much C programming.
+
+2000-08-02 Stephen J. Turnbull <stephen@xemacs.org>
+
+ * xemacs/custom.texi (Menubar Resources): Document FontSet resource.
+
+2000-07-30 Ben Wing <ben@xemacs.org>
+
+ * xemacs\search.texi (Regexp Search):
+ * xemacs\search.texi (Regexps):
+ Synch up with updated docs below (describing non-greedy
+ operators and such).
+
+2000-07-30 Ben Wing <ben@xemacs.org>
+
+ * lispref\searching.texi (Syntax of Regexps):
+ Document ??, which we've supported since 20.4.
+
+2000-07-31 Sandra Wambold <wambold@cygnus.com>
+
+ * xemacs-faq.texi: Minor updates in first two sections
+
+2000-07-27 Andy Piper <andy@xemacs.org>
+
+ * lispref/hash-tables.texi: add new hash table type.
+
2000-07-19 Martin Buchholz <martin@xemacs.org>
* XEmacs 21.2.35 is released.
* info.texi: Fixed @setfilename and a typo.
* standards.texi: Added NEXT to @node Preface. See ALL.
* texinfo.texi: Fixed section names, quoted usage of @TeX{},
- changed some occurences of `:' to `colon'.
+ changed some occurrences of `:' to `colon'.
* xemacs-faq.texi: See ALL.
* internals/internals.texi: See ALL.
* lispref/back.texi: Fixed @setfilename.
support documentation.
@menu
* Introduction:: Introducing Emacs Modules
-* Annatomy of a Module:: Basic module layout and technology
+* Anatomy of a Module:: Basic module layout and technology
* Using ellcc:: How to use the module compiler
* Defining Functions:: Creating new Lisp primitives
* Defining Variables:: Creating new Lisp variables
--- The Detailed Node Listing ---
-Annatomy of a Module
+Anatomy of a Module
* Required Header File:: Always include <emodules.h>
* Required Functions:: Functions you must always provide
* Required Variables:: Variables whose values you must provide
-* Loading other Modules:: How to load dependant modules
+* Loading other Modules:: How to load dependent modules
Using @code{ellcc}
@end ifinfo
-@node Introduction, Annatomy of a Module, Top, Top
+@node Introduction, Anatomy of a Module, Top, Top
@chapter Introduction
@value{emacs} is a powerful, extensible editor. The traditional way of
implications. Like all other interpreted languages (like Java), Elisp
is often suitable only for certain types of application or extension.
So although Elisp is a general purpose language, and very high level,
-there are times when it is desirable to descend to a lower level compiled
+there are times when it is desirable to descend to a lower level compiled
language for speed purposes.
Secondly, Elisp (or Lisp in general) is not a very common language any
more, except for certain circles in the computer industry. C is a far
-more commonly known language, and because it is compiled, more suited to
+more commonly known language, and because it is compiled, more suited to
a wider range of applications, especially those that require low level
access to a system or need to be as quick as possible.
@cindex DSO
@cindex shared object
This manual describes a new way of extending @value{emacs}, by using dynamic
-loadable modules (also knows as dynamicaly loadable libraries (DLLs),
-dynamic shared objects (DSOs) or just simply shared objectcs), which can
+loadable modules (also known as dynamically loadable libraries (DLLs),
+dynamic shared objects (DSOs) or just simply shared objects), which can
be written in C or C++ and loaded into @value{emacs} at any time. I sometimes
refer to this technology as @dfn{CEmacs}, which is short for @dfn{C
Extensible Emacs}.
compile and link all objects that will make up the final shared object,
and accepts all common C compiler flags. @code{ellcc} also sets up the
correct environment for compiling modules by enabling any special
-compiler modes (such as PIC mode), setting the correct include paths for
+compiler modes (such as PIC mode), setting the correct include paths for
the location of @value{emacs} internal header files etc. The program will also
invoke the linker correctly to created the final shared object which is
loaded into @value{emacs}.
@item
@cindex header files
CEmacs also makes all of the relevant @value{emacs} internal header files
-availible for module authors to use. This is often required to get data
+available for module authors to use. This is often required to get data
structure definitions and external variable declarations. The header
files installed include the module specific header file
@file{emodules.h}. Due to the nature of dynamic modules, most of the
internals of @value{emacs} are exposed.
-@xref{Top,,,internals,@value{emacs} Internals Manual}, for a
-more complete discussion on how to extend and understand @value{emacs}. All of
+@xref{Top,,,internals,@value{emacs} Internals Manual}, for a
+more complete discussion on how to extend and understand @value{emacs}. All of
the rules for C modules are discussed there.
@item
deal to look at the actual @value{emacs} source code to see how things are
done.
-@node Annatomy of a Module, Using ellcc, Introduction, Top
-@chapter Annatomy of a Module
-@cindex annatomy
+@node Anatomy of a Module, Using ellcc, Introduction, Top
+@chapter Anatomy of a Module
+@cindex anatomy
@cindex module skeleton
@cindex skeleton, module
@cindex module format
@cindex format, module
- Each dynamically loadable @value{emacs} extension (hereafter refered to as a
-module) has a certain compulsory format, and must contain several
-pieces of information and several mandatory functions. This chapter
+ Each dynamically loadable @value{emacs} extension (hereafter referred to as a
+module) has a certain compulsory format, and must contain several
+pieces of information and several mandatory functions. This chapter
describes the basic layout of a module, and provides a very simple
sample. The source for this sample can be found in the file
@file{modules/simple/sample.c} in the main @value{emacs} source code tree.
* Required Header File:: Always include <emodules.h>
* Required Functions:: Functions you must always provide
* Required Variables:: Variables whose values you must provide
-* Loading other Modules:: How to load dependant modules
+* Loading other Modules:: How to load dependent modules
@end menu
-@node Required Header File, Required Functions, Annatomy of a Module, Annatomy of a Module
+@node Required Header File, Required Functions, Anatomy of a Module, Anatomy of a Module
@section Required Header File
@cindex required header
@cindex include files
@cindex emodules.h
@cindex config.h
Every module must include the file @file{<emodules.h>}. This
-will include several other @value{emacs} internal header files, and will set up
+will include several other @value{emacs} internal header files, and will set up
certain vital macros. One of the most important files included by
@file{emodules.h} is the generated @file{config.h} file, which contains
all of the required system abstraction macros and definitions. Most
constants defined in @file{config.h}. Please read that file to
familiarize yourself with the macros defined there.
- Depending on exactly what your module will be doing, you will probably
+ Depending on exactly what your module will be doing, you will probably
need to include one or more of the @value{emacs} internal header files. When
-you @code{#include <emodules.h>}, you will get a few of the most important
+you @code{#include <emodules.h>}, you will get a few of the most important
@value{emacs} header files included automatically for you. The files included
are:
@table @file
@item lisp.h
-This file contains most of the macros required for declaring Lisp object
+This file contains most of the macros required for declaring Lisp object
types, macros for accessing Lisp objects, and global variable
declarations.
@item sysdep.h
-All system dependant declarations and abstraction macros live here. You
+All system dependent declarations and abstraction macros live here. You
should never call low level system functions directly. Rather, you
should use the abstraction macros provided in this header file.
manipulating @value{emacs} frames.
@end table
-@node Required Functions, Required Variables, Required Header File, Annatomy of a Module
+@node Required Functions, Required Variables, Required Header File, Anatomy of a Module
@section Required Functions
@cindex initialization
@cindex functions, required
@cindex required functions
Every module requires several initialization functions. It is the
-responsibility of these functions to load in any dependant modules, and to
-declare all variables and functions which are to be made visibile to the
+responsibility of these functions to load in any dependent modules, and to
+declare all variables and functions which are to be made visible to the
@value{emacs} Lisp reader. Each of these functions performs a very specific
task, and they are executed in the correct order by @value{emacs}. All of
these functions are @code{void} functions which take no arguments.
@table @code
@item syms_of_module
@findex syms_of_module
-This required function is responsible for introducing to the Lisp reader
+This required function is responsible for introducing to the Lisp reader
all functions that you have defined in your module using
@code{DEFUN()}. Note that @emph{only} functions are declared here, using
the @code{DEFSUBR()} macro. No variables are declared.
@item modules_of_module
@findex modules_of_module
This optional function should be used to load in any modules which your
-module depends on. The @value{emacs} module loading code makes sure that the
+module depends on. The @value{emacs} module loading code makes sure that the
same module is not loaded twice, so several modules can safely call the
module load function for the same module. Only one copy of each module
(at a given version) will ever be loaded.
functions and variables declared in your module.
@end table
-@node Required Variables, Loading other Modules, Required Functions, Annatomy of a Module
+@node Required Variables, Loading other Modules, Required Functions, Anatomy of a Module
@section Required Variables
@cindex initialization
@cindex variables, required
Not only does a module need to declare the initialization functions
mentioned above, it is also required to provide certain variables which
-the module loading code searches for in order to determine the viability
+the module loading code searches for in order to determine the viability
of a module. You are @emph{not} required to provide these variables in
your source files. They are automatically set up in the module
initialization file by the @code{ellcc} compiler. These variables are
version of the @value{emacs} loading technology that was used to produce the
module being loaded. This version number is completely unrelated to
the @value{emacs} version number, as a given module may quite well work
-regardless of the version of @value{emacs} that was installed at the time the
+regardless of the version of @value{emacs} that was installed at the time the
module was created.
The @value{emacs} modules version is used to differentiate between major
@item emodules_name
This is a short (typically 10 characters or less) name for the module,
and it is used as a suffix for all of the required functions. This is
-also the name by which the module is recognised when loading dependant
+also the name by which the module is recognized when loading dependent
modules. The name does not necessarily have to be the same as the
physical file name, although keeping the two names in sync is a pretty
-good idea. The name must not be empty, and it must be a valid part of a
-C function name. The value of this variable is appended to the function
+good idea. The name must not be empty, and it must be a valid part of a
+C function name. The value of this variable is appended to the function
names @code{syms_of_}, @code{vars_of_}, @code{modules_of_} and
@code{docs_of_} to form the actual function names that the module
loading code looks for when loading a module.
@code{--mod-title} argument to @code{ellcc}.
@end table
-@node Loading other Modules, , Required Variables, Annatomy of a Module
+@node Loading other Modules, , Required Variables, Anatomy of a Module
@section Loading other Modules
-@cindex dependancies
+@cindex dependencies
@findex modules_of_module
@findex emodules_load
@code{modules_of_module} to load in any modules which the current module
depends on. If the module is stand-alone, and does not depend on other
modules, then this function can be left empty or even undeclared.
-However, if it does have dependnacies, it must call
+However, if it does have dependencies, it must call
@code{emodules_load}:
@example
@end cartouche
@end example
-The first argument @var{module} is the name of the actual shared object
+The first argument @var{module} is the name of the actual shared object
or DLL. You can omit the @file{.so}, @file{.ell} or @file{.dll}
extension of you wish. If you do not specify an absolute path name,
then the same rules as apply to loading Lisp modules are applied when
searching for the module. If the module cannot be found in any of the
standard places, and an absolute path name was not specified,
-@code{emodules_load} will signal an error and loading of the module
+@code{emodules_load} will signal an error and loading of the module
will stop.
The second argument (@var{modname}) is the module name to load, and
must match the contents of the variable @var{emodule_name} in the
-module to be loaded. A mis-match will cause the module load to fail. If
+module to be loaded. A mis-match will cause the module load to fail. If
this parameter is @code{NULL} or empty, then no checks are performed
against the target module's @var{emodule_name} variable.
or empty, and the match fails, then the load of the module will fail.
@code{emodules_load} can be called recursively. If, at any point
-during the loading of modules a failure is encountered, then all modules
+during the loading of modules a failure is encountered, then all modules
that were loaded since the top level call to @code{emodules_load}
will be unloaded. This means that if any child modules fail to load,
then their parents will also fail to load. This does not include
previous successful calls to @code{emodules_load} at the top level.
-@node Using ellcc, Defining Functions, Annatomy of a Module, Top
+@node Using ellcc, Defining Functions, Anatomy of a Module, Top
@chapter Using @code{ellcc}
@cindex @code{ellcc}
@cindex module compiler
an Emacs module rather than a static C object.
@code{ellcc} has three distinct modes of operation. It can be run in
-compile, link or initialization mode. These modes are discussed in more
+compile, link or initialization mode. These modes are discussed in more
detail below. If you want @code{ellcc} to show the commands it is
executing, you can specify the option @code{--mode=verbose} to
@code{ellcc}. Specifying this option twice will enable certain extra
@cindex compiling
By default, @code{ellcc} is in @dfn{compile} mode. This means that it
-assumes that all of the command line arguments are C compiler arguments,
+assumes that all of the command line arguments are C compiler arguments,
and that you want to compile the specified source file or files. You
can force compile mode by specifying the @code{--mode=compile} argument
to @code{ellcc}.
same exit codes and messages that your C compiler does.
By far the easiest way to compile modules is to construct a
-@file{Makefile} as you would for a normal program, and simply insert, at
+@file{Makefile} as you would for a normal program, and simply insert, at
some appropriate place something similar to:
@example
and variables passed as static strings in the source code, the
documentation is included as a C comment. A special program, called
@file{make-docfile}, is used to scan the source code files and extract
-the documentation from these comments, producing the @value{emacs} @file{DOC}
+the documentation from these comments, producing the @value{emacs} @file{DOC}
file, which the internal help engine scans when the documentation for a
function or variable is requested.
Due to the internal construction of Lisp objects, subrs and other such
things, adding documentation for a compiled function or variable in a
compiled module, at any time after @value{emacs} has been @dfn{dumped} is
-somewhat problematic. Fortunately, as a module writer you are insulated
+somewhat problematic. Fortunately, as a module writer you are insulated
from the difficulties thanks to your friend @code{ellcc} and some
internal trickery in the module loading code. This is all done using
the @dfn{initialization} mode of @code{ellcc}.
The result of running @code{ellcc} in initialization mode is a C source
file which you compile with (you guessed it) @code{ellcc} in compile
mode. Initialization mode is where you set the module name, version,
-title and gather together all of the documentaion strings for the
-functions and vairables in your module. There are several options that
+title and gather together all of the documentation strings for the
+functions and variables in your module. There are several options that
you are required to pass @code{ellcc} in initialization mode, the first
of which is the mode switch itself, @code{--mode=init}.
screen.
Following all of these parameters, you need to provide the list of all
-source code modules that make up your module. These are the files which
-are scanned by @file{make-docfile}, and provide the information required
+source code modules that make up your module. These are the files which
+are scanned by @file{make-docfile}, and provide the information required
to populate the @code{docs_of_module} function. Below is a sample
@file{Makefile} fragment which indicates how all of this is used.
searched for a given module when the user attempts to load it. The
valid extensions that the loader attempts to use are @file{.so},
@file{.ell} and @file{.dll}. You can use any of these extensions,
-although @file{.ell} is the prefered extension.
+although @file{.ell} is the preferred extension.
@node Link Mode, Other ellcc options, Initialization Mode, Using ellcc
@section Link Mode
@cindex linking
Once all of your source code files have been compiled (including the
-generated init file) you need to link them all together to created the
+generated init file) you need to link them all together to create the
loadable module. To do this, you invoke @code{ellcc} in link mode, by
-pasing the @code{--mode-link} command. You need to specify the final
-output file using the @code{--mod-output=NAME} command, but other than
+passing the @code{--mode-link} option. You need to specify the final
+output file using the @code{--mod-output=NAME} option, but other than
that all other arguments are passed on directly to the system compiler
or linker, along with any other required arguments to create the
loadable module.
Aside from the three main @code{ellcc} modes described above,
@code{ellcc} can accept several other options. These are typically used
-in a @file{Makefile} to determine installation paths. @code{ellcc} also
+in a @file{Makefile} to determine installation paths. @code{ellcc} also
allows you to over-ride several of its built-in compiler and linker
options using environment variables. Here is the complete list of
options that @code{ellcc} accepts.
@item --mode=init
Used to create the documentation function and to initialize other
-required variables. Produces a C source file that must be compiled with
+required variables. Produces a C source file that must be compiled with
@code{ellcc} in compile mode before linking the final module.
@item --mode=verbose
Enables verbose mode. This will show you the commands that are being
-executed, as well as the version number of @code{ellcc}. If you specify
+executed, as well as the version number of @code{ellcc}. If you specify
this option twice, then some extra debugging information is displayed.
@item --mod-name=NAME
-Sets the short internaml module @var{NAME} to the string specified,
+Sets the short internal module @var{NAME} to the string specified,
which must consist only of valid C identifiers. Required during
initialization mode.
final loadable module to @var{FILENAME}.
@item --mod-location
-This will print the name of the standard module installation path on the
+This will print the name of the standard module installation path on the
standard output and immediately exit @code{ellcc}. Use this option to
determine the directory prefix of where you should install your modules.
This will print the name of the site specific module location and exit.
@item --mod-archdir
-Prints the name of the root of the architecture-dependant directory that
-@value{emacs} searches for architecture-dependant files.
+Prints the name of the root of the architecture-dependent directory that
+@value{emacs} searches for architecture-dependent files.
@item --mod-config
-Prints the name of the configuration for which @value{emacs} and @code{ellcc}
+Prints the name of the configuration for which @value{emacs} and @code{ellcc}
were compiled.
@end table
During its normal operation, @code{ellcc} uses the compiler and linker
flags that were determined at the time @value{emacs} was configured. In
-certain rare circumstances you may wish to over-ride the flags passed to
+certain rare circumstances you may wish to over-ride the flags passed to
the compiler or linker, and you can do so using environment variables.
-The table below lists all of the environment variables that @code{ellcc}
-recognises.
+The table below lists all of the environment variables that @code{ellcc}
+recognizes.
@table @code
@item ELLCC
One of the main reasons you would ever write a module is to
provide one or more @dfn{functions} for the user or the editor to use.
-The term
+The term
@dfn{function} is a bit overloaded here, as it refers to both a C
function and the way it appears to Lisp, which is a @dfn{subroutine}, or
simply a @dfn{subr}. A Lisp subr is also known as a Lisp primitive, but
that term applies less to dynamic modules. @xref{Writing Lisp
Primitives,,,internals,@value{emacs} Internals Manual}, for details on how to
declare functions. You should familiarize yourself with the
-instructions there. The format of the function declaration is identical
+instructions there. The format of the function declaration is identical
in modules.
- Normal Lisp primitives document the functions they defining by including
+ Normal Lisp primitives document the functions they defining by including
the documentation as a C comment. During the build process, a program
called @file{make-docfile} is run, which will extract all of these
comments, build up a single large documentation file, and will store
When using @code{DEFUN} in normal @value{emacs} C code, the sixth
``parameter'' is a C comment which documents the function. For a
dynamic module, we of course need to convert the C comment to a usable
-string, and we need to set the documentation pointer of the subr to this
+string, and we need to set the documentation pointer of the subr to this
string. As a module programmer, you don't actually need to do any work
for this to happen. It is all taken care of in the
@code{docs_of_module} function created by @code{ellcc}.
@cindex functions, Lisp
@cindex functions, defining
- Although the full syntax of a function declaration is discussed in the
+ Although the full syntax of a function declaration is discussed in the
@value{emacs} internals manual in greater depth, what follows is a brief
description of how to define and implement a new Lisp primitive in a
module. This is done using the @code{DEFUN} macro. Here is a small
DEFUN ("my-function", Fmy_function, 1, 1, "FFile name: ", /*
Sample Emacs primitive function.
-The specified FILE is frobricated before it is fnozzled.
+The specified FILE is frobnicated before it is fnozzled.
*/
(file))
@{
@end example
The first argument is the name of the function as it will appear to the
-Lisp reader. This must be provided as a string. The second argument is
+Lisp reader. This must be provided as a string. The second argument is
the name of the actual C function that will be created. This is
-typically the Lisp function name with a preceding capital @code{F}, with
+typically the Lisp function name with a preceding capital @code{F}, with
hyphens converted to underscores. This must be a valid C function
name. Next come the minimum and maximum number of arguments,
respectively. This is used to ensure that the correct number of
@cindex functions, declaring
Simply writing the code for a function is not enough to make it
-availible to the Lisp reader. You have to, during module
+available to the Lisp reader. You have to, during module
initialization, let the Lisp reader know about the new function. This
is done by calling @code{DEFSUBR} with the name of the function. This
is the sole purpose of the initialization function
Rarely will you write a module that only contains functions. It is
common to also provide variables which can be used to control the
-behaviour of the function, or store the results of the function being
+behavior of the function, or store the results of the function being
executed. The actual C variable types are the same for modules
and internal @value{emacs} primitives, and the declaration of the variables
is identical.
- @xref{Adding Global Lisp Variables,,,internals,XEmacs Internals Manual},
+ @xref{Adding Global Lisp Variables,,,internals,XEmacs Internals Manual},
for more information on variables and naming conventions.
Once your variables are defined, you need to initialize them and make
the Lisp reader aware of them. This is done in the
@code{vars_of_module} initialization function using special @value{emacs}
-macros such as @code{DEFVAR_LISP}, @code{DEFVAR_BOOL}, @code{DEFVAR_INT}
-etc. The best way to see how to use these macros is to look at existing
+macros such as @code{DEFVAR_LISP}, @code{DEFVAR_BOOL}, @code{DEFVAR_INT}
+etc. The best way to see how to use these macros is to look at existing
source code, or read the internals manual.
One @emph{very} important difference between @value{emacs} variables and
module variables is how you use pure space. Simply put, you
@strong{never} use pure space in @value{emacs} modules. The pure space
-storage is of a limited size, and is initialized propperly during the
+storage is of a limited size, and is initialized properly during the
dumping of @value{emacs}. Because variables are being added dynamically to
an already running @value{emacs} when you load a module, you cannot use pure
space. Be warned: @strong{do not use pure space in modules. Repeat, do
@setfilename ../info/info.info
@settitle Info
@comment %**end of header
-@comment $Id: info.texi,v 1.4.2.4 2000/01/18 07:27:42 yoshiki Exp $
+@comment $Id: info.texi,v 1.4.2.5 2000/09/13 10:57:18 martinb Exp $
@dircategory Texinfo documentation system
@direntry
@node Emacs Info Variables, , Checking, Advanced Info
@section Emacs Info-mode Variables
-The following variables may modify the behaviour of Info-mode in Emacs;
+The following variables may modify the behavior of Info-mode in Emacs;
you may wish to set one or several of these variables interactively, or
in your @file{~/.emacs} init file. @xref{Examining, Examining and
Setting Variables, Examining and Setting Variables, xemacs, XEmacs
When the Lisp initialization code is done, the C code enters the event
loop, and stays there for the duration of the XEmacs process. The code
-for the event loop is contained in @file{keyboard.c}, and is called
+for the event loop is contained in @file{cmdloop.c}, and is called
@code{Fcommand_loop_1()}. Note that this event loop could very well be
written in Lisp, and in fact a Lisp version exists; but apparently,
doing this makes XEmacs run noticeably slower.
@example
-crt0.c
+ecrt0.c
lastfile.c
pre-crt0.c
@end example
@example
-prefix-args.c
-@end example
-
-This is actually the source for a small, self-contained program
-used during building.
-
-
-@example
universe.h
@end example
@section Basic Lisp Modules
@example
-emacsfns.h
lisp-disunion.h
lisp-union.h
lisp.h
@example
event-Xt.c
+event-msw.c
event-stream.c
event-tty.c
+events-mod.h
+gpmevent.c
+gpmevent.h
events.c
events.h
@end example
@example
-keyboard.c
+cmdloop.c
@end example
-@file{keyboard.c} contains functions that implement the actual editor
+@file{cmdloop.c} contains functions that implement the actual editor
command loop---i.e. the event loop that cyclically retrieves and
dispatches events. This code is also rather tricky, just like
@file{event-stream.c}.
@section Modules for the Basic Displayable Lisp Objects
@example
-device-ns.h
-device-stream.c
-device-stream.h
+console-msw.c
+console-msw.h
+console-stream.c
+console-stream.h
+console-tty.c
+console-tty.h
+console-x.c
+console-x.h
+console.c
+console.h
+@end example
+
+These modules implement the @dfn{console} Lisp object type. A console
+contains multiple display devices, but only one keyboard and mouse.
+Most of the time, a console will contain exactly one device.
+
+Consoles are the top of a lisp object inclusion hierarchy. Consoles
+contain devices, which contain frames, which contain windows.
+
+
+
+@example
+device-msw.c
device-tty.c
-device-tty.h
device-x.c
-device-x.h
device.c
device.h
@end example
@example
-frame-ns.h
+frame-msw.c
frame-tty.c
frame-x.c
-frame-x.h
frame.c
frame.h
@end example
@example
bitmaps.h
-glyphs-ns.h
+glyphs-eimage.c
+glyphs-msw.c
+glyphs-msw.h
+glyphs-widget.c
glyphs-x.c
glyphs-x.h
glyphs.c
@example
-objects-ns.h
+objects-msw.c
+objects-msw.h
objects-tty.c
objects-tty.h
objects-x.c
@example
+menubar-msw.c
+menubar-msw.h
menubar-x.c
menubar.c
+menubar.h
@end example
@example
+scrollbar-msw.c
+scrollbar-msw.h
scrollbar-x.c
scrollbar-x.h
scrollbar.c
@example
+toolbar-msw.c
toolbar-x.c
toolbar.c
toolbar.h
@end example
These modules decode GIF-format image files, for use with glyphs.
+These files were removed due to Unisys patent infringement concerns.
@example
redisplay-output.c
+redisplay-msw.c
redisplay-tty.c
redisplay-x.c
redisplay.c
Similar to other subsystems in XEmacs, lstreams are separated into
generic functions and a set of methods for the different types of
lstreams. @file{lstream.c} provides implementations of many different
-types of streams; others are provided, e.g., in @file{mule-coding.c}.
+types of streams; others are provided, e.g., in @file{file-coding.c}.
-@example
-msdos.c
-msdos.h
-@end example
-
-These modules are used for MS-DOS support, which does not work in
-XEmacs.
-
-
-
@node Modules for Interfacing with X Windows, Modules for Internationalization, Modules for Interfacing with the Operating System, A Summary of the Various XEmacs Modules
@section Modules for Interfacing with X Windows
@example
-xselect.c
+select-msw.c
+select-x.c
+select.c
+select.h
@end example
@cindex selections
mule-ccl.c
mule-charset.c
mule-charset.h
-mule-coding.c
-mule-coding.h
+file-coding.c
+file-coding.h
mule-mcpath.c
mule-mcpath.h
mule-wnnfns.c
just Asian languages (although they are generally the most complicated
to support). This code is still in beta.
-@file{mule-charset.*} and @file{mule-coding.*} provide the heart of the
+@file{mule-charset.*} and @file{file-coding.*} provide the heart of the
XEmacs MULE support. @file{mule-charset.*} implements the @dfn{charset}
Lisp object type, which encapsulates a character set (an ordered one- or
two-dimensional set of characters, such as US ASCII or JISX0208 Japanese
Kanji).
-@file{mule-coding.*} implements the @dfn{coding-system} Lisp object
+@file{file-coding.*} implements the @dfn{coding-system} Lisp object
type, which encapsulates a method of converting between different
encodings. An encoding is a representation of a stream of characters,
possibly from multiple character sets, using a stream of bytes or words,
file. To create one of these, copy an existing model and modify as
necessary.
+ @strong{Please note:} If you define an lrecord in an external
+dynamically-loaded module, you must use @code{DECLARE_EXTERNAL_LRECORD},
+@code{DEFINE_EXTERNAL_LRECORD_IMPLEMENTATION}, and
+@code{DEFINE_EXTERNAL_LRECORD_SEQUENCE_IMPLEMENTATION} instead of the
+non-EXTERNAL forms. These macros will dynamically add new type numbers
+to the global enum that records them, whereas the non-EXTERNAL forms
+assume that the programmer has already inserted the correct type numbers
+into the enum's code at compile-time.
+
The various methods in the lrecord implementation structure are:
@enumerate
tree recursively.
This has desirable properties such as lw_modify_all_widgets which is
-called from glyphs-x.c and updates all the properties of a widget
+called from @file{glyphs-x.c} and updates all the properties of a widget
without having to know what the widget is or what toolkit it is from.
Unfortunately this also has hairy properties such as making the lwlib
code quite complex. And of course lwlib has to know at some level what
Buffers in Emacs editing are objects that have distinct names and hold
text that can be edited. Buffers appear to Lisp programs as a special
-data type. You can think of the contents of a buffer as an extendable
+data type. You can think of the contents of a buffer as an extendible
string; insertions and deletions may occur in any part of the buffer.
@xref{Text}.
@defun valid-device-type-p device-type
This function returns whether @var{device-type} (which should be a symbol)
-species a valid device type.
+specifies a valid device type.
@end defun
@defun valid-device-class-p device-class
This function returns whether @var{device-class} (which should be a symbol)
-species a valid device class.
+specifies a valid device class.
@end defun
@defvar terminal-device
permissions @var{mode}. @var{access} can be any combination of @code{r}
@code{w} and @code{+}, for read, write, and creation flags.
-@var{type} can have the value @code{'dbm} or @code{'berkeley_db} to
+@var{type} can have the value @code{'dbm} or @code{'berkeley-db} to
select the type of database file to use. (Note: XEmacs may not
support both of these types.)
For a @var{type} of @code{'dbm}, there are no subtypes, so
@var{subtype} should be @code{nil}.
-For a @var{type} of @code{'berkeley_db}, the following subtypes are
+For a @var{type} of @code{'berkeley-db}, the following subtypes are
available: @code{'hash}, @code{'btree}, and @code{'recno}. See the
-manpages for the Berkeley DB functions to more information about these
+manpages for the Berkeley DB functions for more information about these
types.
@end defun
Keyword @code{:rehash-threshold} must be a float between 0.0 and 1.0,
and specifies the load factor of the hash table which triggers enlarging.
-Keyword @code{:weakness} can be @code{nil} (default), @code{t},
-@code{key} or @code{value}.
-
-A weak hash table is one whose pointers do not count as GC referents:
-for any key-value pair in the hash table, if the only remaining pointer
-to either the key or the value is in a weak hash table, then the pair
-will be removed from the hash table, and the key and value collected.
-A non-weak hash table (or any other pointer) would prevent the object
-from being collected.
+Non-standard keyword @code{:weakness} can be @code{nil} (default),
+@code{t}, @code{key-and-value}, @code{key}, @code{value} or
+@code{key-or-value}. @code{t} is an alias for @code{key-and-value}.
+
+A key-and-value-weak hash table, also known as a fully-weak or simply
+as a weak hash table, is one whose pointers do not count as GC
+referents: for any key-value pair in the hash table, if the only
+remaining pointer to either the key or the value is in a weak hash
+table, then the pair will be removed from the hash table, and the key
+and value collected. A non-weak hash table (or any other pointer)
+would prevent the object from being collected.
A key-weak hash table is similar to a fully-weak hash table except that
a key-value pair will be removed only if the key remains unmarked
unmarked outside of weak hash tables. The pair will remain in the
hash table if the value is pointed to by something other than a weak
hash table, even if the key is not.
+
+A key-or-value-weak hash table is similar to a fully-weak hash table except
+that a key-value pair will be removed only if the value and the key remain
+unmarked outside of weak hash tables. The pair will remain in the
+hash table if the value or key are pointed to by something other than a weak
+hash table, even if the other is not.
@end defun
@defun copy-hash-table hash-table
(Otherwise, you'd have to explicitly map over the hash table every so
often and remove unnecessary elements.)
-There are three types of weak hash tables:
+There are four types of weak hash tables:
@table @asis
-@item fully weak hash tables
-In these hash tables, a pair disappears if either the key or the value
-is unreferenced outside of the table.
+@item key-and-value-weak hash tables
+In these hash tables, also known as fully weak or simply as weak hash
+tables, a pair disappears if either the key or the value is unreferenced
+outside of the table.
@item key-weak hash tables
In these hash tables, a pair disappears if the key is unreferenced outside
of the table, regardless of how the value is referenced.
@item value-weak hash tables
In these hash tables, a pair disappears if the value is unreferenced outside
of the table, regardless of how the key is referenced.
+@item key-or-value-weak hash tables
+In these hash tables, a pair disappears if both the key and the value
+are unreferenced outside of the table.
@end table
Also see @ref{Weak Lists}.
This command unloads the library that provided feature @var{feature}.
It undefines all functions, macros, and variables defined in that
library with @code{defconst}, @code{defvar}, @code{defun},
-@code{defmacro}, @code{defsubst}, @code{definf-function} and
+@code{defmacro}, @code{defsubst}, @code{define-function} and
@code{defalias}. It then restores any autoloads formerly associated
with those symbols. (Loading saves these in the @code{autoload}
property of the symbol.)
@end example
@end defun
-@defun read-command prompt &optinal default-value
+@defun read-command prompt &optional default-value
This function reads the name of a command and returns it as a Lisp
symbol. The argument @var{prompt} is used as in
@code{read-from-minibuffer}. Recall that a command is anything for
byte 0x8F.
The advantage of a modal encoding is that it is generally more
-space-efficient, and is easily extendable because there are essentially
+space-efficient, and is easily extendible because there are essentially
an arbitrary number of escape sequences that can be created. The
disadvantage, however, is that it is much more difficult to work with
if it is not being processed in a sequential manner. In the non-modal
@c -*-texinfo-*-
@c This is part of the XEmacs Lisp Reference Manual.
-@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
+@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
@c See the file lispref.texi for copying conditions.
@setfilename ../../info/processes.info
@node Processes, System Interface, Databases, Top
argument, @var{args}. The @var{args} must all be strings, and they are
supplied to @var{program} as separate command line arguments. Wildcard
characters and other shell constructs are not allowed in these strings,
-since they are passed directly to the specified program.
+since they are passed directly to the specified program.
@strong{Please note:} The argument @var{program} contains only the
name of the program; it may not contain any command-line arguments. You
specify overrides for it with @code{process-environment}. @xref{System
Environment}.
-@defvar exec-directory
+@defvar exec-directory
@pindex wakeup
The value of this variable is the name of a directory (a string) that
contains programs that come with XEmacs, that are intended for XEmacs
@smallexample
@group
-(call-process-region
- start end
+(call-process-region
+ start end
shell-file-name ; @r{Name of program.}
nil ; @r{Do not delete region.}
buffer ; @r{Send output to @code{buffer}.}
section. XEmacs also sends signals automatically at certain times:
killing a buffer sends a @code{SIGHUP} signal to all its associated
processes; killing XEmacs sends a @code{SIGHUP} signal to all remaining
-processes. (@code{SIGHUP} is a signal that usually indicates that the
-user hung up the phone.)
+processes. (@code{SIGHUP} is a signal that indicates that the
+connection between the user and the process is broken, for example if a
+connection via a telephone line is hung up.)
Each of the signal-sending functions takes two optional arguments:
-@var{process-name} and @var{current-group}.
+@var{process} and @var{current-group}.
- The argument @var{process-name} must be either a process, the name of
-one, or @code{nil}. If it is @code{nil}, the process defaults to the
-process associated with the current buffer. An error is signaled if
-@var{process-name} does not identify a process.
+ The argument @var{process} must be either a process or a buffer,
+the name of one, or @code{nil}. If it is @code{nil}, the process
+defaults to the process associated with the current buffer. An error is
+signaled if @var{process} does not identify a process.
The argument @var{current-group} is a flag that makes a difference
when you are running a job-control shell as an XEmacs subprocess. If it
-is non-@code{nil}, then the signal is sent to the current process-group
-of the terminal that XEmacs uses to communicate with the subprocess. If
-the process is a job-control shell, this means the shell's current
-subjob. If it is @code{nil}, the signal is sent to the process group of
-the immediate subprocess of XEmacs. If the subprocess is a job-control
-shell, this is the shell itself.
+is non-@code{nil}, then the signal is sent to the current foreground
+process group of the terminal that XEmacs uses to communicate with the
+subprocess. If the process is a job-control shell, this means the
+shell's current subjob. If it is @code{nil}, the signal is sent to the
+process group of the immediate subprocess of XEmacs. If the subprocess
+is a job-control shell, this is the shell itself.
The flag @var{current-group} has no effect when a pipe is used to
communicate with the subprocess, because the operating system does not
job-control shells won't work when a pipe is used. See
@code{process-connection-type} in @ref{Asynchronous Processes}.
-@defun interrupt-process &optional process-name current-group
-This function interrupts the process @var{process-name} by sending the
-signal @code{SIGINT}. Outside of XEmacs, typing the ``interrupt
-character'' (normally @kbd{C-c} on some systems, and @code{DEL} on
-others) sends this signal. When the argument @var{current-group} is
-non-@code{nil}, you can think of this function as ``typing @kbd{C-c}''
-on the terminal by which XEmacs talks to the subprocess.
+ Some of the functions below take a @var{signal} argument, which
+identifies a signal to be sent. It must be either an integer or a
+symbol which names the signal, like @code{SIGSEGV}.
+
+@defun process-send-signal signal &optional process current-group
+This function sends the signal @var{signal} to the process @var{process}.
+The following functions can be implemented in terms of
+@code{process-send-signal}.
+@end defun
+
+@defun interrupt-process &optional process current-group
+This function interrupts the process @var{process} by sending the signal
+@code{SIGINT}. Outside of XEmacs, typing the ``interrupt character''
+(normally @kbd{C-c}) sends this signal. When the argument
+@var{current-group} is non-@code{nil}, you can think of this function as
+``typing @kbd{C-c}'' on the terminal by which XEmacs talks to the
+subprocess.
@end defun
-@defun kill-process &optional process-name current-group
-This function kills the process @var{process-name} by sending the
+@defun kill-process &optional process current-group
+This function kills the process @var{process} by sending the
signal @code{SIGKILL}. This signal kills the subprocess immediately,
and cannot be handled by the subprocess.
@end defun
-@defun quit-process &optional process-name current-group
+@defun quit-process &optional process current-group
This function sends the signal @code{SIGQUIT} to the process
-@var{process-name}. This signal is the one sent by the ``quit
-character'' (usually @kbd{C-b} or @kbd{C-\}) when you are not inside
-XEmacs.
+@var{process}. This signal is the one sent by the ``quit
+character'' (usually @kbd{C-\}) when you are not inside XEmacs.
@end defun
-@defun stop-process &optional process-name current-group
-This function stops the process @var{process-name} by sending the
+@defun stop-process &optional process current-group
+This function stops the process @var{process} by sending the
signal @code{SIGTSTP}. Use @code{continue-process} to resume its
execution.
on the terminal XEmacs uses to communicate with the subprocess.
@end defun
-@defun continue-process &optional process-name current-group
+@defun continue-process &optional process current-group
This function resumes execution of the process @var{process} by sending
-it the signal @code{SIGCONT}. This presumes that @var{process-name} was
+it the signal @code{SIGCONT}. This presumes that @var{process} was
stopped previously.
@end defun
-@c Emacs 19 feature
@defun signal-process pid signal
-This function sends a signal to process @var{pid}, which need not be
-a child of XEmacs. The argument @var{signal} specifies which signal
-to send; it should be an integer.
+This function sends a signal to the process with process id @var{pid},
+which need not be a child of XEmacs. The argument @var{signal}
+specifies which signal to send.
@end defun
@node Output from Processes
The string describing the event looks like one of the following:
@itemize @bullet
-@item
+@item
@code{"finished\n"}.
@item
@dfn{non-greedy} quantifier, a regexp construct borrowed from Perl.
@c Did perl get this from somewhere? What's the real history of *? ?
-This construct very useful for when you want to match the text inside a
-pair of delimiters. For instance, @samp{/\*.*?\*/} will match C
-comments in a string. This could not be achieved without the use of
-greedy quantifier.
+This construct is very useful for when you want to match the text inside
+a pair of delimiters. For instance, @samp{/\*.*?\*/} will match C
+comments in a string. This could not easily be achieved without the use
+of a non-greedy quantifier.
This construct has not been available prior to XEmacs 20.4. It is not
available in FSF Emacs.
@item +?
@cindex @samp{+?} in regexp
-is the @samp{+} analog to @samp{*?}.
+is the non-greedy version of @samp{+}.
+
+@item ??
+@cindex @samp{??} in regexp
+is the non-greedy version of @samp{?}.
@item \@{n,m\@}
@c Note the spacing after the close brace is deliberate.
more than @var{m} times. This syntax is supported by most Unix regexp
utilities, and has been introduced to XEmacs for the version 20.3.
+Unfortunately, the non-greedy version of this quantifier does not exist
+currently, although it does in Perl.
+
@item [ @dots{} ]
@cindex character set (in regexp)
@cindex @samp{[} in regexp
substring to be recorded for future reference.
This is useful when you need a lot of grouping @samp{\( @dots{} \)}
-constructs, but only want to remember one or two. Then you can use
-not want to remember them for later use with @code{match-string}.
+constructs, but only want to remember one or two -- or if you have
+more than nine groupings and need to use backreferences to refer to
+the groupings at the end.
Using @samp{\(?: @dots{} \)} rather than @samp{\( @dots{} \)} when you
don't need the captured substrings ought to speed up your programs some,
must do. The actual performance gain to be observed has not been
measured or quantified as of this writing.
@c This is used to good advantage by the font-locking code, and by
-@c `regexp-opt.el'. ... It will be. It's not yet, but will be.
+@c `regexp-opt.el'.
The shy grouping operator has been borrowed from Perl, and has not been
available prior to XEmacs 20.3, nor is it available in FSF Emacs.
@defun window-point window
This function returns the current position of point in @var{window}.
-For a nonselected window, this is the value point would have (in that
+For a non-selected window, this is the value point would have (in that
window's buffer) if that window were selected.
When @var{window} is the selected window and its buffer is also the
@finalout
@titlepage
@title XEmacs FAQ
-@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 2000/07/08 09:14:11 $
+@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 2000/09/19 07:50:41 $
@sp 1
@author Tony Rossini <rossini@@biostat.washington.edu>
@author Ben Wing <ben@@xemacs.org>
This is the guide to the XEmacs Frequently Asked Questions list---a
compendium of questions and answers pertaining to one of the finest
-programs ever written. It is much more than just a Text Editor.
+programs ever written. XEmacs is much more than just a Text Editor.
-This FAQ is freely redistributable. I take no liability for the
-correctness and safety of any procedures or advice given here. This
-FAQ is distributed in the hope that it will be useful, but WITHOUT ANY
-WARRANTY; without even the implied warranty of MERCHANTABILITY or
-FITNESS FOR A PARTICULAR PURPOSE.
+This FAQ is freely redistributable. This FAQ is distributed in the hope
+that it will be useful, but WITHOUT ANY WARRANTY; without even the
+implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
If you have a Web browser, the official hypertext version is at
@iftex
@*
@end iftex
-@uref{http://www.xemacs.org/faq/xemacs-faq.html}.
-
-This version is somewhat nicer than the unofficial hypertext versions
-that are archived at Utrecht, Oxford, Smart Pages, and other FAQ
-archives.
+@uref{http://www.xemacs.org/faq/xemacs-faq.html}
@ifset CANONICAL
@html
* Q1.0.4:: Why Another Version of Emacs?
* Q1.0.5:: Why Haven't XEmacs and GNU Emacs Merged?
* Q1.0.6:: Where can I get help?
-* Q1.0.7:: Where is the mailing list archived?
+* Q1.0.7:: Where are the mailing lists archived?
* Q1.0.8:: How do you pronounce XEmacs?
* Q1.0.9:: What does XEmacs look like?
* Q1.0.10:: Is there a port of XEmacs to Microsoft ('95 or NT)?
* Q1.2.3:: Who contributed to the FAQ in the past?
Internationalization:
-* Q1.3.1:: What is the status of XEmacs v20?
-* Q1.3.2:: What is the status of Asian-language support, aka @var{mule}?
+* Q1.3.1:: What is the status of internationalization support aka MULE (including Asian language support?
+* Q1.3.2:: How can I help with internationalization?
* Q1.3.3:: How do I type non-ASCII characters?
* Q1.3.4:: Can XEmacs messages come out in a different language?
-* Q1.3.5:: Please explain the various input methods in MULE/XEmacs 20.0
-* Q1.3.6:: How do I portably code for MULE/XEmacs 20.0?
+* Q1.3.5:: Please explain the various input methods in MULE/XEmacs
+* Q1.3.6:: How do I portably code for MULE/XEmacs?
* Q1.3.7:: How about Cyrillic Modes?
Getting Started:
* Q5.1.4:: What is the performance hit of @code{let}?
* Q5.1.5:: What is the recommended use of @code{setq}?
* Q5.1.6:: What is the typical misuse of @code{setq} ?
-* Q5.1.7:: I like the the @code{do} form of cl, does it slow things down?
+* Q5.1.7:: I like the @code{do} form of cl, does it slow things down?
* Q5.1.8:: I like recursion, does it slow things down?
* Q5.1.9:: How do I put a glyph as annotation in a buffer?
* Q5.1.10:: @code{map-extents} won't traverse all of my extents!
* Q1.0.4:: Why Another Version of Emacs?
* Q1.0.5:: Why Haven't XEmacs and GNU Emacs Merged?
* Q1.0.6:: Where can I get help?
-* Q1.0.7:: Where is the mailing list archived?
+* Q1.0.7:: Where are the mailing lists archived?
* Q1.0.8:: How do you pronounce XEmacs?
* Q1.0.9:: What does XEmacs look like?
* Q1.0.10:: Is there a port of XEmacs to Microsoft ('95 or NT)?
* Q1.2.3:: Who contributed to the FAQ in the past?
Internationalization:
-* Q1.3.1:: What is the status of XEmacs v20?
-* Q1.3.2:: What is the status of Asian-language support, aka @var{mule}?
+* Q1.3.1:: What is the status of internationalization support aka MULE (including Asian language support?
+* Q1.3.2:: How can I help with internationalization?
* Q1.3.3:: How do I type non-ASCII characters?
* Q1.3.4:: Can XEmacs messages come out in a different language?
-* Q1.3.5:: Please explain the various input methods in MULE/XEmacs 20.0
-* Q1.3.6:: How do I portably code for MULE/XEmacs 20.0?
+* Q1.3.5:: Please explain the various input methods in MULE/XEmacs
+* Q1.3.6:: How do I portably code for MULE/XEmacs?
* Q1.3.7:: How about Cyrillic Modes?
Getting Started:
@node Q1.0.2, Q1.0.3, Q1.0.1, Introduction
@unnumberedsubsec Q1.0.2: What is the current version of XEmacs?
-XEmacs 21.1.8 is the current stable version of XEmacs.
-
-XEmacs 20.4 is a minor upgrade from 20.3, containing many bugfixes. It
-was released in February 1998.
+XEmacs versions 21.1.* are releases made from the current stable
+sources. XEmacs versions 21.2.* are releases made from the development
+sources. Check at @uref{http://www.xemacs.org} for the current minor
+version.
XEmacs 19.16 was the last release of v19, released in November, 1997,
which was also the last version without international language support.
@samp{unsubscribe} to be removed.
@node Q1.0.7, Q1.0.8, Q1.0.6, Introduction
-@unnumberedsubsec Q1.0.7: Where is the mailing list archived?
+@unnumberedsubsec Q1.0.7: Where are the mailing lists archived?
The archives can be found at @uref{http://www.xemacs.org/Lists/Archive}
TeX, you can generate your own manual from the XEmacs sources.
HTML and Postscript versions of XEmacs manuals may be available from the
-XEmacs web site in the future.
-
+XEmacs web site in the future. Send requests to @email{faq@@xemacs.org}.
@node Q1.1.1, Q1.1.2, Q1.0.14, Introduction
@unnumberedsec 1.1: Policies
Please make sure that @samp{XEmacs FAQ} appears on the Subject: line.
If you think you have a better way of answering a question, or think a
question should be included, we'd like to hear about it. Questions and
-answers included into the FAQ will be edited for spelling and grammar,
+answers included into the FAQ will be edited for spelling and grammar
and will be attributed. Answers appearing without attribution are
-either from versions of the FAQ dated before May 1996, or are from one
-of the four people listed at the top of this document. Answers quoted
-from Usenet news articles will always be attributed, regardless of the
-author.
+either from versions of the FAQ dated before May 1996 or are from
+previous FAQ maintainers. Answers quoted from Usenet news articles will
+always be attributed, regardless of the author.
@node Q1.1.2, Q1.1.3, Q1.1.1, Introduction
@unnumberedsubsec Q1.1.2: How do I become a Beta Tester?
@node Q1.3.1, Q1.3.2, Q1.2.3, Introduction
@unnumberedsec 1.3: Internationalization
-@unnumberedsubsec Q1.3.1: What is the status of XEmacs v20?
-
-XEmacs v20 is the version of XEmacs that includes MULE (Asian-language)
-support. XEmacs 20.0 was released in February 1997, followed by XEmacs
-20.2 in May, XEmacs 20.3 in November and XEmacs 20.4 in February 1998. When compiled without MULE
-support, 20.4 is approximately as stable as 19.16, and probably faster
-(due to additional optimization work.)
-
-As of XEmacs 20.3, version 20 is @emph{the} supported version of
-XEmacs. This means that 19.16 will optionally receive stability fixes
-(if any), but that all the real development work will be done on the v20
-tree.
-
-The incompatible changes in XEmacs 20 include the additional byte-codes,
-new primitive data types (@code{character}, @code{char-table}, and
-@code{range-table}). This means that the character-integer equivalence
-inherent to all the previous Emacs and XEmacs releases no longer
-applies.
-
-However, to avoid breaking old code, many functions that should normally
-accept characters work with integers, and vice versa. For more
-information, see the Lisp reference manual. Here is a relevant excerpt,
-for your convenience.
+@unnumberedsubsec Q1.3.1: What is the status of internationalization support aka MULE (including Asian language support?
-@quotation
- In XEmacs version 19, and in all versions of FSF GNU Emacs, a
-@dfn{character} in XEmacs Lisp is nothing more than an integer.
-This is yet another holdover from XEmacs Lisp's derivation from
-vintage-1980 Lisps; modern versions of Lisp consider this equivalence
-a bad idea, and have separate character types. In XEmacs version 20,
-the modern convention is followed, and characters are their own
-primitive types. (This change was necessary in order for @sc{mule},
-i.e. Asian-language, support to be correctly implemented.)
-
- Even in XEmacs version 20, remnants of the equivalence between
-characters and integers still exist; this is termed the @dfn{char-int
-confoundance disease}. In particular, many functions such as @code{eq},
-@code{equal}, and @code{memq} have equivalent functions (@code{old-eq},
-@code{old-equal}, @code{old-memq}, etc.) that pretend like characters
-are integers are the same. Byte code compiled under any version 19
-Emacs will have all such functions mapped to their @code{old-} equivalents
-when the byte code is read into XEmacs 20. This is to preserve
-compatibility---Emacs 19 converts all constant characters to the equivalent
-integer during byte-compilation, and thus there is no other way to preserve
-byte-code compatibility even if the code has specifically been written
-with the distinction between characters and integers in mind.
-
- Every character has an equivalent integer, called the @dfn{character
-code}. For example, the character @kbd{A} is represented as the
-@w{integer 65}, following the standard @sc{ascii} representation of
-characters. If XEmacs was not compiled with @sc{mule} support, the
-range of this integer will always be 0 to 255---eight bits, or one
-byte. (Integers outside this range are accepted but silently truncated;
-however, you should most decidedly @emph{not} rely on this, because it
-will not work under XEmacs with @sc{mule} support.) When @sc{mule}
-support is present, the range of character codes is much
-larger. (Currently, 19 bits are used.)
-
- FSF GNU Emacs uses kludgy character codes above 255 to represent
-keyboard input of @sc{ascii} characters in combination with certain
-modifiers. XEmacs does not use this (a more general mechanism is
-used that does not distinguish between @sc{ascii} keys and other
-keys), so you will never find character codes above 255 in a
-non-@sc{mule} XEmacs.
-
- Individual characters are not often used in programs. It is far more
-common to work with @emph{strings}, which are sequences composed of
-characters.
-@end quotation
+Both the stable and development versions of XEmacs include
+internationalization support (aka MULE). MULE currently works on UNIX
+and Linux systems; work for supporting MULE on Windows operating systems
+is in progress. Binaries compiled without MULE support run faster than
+MULE capable XEmacsen.
@node Q1.3.2, Q1.3.3, Q1.3.1, Introduction
-@unnumberedsubsec Q1.3.2: What is the status of Asian-language support, aka MULE?
-
-MULE support is now available for UNIX versions of XEmacs.
+@unnumberedsubsec Q1.3.2: How can I help with internationalization?
If you would like to help, you may want to join the
@email{xemacs-mule@@xemacs.org} mailing list. Especially needed are
The message-catalog support has mostly been written but doesn't
currently work. The first release of XEmacs 20 will @emph{not} support
-it. However, menubar localization @emph{does} work, even in 19.14. To
+it. However, menubar localization @emph{does} work. To
enable it, add to your @file{Emacs} file entries like this:
@example
removing punctuation and capitalizing as above.
@node Q1.3.5, Q1.3.6, Q1.3.4, Introduction
-@unnumberedsubsec Q1.3.5: Please explain the various input methods in MULE/XEmacs 20.0
+@unnumberedsubsec Q1.3.5: Please explain the various input methods in MULE/XEmacs
@email{morioka@@jaist.ac.jp, MORIOKA Tomohiko} writes:
@end quotation
@node Q1.3.6, Q1.3.7, Q1.3.5, Introduction
-@unnumberedsubsec Q1.3.6: How do I portably code for MULE/XEmacs 20?
+@unnumberedsubsec Q1.3.6: How do I portably code for MULE/XEmacs?
@email{morioka@@jaist.ac.jp, MORIOKA Tomohiko} writes:
@node Q2.0.1, Q2.0.2, Installation, Installation
@unnumberedsec 2.0: Installation
@unnumberedsubsec Q2.0.1: Running XEmacs without installing
-The @file{INSTALL} file says that up to 108 MB of space is needed
-temporarily during installation! How can I just try it out?
+
+How can I just try XEmacs without installing it?
XEmacs will run in place without requiring installation and copying of
the Lisp directories, and without having to specify a special build-time
@node Q2.0.2, Q2.0.3, Q2.0.1, Installation
@unnumberedsubsec Q2.0.2: XEmacs is too big
-Although this entry has been written for XEmacs 19.13, most of it still
-stands true.
-
-@email{steve@@xemacs.org, Steve Baur} writes:
-
-@quotation
-The 45MB of space required by the installation directories can be
+The space required by the installation directories can be
reduced dramatically if desired. Gzip all the .el files. Remove all
-the packages you'll never want to use (or even ones you do like the two
-obsolete mailcrypts and Gnus 4 in 19.13). Remove the TexInfo manuals.
+the packages you'll never want to use. Remove the TexInfo manuals.
Remove the Info (and use just hardcopy versions of the manual). Remove
most of the stuff in etc. Remove or gzip all the source code. Gzip or
remove the C source code. Configure it so that copies are not made of
-the support lisp. I'm not advocating any of these things, just pointing
-out ways to reduce the disk requirements if desired.
-
-Now examine the space used by directory:
-
-@format
-0 /usr/local/bin/xemacs
-2048 /usr/local/bin/xemacs-19.13
-
-1546 /usr/local/lib/xemacs-19.13/i486-miranova-sco3.2v4.2
-1158 /usr/local/lib/xemacs-19.13/i486-unknown-linux1.2.13
-@end format
-
-You need to keep these. XEmacs isn't stripped by default in
-installation, you should consider stripping. That will save you about
-5MB right there.
-
-@format
-207 /usr/local/lib/xemacs-19.13/etc/w3
-122 /usr/local/lib/xemacs-19.13/etc/sounds
-18 /usr/local/lib/xemacs-19.13/etc/sparcworks
-159 /usr/local/lib/xemacs-19.13/etc/vm
-6 /usr/local/lib/xemacs-19.13/etc/e
-21 /usr/local/lib/xemacs-19.13/etc/eos
-172 /usr/local/lib/xemacs-19.13/etc/toolbar
-61 /usr/local/lib/xemacs-19.13/etc/ns
-43 /usr/local/lib/xemacs-19.13/etc/gnus
-@end format
-
-These are support directories for various packages. In general they
-match a directory under ./xemacs-19.13/lib/xemacs-19.13/lisp/. If you
-do not require the package, you may delete or gzip the support too.
-
-@format
-1959 /usr/local/lib/xemacs-19.13/etc
-175 /usr/local/lib/xemacs-19.13/lisp/bytecomp
-340 /usr/local/lib/xemacs-19.13/lisp/calendar
-342 /usr/local/lib/xemacs-19.13/lisp/comint
-517 /usr/local/lib/xemacs-19.13/lisp/dired
-42 /usr/local/lib/xemacs-19.13/lisp/electric
-212 /usr/local/lib/xemacs-19.13/lisp/emulators
-238 /usr/local/lib/xemacs-19.13/lisp/energize
-289 /usr/local/lib/xemacs-19.13/lisp/gnus
-457 /usr/local/lib/xemacs-19.13/lisp/ilisp
-1439 /usr/local/lib/xemacs-19.13/lisp/modes
-2276 /usr/local/lib/xemacs-19.13/lisp/packages
-1040 /usr/local/lib/xemacs-19.13/lisp/prim
-176 /usr/local/lib/xemacs-19.13/lisp/pcl-cvs
-154 /usr/local/lib/xemacs-19.13/lisp/rmail
-3 /usr/local/lib/xemacs-19.13/lisp/epoch
-45 /usr/local/lib/xemacs-19.13/lisp/term
-860 /usr/local/lib/xemacs-19.13/lisp/utils
-851 /usr/local/lib/xemacs-19.13/lisp/vm
-13 /usr/local/lib/xemacs-19.13/lisp/vms
-157 /usr/local/lib/xemacs-19.13/lisp/x11
-19 /usr/local/lib/xemacs-19.13/lisp/tooltalk
-14 /usr/local/lib/xemacs-19.13/lisp/sunpro
-291 /usr/local/lib/xemacs-19.13/lisp/games
-198 /usr/local/lib/xemacs-19.13/lisp/edebug
-619 /usr/local/lib/xemacs-19.13/lisp/w3
-229 /usr/local/lib/xemacs-19.13/lisp/eos
-55 /usr/local/lib/xemacs-19.13/lisp/iso
-59 /usr/local/lib/xemacs-19.13/lisp/mailcrypt
-187 /usr/local/lib/xemacs-19.13/lisp/eterm
-356 /usr/local/lib/xemacs-19.13/lisp/ediff
-408 /usr/local/lib/xemacs-19.13/lisp/hyperbole/kotl
-1262 /usr/local/lib/xemacs-19.13/lisp/hyperbole
-247 /usr/local/lib/xemacs-19.13/lisp/hm--html-menus
-161 /usr/local/lib/xemacs-19.13/lisp/mh-e
-299 /usr/local/lib/xemacs-19.13/lisp/viper
-53 /usr/local/lib/xemacs-19.13/lisp/oobr/tree-x
-4 /usr/local/lib/xemacs-19.13/lisp/oobr/tree-nx/English.lproj/DocWindow.nib
-3 /usr/local/lib/xemacs-19.13/lisp/oobr/tree-nx/English.lproj/InfoPanel.nib
-3 /usr/local/lib/xemacs-19.13/lisp/oobr/tree-nx/English.lproj/TreeView.nib
-11 /usr/local/lib/xemacs-19.13/lisp/oobr/tree-nx/English.lproj
-53 /usr/local/lib/xemacs-19.13/lisp/oobr/tree-nx
-466 /usr/local/lib/xemacs-19.13/lisp/oobr
-14142 /usr/local/lib/xemacs-19.13/lisp
-@end format
+the support lisp.
These are all Emacs Lisp source code and bytecompiled object code. You
may safely gzip everything named *.el here. You may remove any package
that you do not use}. You must be sure you do not use it though, so be
conservative at first.
-Possible candidates for deletion include w3 (newer versions exist, or
-you may just use Lynx or Netscape for web browsing), games, hyperbole,
-mh-e, hm--html-menus (better packages exist), vm, viper, oobr, gnus (new
-versions exist), etc. Ask yourself, @emph{Do I ever want to use this
-package?} If the answer is no, then it is a candidate for removal.
+Possible candidates for deletion include w3, games, hyperbole, mh-e,
+hm-html-menus, vm, viper, oobr, gnus, etc. Ask yourself, @emph{Do I
+ever want to use this package?} If the answer is no, then it is a
+candidate for removal.
First, gzip all the .el files. Then go about package by package and
start gzipping the .elc files. Then run XEmacs and do whatever it is
you normally do. If nothing bad happens, then delete the directory. Be
conservative about deleting directories, and it would be handy to have a
-backup tape around in case you get too zealous.
+backup around in case you get too zealous.
@file{prim}, @file{modes}, @file{packages}, and @file{utils} are four
directories you definitely do @strong{not} want to delete, although
certain packages can be removed from them if you do not use them.
-@example
-1972 /usr/local/lib/xemacs-19.13/info
-@end example
-
-These are online texinfo sources. You may either gzip them or remove
-them. In either case, @kbd{C-h i} (info mode) will no longer work.
-
-@example
-20778 /usr/local/lib/xemacs-19.13
-@end example
-
-The 20MB achieved is less than half of what the full distribution takes up,
-@strong{and} can be achieved without deleting a single file.
-@end quotation
-
-@email{boffi@@hp735.stru.polimi.it, Giacomo Boffi} provides this procedure:
-
-@quotation
-Substitute @file{/usr/local/lib/} with the path where the xemacs tree is
-rooted, then use this script:
-
-@example
-#!/bin/sh
-
-r=/usr/local/lib/xemacs-19.13/lisp
-
-cd $r ; rm -f cmpr ; touch cmpr
-
-du -s .
-
-for d in * ; do
- if test -d $d ; then
- cd $d
- for f in *.el ; do
-# compress (remove) only (ONLY) the sources that have a
-# corresponding compiled file --- do not (DO NOT)
-# touch other sources
- if test -f $@{f@}c ; then gzip -v9 $f >> $r/cmpr ; fi
- done
- cd ..
- fi
-done
-
-du -s .
-@end example
-
-A step beyond would be substituting @samp{rm -f} for @samp{gzip -v9},
-but you have to be desperate for removing the sources (remember that
-emacs can access compressed files transparently).
-
-Also, a good megabyte could easily be trimmed from the $r/../etc
-directory, e.g., the termcap files, some O+NEWS, others that I don't
-remember as well.
-@end quotation
-
-@quotation
-XEmacs 21.0 will unbundle the lisp hierarchy and allow the installer
-to choose exactly how much support code gets installed.
-@end quotation
+Online texinfo sources in the @file{info} can either be compressed them
+or remove them. In either case, @kbd{C-h i} (info mode) will no longer
+work.
@node Q2.0.3, Q2.0.4, Q2.0.2, Installation
@unnumberedsubsec Q2.0.3: Compiling XEmacs with Netaudio.
@unnumberedsubsec Q2.0.5: Do I need X11 to run XEmacs?
No. The name @dfn{XEmacs} is unfortunate in the sense that it is
-@strong{not} an X Window System-only version of Emacs. Starting with
-19.14 XEmacs has full color support on a color-capable character
-terminal.
+@strong{not} an X Window System-only version of Emacs. XEmacs has
+full color support on a color-capable character terminal.
@node Q2.0.6, Q2.0.7, Q2.0.5, Installation
@unnumberedsubsec Q2.0.6: I'm having strange crashes. What do I do?
* Q5.1.4:: What is the performance hit of @code{let}?
* Q5.1.5:: What is the recommended use of @code{setq}?
* Q5.1.6:: What is the typical misuse of @code{setq}?
-* Q5.1.7:: I like the the @code{do} form of cl, does it slow things down?
+* Q5.1.7:: I like the @code{do} form of cl, does it slow things down?
* Q5.1.8:: I like recursion, does it slow things down?
* Q5.1.9:: How do I put a glyph as annotation in a buffer?
* Q5.1.10:: @code{map-extents} won't traverse all of my extents!
@end lisp
@node Q5.1.7, Q5.1.8, Q5.1.6, Miscellaneous
-@unnumberedsubsec Q5.1.7: I like the the @code{do} form of cl, does it slow things down?
+@unnumberedsubsec Q5.1.7: I like the @code{do} form of cl, does it slow things down?
It shouldn't. Here is what Dave Gillespie has to say about cl.el
performance:
list. That is inappropriate. Whether you use Auto Fill mode or not is
a matter of personal taste, not a matter of the contents of particular
files. If you want to use Auto Fill, set up major mode hooks with your
-file file to turn it on (when appropriate) for you alone
+init file to turn it on (when appropriate) for you alone
(@pxref{Init File}). Don't try to use a local variable list that would
impose your taste on everyone working with the file.
colors: It uses whatever resources are appropriate to the type of widget
which is used to implement it.
-If Emacs was compiled to use only the Motif-lookalike menu widgets, then one
-way to specify the font of the menubar would be
+If Emacs was compiled to use only the Lucid Motif-lookalike menu widgets,
+then one way to specify the font of the menubar would be
@example
Emacs*menubar*font: *-courier-medium-r-*-*-*-120-*-*-*-*-*-*
@end example
+If both the Lucid Motif-lookalike menu widgets and X Font Sets are
+configured to allow multilingual menubars, then one uses
+
+@example
+*menubar*FontSet: -*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-*, \
+ -*-*-*-*-*-*-*-120-*-jisx0208.1983-0
+@end example
+
+That would specify fonts for a Japanese menubar. Specifying only one
+XLFD is acceptable; specifying more than one for a given registry
+(language) is also allowed. When X Font Sets are configured, some .font
+resources (eg, menubars) are ignored in favor of the corresponding
+.fontSet resources.
+
If the Motif library is being used, then one would have to use
@example
keyboards lacking a @key{META} key. Unlike the @key{META} key (which,
like the @key{SHIFT} key, is held down while another character is
typed), the @key{ESC} key is pressed and released, and applies to the
-next character typed.
+next character typed.
@item Fill Prefix
The fill prefix is a string that Emacs enters at the beginning
@item Scrolling
Scrolling means shifting the text in the Emacs window to make a
-different part ot the buffer visible. @xref{Display,Scrolling}.
+different part of the buffer visible. @xref{Display,Scrolling}.
@item Searching
Searching means moving point to the next occurrence of a specified
A termscript file contains a record of all characters Emacs sent to
the terminal. It is used for tracking down bugs in Emacs redisplay.
Emacs does not make a termscript file unless explicitly instructed to do
-so.
+so.
@xref{Bugs}.
@item Text
@xref{Windows}, for commands to control the use of windows. Note that if
you are running Emacs under X, terminology can be confusing: Each Emacs
frame occupies a separate X window and can, in turn, be divided into
-different subwindows.
+different subwindows.
@item Word Abbrev
Synonymous with `abbrev'.
n} (@code{view-emacs-news}) displays the file @file{xemacs/etc/NEWS},
which contains documentation on XEmacs changes arranged chronologically.
@kbd{C-h F} (@code{xemacs-local-faq}) displays local version of the
-XEmacs frequentliy-answered-questions-list. @kbd{C-h t}
+XEmacs frequently-answered-questions-list. @kbd{C-h t}
(@code{help-with-tutorial}) displays the learn-by-doing XEmacs
tutorial. @kbd{C-h C-c} (@code{describe-copying}) displays the file
@file{xemacs/etc/COPYING}, which tells you the conditions you must obey
Simplified Chinese script (for mainland of China), Traditional Chinese
script (for Taiwan and Hong-Kong), Greek script, Hebrew script, IPA
symbols, Japanese scripts (Hiragana, Katakana and Kanji), Korean scripts
-(Hangul and Hanja) and Cyrillic script (for Beylorussian, Bulgarian,
+(Hangul and Hanja) and Cyrillic script (for Byelorussian, Bulgarian,
Russian, Serbian and Ukrainian). These features have been merged from
the modified version of Emacs known as MULE (for ``MULti-lingual
Enhancement to GNU Emacs'').
within searches (@kbd{C-q}, @kbd{C-w}, @kbd{C-r}, @kbd{C-s}, or @kbd{C-y}).
Sometimes you search for @samp{FOO} and find it, but were actually
-looking for a different occurence of it. To move to the next occurrence
+looking for a different occurrence of it. To move to the next occurrence
of the search string, type another @kbd{C-s}. Do this as often as
necessary. If you overshoot, you can cancel some @kbd{C-s}
characters with @key{DEL}.
@cindex regexp
A @dfn{regular expression} (@dfn{regexp}, for short) is a pattern that
-denotes a set of strings, possibly an infinite set. Searching for matches
+denotes a (possibly infinite) set of strings. Searching for matches
for a regexp is a powerful operation that editors on Unix systems have
-traditionally offered. In XEmacs, you can search for the next match for
-a regexp either incrementally or not.
+traditionally offered.
+
+ To gain a thorough understanding of regular expressions and how to use
+them to best advantage, we recommend that you study @cite{Mastering
+Regular Expressions, by Jeffrey E.F. Friedl, O'Reilly and Associates,
+1997}. (It's known as the "Hip Owls" book, because of the picture on its
+cover.) You might also read the manuals to @ref{(gawk)Top},
+@ref{(ed)Top}, @cite{sed}, @cite{grep}, @ref{(perl)Top},
+@ref{(regex)Top}, @ref{(rx)Top}, @cite{pcre}, and @ref{(flex)Top}, which
+also make good use of regular expressions.
+
+ The XEmacs regular expression syntax most closely resembles that of
+@cite{ed}, or @cite{grep}, the GNU versions of which all utilize the GNU
+@cite{regex} library. XEmacs' version of @cite{regex} has recently been
+extended with some Perl--like capabilities, described in the next
+section.
+
+ In XEmacs, you can search for the next match for a regexp either
+incrementally or not.
@kindex M-C-s
+@kindex M-C-r
@findex isearch-forward-regexp
@findex isearch-backward-regexp
Incremental search for a regexp is done by typing @kbd{M-C-s}
regexp rather than looking for an exact match against the text in the
buffer. Each time you add text to the search string, you make the regexp
longer, and the new regexp is searched for. A reverse regexp search command
-@code{isearch-backward-regexp} also exists, but no key runs it.
+@code{isearch-backward-regexp} also exists, bound to @kbd{M-C-r}.
All of the control characters that do special things within an ordinary
incremental search have the same functionality in incremental regexp search.
@code{re-search-forward} and @code{re-search-backward}. You can invoke
them with @kbd{M-x} or bind them to keys. You can also call
@code{re-search-forward} by way of incremental regexp search with
-@kbd{M-C-s @key{RET}}.
+@kbd{M-C-s @key{RET}}; similarly for @code{re-search-backward} with
+@kbd{M-C-r @key{RET}}.
@node Regexps, Search Case, Regexp Search, Search
@section Syntax of Regular Expressions
-Regular expressions have a syntax in which a few characters are special
-constructs and the rest are @dfn{ordinary}. An ordinary character is a
-simple regular expression which matches that character and nothing else.
-The special characters are @samp{$}, @samp{^}, @samp{.}, @samp{*},
-@samp{+}, @samp{?}, @samp{[}, @samp{]} and @samp{\}; no new special
-characters will be defined. Any other character appearing in a regular
-expression is ordinary, unless a @samp{\} precedes it.@refill
+ Regular expressions have a syntax in which a few characters are
+special constructs and the rest are @dfn{ordinary}. An ordinary
+character is a simple regular expression that matches that character and
+nothing else. The special characters are @samp{.}, @samp{*}, @samp{+},
+@samp{?}, @samp{[}, @samp{]}, @samp{^}, @samp{$}, and @samp{\}; no new
+special characters will be defined in the future. Any other character
+appearing in a regular expression is ordinary, unless a @samp{\}
+precedes it.
For example, @samp{f} is not a special character, so it is ordinary, and
-therefore @samp{f} is a regular expression that matches the string @samp{f}
-and no other string. (It does @i{not} match the string @samp{ff}.) Likewise,
-@samp{o} is a regular expression that matches only @samp{o}.@refill
+therefore @samp{f} is a regular expression that matches the string
+@samp{f} and no other string. (It does @emph{not} match the string
+@samp{ff}.) Likewise, @samp{o} is a regular expression that matches
+only @samp{o}.@refill
Any two regular expressions @var{a} and @var{b} can be concatenated. The
-result is a regular expression which matches a string if @var{a} matches
+result is a regular expression that matches a string if @var{a} matches
some amount of the beginning of that string and @var{b} matches the rest of
the string.@refill
-As a simple example, you can concatenate the regular expressions @samp{f}
+As a simple example, we can concatenate the regular expressions @samp{f}
and @samp{o} to get the regular expression @samp{fo}, which matches only
-the string @samp{fo}. To do something nontrivial, you
-need to use one of the following special characters:
+the string @samp{fo}. Still trivial. To do something more powerful, you
+need to use one of the special characters. Here is a list of them:
+@need 1200
@table @kbd
@item .@: @r{(Period)}
+@cindex @samp{.} in regexp
is a special character that matches any single character except a newline.
-Using concatenation, you can make regular expressions like @samp{a.b}, which
-matches any three-character string which begins with @samp{a} and ends with
+Using concatenation, we can make regular expressions like @samp{a.b}, which
+matches any three-character string that begins with @samp{a} and ends with
@samp{b}.@refill
@item *
-is not a construct by itself; it is a suffix, which means the
-preceding regular expression is to be repeated as many times as
+@cindex @samp{*} in regexp
+is not a construct by itself; it is a quantifying suffix operator that
+means to repeat the preceding regular expression as many times as
possible. In @samp{fo*}, the @samp{*} applies to the @samp{o}, so
@samp{fo*} matches one @samp{f} followed by any number of @samp{o}s.
The case of zero @samp{o}s is allowed: @samp{fo*} does match
@samp{f}.@refill
-@samp{*} always applies to the @i{smallest} possible preceding
+@samp{*} always applies to the @emph{smallest} possible preceding
expression. Thus, @samp{fo*} has a repeating @samp{o}, not a
repeating @samp{fo}.@refill
-The matcher processes a @samp{*} construct by immediately matching
-as many repetitions as it can find. Then it continues with the rest
-of the pattern. If that fails, backtracking occurs, discarding some
-of the matches of the @samp{*}-modified construct in case that makes
-it possible to match the rest of the pattern. For example, matching
-@samp{ca*ar} against the string @samp{caaar}, the @samp{a*} first
-tries to match all three @samp{a}s; but the rest of the pattern is
-@samp{ar} and there is only @samp{r} left to match, so this try fails.
-The next alternative is for @samp{a*} to match only two @samp{a}s.
-With this choice, the rest of the regexp matches successfully.@refill
+The matcher processes a @samp{*} construct by matching, immediately, as
+many repetitions as can be found; it is "greedy". Then it continues
+with the rest of the pattern. If that fails, backtracking occurs,
+discarding some of the matches of the @samp{*}-modified construct in
+case that makes it possible to match the rest of the pattern. For
+example, in matching @samp{ca*ar} against the string @samp{caaar}, the
+@samp{a*} first tries to match all three @samp{a}s; but the rest of the
+pattern is @samp{ar} and there is only @samp{r} left to match, so this
+try fails. The next alternative is for @samp{a*} to match only two
+@samp{a}s. With this choice, the rest of the regexp matches
+successfully.@refill
+
+Nested repetition operators can be extremely slow if they specify
+backtracking loops. For example, it could take hours for the regular
+expression @samp{\(x+y*\)*a} to match the sequence
+@samp{xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxz}. The slowness is because
+Emacs must try each imaginable way of grouping the 35 @samp{x}'s before
+concluding that none of them can work. To make sure your regular
+expressions run fast, check nested repetitions carefully.
@item +
-is a suffix character similar to @samp{*} except that it requires that
-the preceding expression be matched at least once. For example,
-@samp{ca+r} will match the strings @samp{car} and @samp{caaaar}
-but not the string @samp{cr}, whereas @samp{ca*r} would match all
-three strings.@refill
+@cindex @samp{+} in regexp
+is a quantifying suffix operator similar to @samp{*} except that the
+preceding expression must match at least once. It is also "greedy".
+So, for example, @samp{ca+r} matches the strings @samp{car} and
+@samp{caaaar} but not the string @samp{cr}, whereas @samp{ca*r} matches
+all three strings.
@item ?
-is a suffix character similar to @samp{*} except that it can match the
-preceding expression either once or not at all. For example,
-@samp{ca?r} will match @samp{car} or @samp{cr}; nothing else.
+@cindex @samp{?} in regexp
+is a quantifying suffix operator similar to @samp{*}, except that the
+preceding expression can match either once or not at all. For example,
+@samp{ca?r} matches @samp{car} or @samp{cr}, but does not match anything
+else.
+
+@item *?
+@cindex @samp{*?} in regexp
+works just like @samp{*}, except that rather than matching the longest
+match, it matches the shortest match. @samp{*?} is known as a
+@dfn{non-greedy} quantifier, a regexp construct borrowed from Perl.
+@c Did perl get this from somewhere? What's the real history of *? ?
+
+This construct is very useful for when you want to match the text inside
+a pair of delimiters. For instance, @samp{/\*.*?\*/} will match C
+comments in a string. This could not easily be achieved without the use
+of a non-greedy quantifier.
+
+This construct has not been available prior to XEmacs 20.4. It is not
+available in FSF Emacs.
+
+@item +?
+@cindex @samp{+?} in regexp
+is the non-greedy version of @samp{+}.
+
+@item ??
+@cindex @samp{??} in regexp
+is the non-greedy version of @samp{?}.
+
+@item \@{n,m\@}
+@c Note the spacing after the close brace is deliberate.
+@cindex @samp{\@{n,m\@} }in regexp
+serves as an interval quantifier, analogous to @samp{*} or @samp{+}, but
+specifies that the expression must match at least @var{n} times, but no
+more than @var{m} times. This syntax is supported by most Unix regexp
+utilities, and has been introduced to XEmacs for the version 20.3.
+
+Unfortunately, the non-greedy version of this quantifier does not exist
+currently, although it does in Perl.
@item [ @dots{} ]
+@cindex character set (in regexp)
+@cindex @samp{[} in regexp
+@cindex @samp{]} in regexp
@samp{[} begins a @dfn{character set}, which is terminated by a
-@samp{]}. In the simplest case, the characters between the two form
-the set. Thus, @samp{[ad]} matches either one @samp{a} or one
-@samp{d}, and @samp{[ad]*} matches any string composed of just
-@samp{a}s and @samp{d}s (including the empty string), from which it
-follows that @samp{c[ad]*r} matches @samp{cr}, @samp{car}, @samp{cdr},
+@samp{]}. In the simplest case, the characters between the two brackets
+form the set. Thus, @samp{[ad]} matches either one @samp{a} or one
+@samp{d}, and @samp{[ad]*} matches any string composed of just @samp{a}s
+and @samp{d}s (including the empty string), from which it follows that
+@samp{c[ad]*r} matches @samp{cr}, @samp{car}, @samp{cdr},
@samp{caddaar}, etc.@refill
-You can include character ranges in a character set by writing two
+The usual regular expression special characters are not special inside a
+character set. A completely different set of special characters exists
+inside character sets: @samp{]}, @samp{-} and @samp{^}.@refill
+
+@samp{-} is used for ranges of characters. To write a range, write two
characters with a @samp{-} between them. Thus, @samp{[a-z]} matches any
-lower-case letter. Ranges may be intermixed freely with individual
-characters, as in @samp{[a-z$%.]}, which matches any lower-case letter
-or @samp{$}, @samp{%}, or period.
-@refill
+lower case letter. Ranges may be intermixed freely with individual
+characters, as in @samp{[a-z$%.]}, which matches any lower case letter
+or @samp{$}, @samp{%}, or a period.@refill
-Note that inside a character set the usual special characters are not
-special any more. A completely different set of special characters
-exists inside character sets: @samp{]}, @samp{-}, and @samp{^}.@refill
+To include a @samp{]} in a character set, make it the first character.
+For example, @samp{[]a]} matches @samp{]} or @samp{a}. To include a
+@samp{-}, write @samp{-} as the first character in the set, or put it
+immediately after a range. (You can replace one individual character
+@var{c} with the range @samp{@var{c}-@var{c}} to make a place to put the
+@samp{-}.) There is no way to write a set containing just @samp{-} and
+@samp{]}.
-To include a @samp{]} in a character set, you must make it the first
-character. For example, @samp{[]a]} matches @samp{]} or @samp{a}. To
-include a @samp{-}, write @samp{---}, which is a range containing only
-@samp{-}. To include @samp{^}, make it other than the first character
-in the set.@refill
+To include @samp{^} in a set, put it anywhere but at the beginning of
+the set.
@item [^ @dots{} ]
+@cindex @samp{^} in regexp
@samp{[^} begins a @dfn{complement character set}, which matches any
character except the ones specified. Thus, @samp{[^a-z0-9A-Z]}
-matches all characters @i{except} letters and digits.@refill
+matches all characters @emph{except} letters and digits.@refill
@samp{^} is not special in a character set unless it is the first
character. The character following the @samp{^} is treated as if it
-were first (@samp{-} and @samp{]} are not special there).
+were first (thus, @samp{-} and @samp{]} are not special there).
Note that a complement character set can match a newline, unless
newline is mentioned as one of the characters not to match.
@item ^
-is a special character that matches the empty string, but only if at
-the beginning of a line in the text being matched. Otherwise, it fails
-to match anything. Thus, @samp{^foo} matches a @samp{foo} that occurs
-at the beginning of a line.
+@cindex @samp{^} in regexp
+@cindex beginning of line in regexp
+is a special character that matches the empty string, but only at the
+beginning of a line in the text being matched. Otherwise it fails to
+match anything. Thus, @samp{^foo} matches a @samp{foo} that occurs at
+the beginning of a line.
+
+When matching a string instead of a buffer, @samp{^} matches at the
+beginning of the string or after a newline character @samp{\n}.
@item $
+@cindex @samp{$} in regexp
is similar to @samp{^} but matches only at the end of a line. Thus,
-@samp{xx*$} matches a string of one @samp{x} or more at the end of a line.
+@samp{x+$} matches a string of one @samp{x} or more at the end of a line.
+
+When matching a string instead of a buffer, @samp{$} matches at the end
+of the string or before a newline character @samp{\n}.
@item \
-does two things: it quotes the special characters (including
+@cindex @samp{\} in regexp
+has two functions: it quotes the special characters (including
@samp{\}), and it introduces additional special constructs.
Because @samp{\} quotes special characters, @samp{\$} is a regular
expression that matches only @samp{$}, and @samp{\[} is a regular
-expression that matches only @samp{[}, and so on.@refill
+expression that matches only @samp{[}, and so on.
+
+@c Removed a paragraph here in lispref about doubling backslashes inside
+@c of Lisp strings.
+
@end table
-Note: for historical compatibility, special characters are treated as
-ordinary ones if they are in contexts where their special meanings make no
-sense. For example, @samp{*foo} treats @samp{*} as ordinary since there is
-no preceding expression on which the @samp{*} can act. It is poor practice
-to depend on this behavior; better to quote the special character anyway,
-regardless of where is appears.@refill
+@strong{Please note:} For historical compatibility, special characters
+are treated as ordinary ones if they are in contexts where their special
+meanings make no sense. For example, @samp{*foo} treats @samp{*} as
+ordinary since there is no preceding expression on which the @samp{*}
+can act. It is poor practice to depend on this behavior; quote the
+special character anyway, regardless of where it appears.@refill
-Usually, @samp{\} followed by any character matches only
+For the most part, @samp{\} followed by any character matches only
that character. However, there are several exceptions: characters
-which, when preceded by @samp{\}, are special constructs. Such
+that, when preceded by @samp{\}, are special constructs. Such
characters are always ordinary when encountered on their own. Here
-is a table of @samp{\} constructs.
+is a table of @samp{\} constructs:
@table @kbd
@item \|
+@cindex @samp{|} in regexp
+@cindex regexp alternative
specifies an alternative.
Two regular expressions @var{a} and @var{b} with @samp{\|} in
-between form an expression that matches anything @var{a} or
+between form an expression that matches anything that either @var{a} or
@var{b} matches.@refill
Thus, @samp{foo\|bar} matches either @samp{foo} or @samp{bar}
Full backtracking capability exists to handle multiple uses of @samp{\|}.
@item \( @dots{} \)
+@cindex @samp{(} in regexp
+@cindex @samp{)} in regexp
+@cindex regexp grouping
is a grouping construct that serves three purposes:
@enumerate
Thus, @samp{\(foo\|bar\)x} matches either @samp{foox} or @samp{barx}.
@item
-To enclose a complicated expression for the postfix @samp{*} to operate on.
-Thus, @samp{ba\(na\)*} matches @samp{bananana}, etc., with any (zero or
-more) number of @samp{na} strings.@refill
+To enclose an expression for a suffix operator such as @samp{*} to act
+on. Thus, @samp{ba\(na\)*} matches @samp{bananana}, etc., with any
+(zero or more) number of @samp{na} strings.@refill
@item
-To mark a matched substring for future reference.
-
+To record a matched substring for future reference.
@end enumerate
This last application is not a consequence of the idea of a
-parenthetical grouping; it is a separate feature which happens to be
+parenthetical grouping; it is a separate feature that happens to be
assigned as a second meaning to the same @samp{\( @dots{} \)} construct
-because in practice there is no conflict between the two meanings.
-Here is an explanation:
+because there is no conflict in practice between the two meanings.
+Here is an explanation of this feature:
@item \@var{digit}
-after the end of a @samp{\( @dots{} \)} construct, the matcher remembers the
-beginning and end of the text matched by that construct. Then, later on
-in the regular expression, you can use @samp{\} followed by @var{digit}
-to mean ``match the same text matched the @var{digit}'th time by the
-@samp{\( @dots{} \)} construct.''@refill
-
-The strings matching the first nine @samp{\( @dots{} \)} constructs appearing
-in a regular expression are assigned numbers 1 through 9 in order that the
-open-parentheses appear in the regular expression. @samp{\1} through
-@samp{\9} may be used to refer to the text matched by the corresponding
+matches the same text that matched the @var{digit}th occurrence of a
@samp{\( @dots{} \)} construct.
+In other words, after the end of a @samp{\( @dots{} \)} construct. the
+matcher remembers the beginning and end of the text matched by that
+construct. Then, later on in the regular expression, you can use
+@samp{\} followed by @var{digit} to match that same text, whatever it
+may have been.
+
+The strings matching the first nine @samp{\( @dots{} \)} constructs
+appearing in a regular expression are assigned numbers 1 through 9 in
+the order that the open parentheses appear in the regular expression.
+So you can use @samp{\1} through @samp{\9} to refer to the text matched
+by the corresponding @samp{\( @dots{} \)} constructs.
+
For example, @samp{\(.*\)\1} matches any newline-free string that is
composed of two identical halves. The @samp{\(.*\)} matches the first
half, which may be anything, but the @samp{\1} that follows must match
the same exact text.
+@item \(?: @dots{} \)
+@cindex @samp{\(?:} in regexp
+@cindex regexp grouping
+is called a @dfn{shy} grouping operator, and it is used just like
+@samp{\( @dots{} \)}, except that it does not cause the matched
+substring to be recorded for future reference.
+
+This is useful when you need a lot of grouping @samp{\( @dots{} \)}
+constructs, but only want to remember one or two -- or if you have
+more than nine groupings and need to use backreferences to refer to
+the groupings at the end.
+
+Using @samp{\(?: @dots{} \)} rather than @samp{\( @dots{} \)} when you
+don't need the captured substrings ought to speed up your programs some,
+since it shortens the code path followed by the regular expression
+engine, as well as the amount of memory allocation and string copying it
+must do. The actual performance gain to be observed has not been
+measured or quantified as of this writing.
+@c This is used to good advantage by the font-locking code, and by
+@c `regexp-opt.el'.
+
+The shy grouping operator has been borrowed from Perl, and has not been
+available prior to XEmacs 20.3, nor is it available in FSF Emacs.
+
+@item \w
+@cindex @samp{\w} in regexp
+matches any word-constituent character. The editor syntax table
+determines which characters these are. @xref{Syntax}.
+
+@item \W
+@cindex @samp{\W} in regexp
+matches any character that is not a word constituent.
+
+@item \s@var{code}
+@cindex @samp{\s} in regexp
+matches any character whose syntax is @var{code}. Here @var{code} is a
+character that represents a syntax code: thus, @samp{w} for word
+constituent, @samp{-} for whitespace, @samp{(} for open parenthesis,
+etc. @xref{Syntax}, for a list of syntax codes and the characters that
+stand for them.
+
+@item \S@var{code}
+@cindex @samp{\S} in regexp
+matches any character whose syntax is not @var{code}.
+@end table
+
+ The following regular expression constructs match the empty string---that is,
+they don't use up any characters---but whether they match depends on the
+context.
+
+@table @kbd
@item \`
-matches the empty string, provided it is at the beginning
-of the buffer.
+@cindex @samp{\`} in regexp
+matches the empty string, but only at the beginning
+of the buffer or string being matched against.
@item \'
-matches the empty string, provided it is at the end of
-the buffer.
+@cindex @samp{\'} in regexp
+matches the empty string, but only at the end of
+the buffer or string being matched against.
+
+@item \=
+@cindex @samp{\=} in regexp
+matches the empty string, but only at point.
+(This construct is not defined when matching against a string.)
@item \b
-matches the empty string, provided it is at the beginning or
+@cindex @samp{\b} in regexp
+matches the empty string, but only at the beginning or
end of a word. Thus, @samp{\bfoo\b} matches any occurrence of
@samp{foo} as a separate word. @samp{\bballs?\b} matches
@samp{ball} or @samp{balls} as a separate word.@refill
@item \B
-matches the empty string, provided it is @i{not} at the beginning or
+@cindex @samp{\B} in regexp
+matches the empty string, but @emph{not} at the beginning or
end of a word.
@item \<
-matches the empty string, provided it is at the beginning of a word.
+@cindex @samp{\<} in regexp
+matches the empty string, but only at the beginning of a word.
@item \>
-matches the empty string, provided it is at the end of a word.
-
-@item \w
-matches any word-constituent character. The editor syntax table
-determines which characters these are.
-
-@item \W
-matches any character that is not a word-constituent.
-
-@item \s@var{code}
-matches any character whose syntax is @var{code}. @var{code} is a
-character which represents a syntax code: thus, @samp{w} for word
-constituent, @samp{-} for whitespace, @samp{(} for open-parenthesis,
-etc. @xref{Syntax}.@refill
-
-@item \S@var{code}
-matches any character whose syntax is not @var{code}.
+@cindex @samp{\>} in regexp
+matches the empty string, but only at the end of a word.
@end table
Here is a complicated regexp used by Emacs to recognize the end of a
@cindex root of a hierarchy
Whenever this section refers to a directory using the shorthand
@code{<root>}, it means that XEmacs searches for it under all
-hierarchies under all hierarchies XEmacs was able to scrounge up. In a
+hierarchies XEmacs was able to scrounge up. In a
running XEmacs, the hierarchy roots are stored in the variable
@code{emacs-roots}.
@vindex emacs-roots
package hierarchies with the @code{--package-path} option to configure.
@cindex package path
The early, late, and last components of the package path are separated
-by double instead of single colons. If three components are present,
-they are locate the early, late, and last package hierarchies
+by double instead of single colons. If all three components are
+present, they locate the early, late, and last package hierarchies
respectively. If two components are present, they locate the early and
-late hierarchies. If only one component is present, it locates the late
-hierarchy. At run time, the package path may also be specified via the
-@code{EMACSPACKAGEPATH} environment variable.
+late hierarchies. If only one component is present, it locates the
+late hierarchy. At run time, the package path may also be specified via
+the @code{EMACSPACKAGEPATH} environment variable.
An XEmacs package is laid out just like a normal installed XEmacs lisp
directory. It may have @file{lisp}, @file{etc}, @file{info}, and
/*
* Each dynamically loaded Emacs module is given a name at compile
* time. This is a short name, and must be a valid part of a C
- * identifier. This name is used to contruct the name of several
+ * identifier. This name is used to construct the name of several
* functions which must appear in the module source code.
- * The first such function, modules_of_XXXX, should load in any dependant
+ * The first such function, modules_of_XXXX, should load in any dependent
* modules. This function is optional, and the module will still load if
* it is not present in the module.
*
{
/*
* This function isn't actually required as we will not be loading
- * in any dependant modules, but if we were, we would do something like:
- * emodules_load ("dependant.ell", "sample2", "1.0.0");
+ * in any dependent modules, but if we were, we would do something like:
+ * emodules_load ("dependent.ell", "sample2", "1.0.0");
*/
}
+2000-10-04 Martin Buchholz <martin@xemacs.org>
+
+ * XEmacs 21.2.36 is released.
+
+2000-09-30 Martin Buchholz <martin@xemacs.org>
+
+ * config.h (HAVE_STRCASECMP): Remove.
+
+2000-09-07 Jonathan Harris <jhar@tardis.ed.ac.uk>
+
+ * xemacs.mak:
+ Make src\depend parsing recognise "#if defined" instead of "#ifdef".
+ Use matching single quotes to keep 4dos shell happy.
+
+2000-08-07 Ben Wing <ben@xemacs.org>
+
+ * xemacs.mak: add getloadavg.c.
+
+2000-07-30 Ben Wing <ben@xemacs.org>
+
+ * README (NOTE):
+ Improve X documentation.
+ Document nascent Mule support.
+ Document current MS Windows contributors.
+
+2000-07-15 Ben Wing <ben@xemacs.org>
+
+ * xemacs.mak:
+ added new file win32.c.
+ took out unused alloca.c.
+ * xemacs.mak (update-elc-2): added new target for rebuilding the
+ remaining .elcs after dumped. its dependency is added for target
+ all.
+ * xemacs.mak (update-auto-and-custom):
+ cleaned up ; now it byte-compiles custom-load.el.
+ * xemacs.mak (mostlyclean):
+ * xemacs.mak (clean):
+ * xemacs.mak (nicenclean):
+ * xemacs.mak (distclean):
+ * xemacs.mak (realclean):
+ * xemacs.mak (versionclean):
+ Redid all the clean targets, to be similar to what's in the
+ standard Makefile.
+
+2000-07-18 Kirill 'Big K' Katsnelson <kkm@dtmx.com>
+
+ * xemacs.mak ($(PROGNAME)): Do check error code from temacs during
+ dumping.
+
2000-07-19 Martin Buchholz <martin@xemacs.org>
* XEmacs 21.2.35 is released.
Rebindind C-x and C-c is trickier because by default these are prefix
keys in XEmacs. See the "Key Bindings" node in the XEmacs manual.
-** Behaviour of selected regions
+** Behavior of selected regions
Selected regions behave differently in XEmacs from typical Windows
programs. The pc-select package provides various functions to enable
-the standard Windows behaviour for selected regions (eg mark via
+the standard Windows behavior for selected regions (eg mark via
shift-arrow, self-inserting deletes region, etc).
** Limitations on the use of the AltGr key.
-Building and Installing XEmacs on Windows 95/98/NT -*- mode:outline -*-
+Building and Installing XEmacs on Windows 95/98/NT/2000 -*- mode:outline -*-
David Hobley
Marc Paquette
Jonathan Harris
Ben Wing
-This is a port of XEmacs to Windows 95/98/NT. If you are looking for a port
-of GNU Emacs, see http://www.cs.washington.edu/homes/voelker/ntemacs.html.
-
+This is a port of XEmacs to Windows 95/98/NT/2000. If you are looking for a
+port of GNU Emacs, see http://www.cs.washington.edu/homes/voelker/ntemacs.html.
+NT 3.51 or later is required for building on Windows NT. Note that the
+developers typically use NT 4.0 and Windows 2000, and there may possibly be
+problems under Windows 95/98 and NT 3.51. If so, please report them to
+xemacs-nt@xemacs.org; we are committed to maintaining compatibility with all
+systems listed.
* Required tools and sources
============================
Your PATH environment variable also needs to include the DevStudio
vc\bin and sharedide\bin directories.
- Visual C++ V5.0 installs a batch file called vcvars32.bat in
+ Visual C++ V5.0 and later install a batch file called vcvars32.bat in
c:\Program Files\DevStudio\VC\bin\ (or wherever you installed it) that you
can run before building to set up all of these environment variables.
+ Alternatively, you can choose at setup time to have these
+ environment variables automatically set up in the registry, which
+ is generally a good idea.
+
2. Grab the latest XEmacs source from
ftp://ftp.xemacs.org/pub/xemacs/
- or one of its mirrors listed at http://www.xemacs.org/Download/index.html .
+ or one of its mirrors listed at http://www.xemacs.org/Download/index.html.
+
+ (NOTE: If you are behind a firewall and have problems with FTP access,
+ the URL http://ftp.xemacs.org/pub/xemacs/ works just as well.)
You'll also need the packages. You probably want to get the unified
packages bundle from
ftp://ftp.xemacs.org/pub/xemacs/packages/xemacs-sumo.tar.gz
+ If you are building with international support, you also need
+
+ ftp://ftp.xemacs.org/pub/xemacs/packages/xemacs-mule-sumo.tar.gz
+
Although we don't recommend it, you can also retrieve just the packages
you really need if you have an extremely slow net connection or are very
short on disk space. You can find the various packages in
- ftp://ftp.xemacs.org/pub/xemacs/packages/. You will need the
- xemacs-base package. You'll also need the texinfo package unless you
- have a copy of makeinfo.exe on your machine. If you want to download
- additional or updated packages from within XEmacs you'll need the efs,
- dired and vm packages. You'll probably also want at least the
- edit-utils, text-modes, fsf-compat, cc-mode, prog-modes and xemacs-devel
- packages.
+ ftp://ftp.xemacs.org/pub/xemacs/packages/. You will need the xemacs-base
+ package (and mule-base, if building with international support). You'll
+ also need the texinfo package unless you have a copy of makeinfo.exe on
+ your machine. If you want to download additional or updated packages
+ from within XEmacs you'll need the efs, dired and vm packages. You'll
+ probably also want at least the edit-utils, text-modes, fsf-compat,
+ cc-mode, prog-modes and xemacs-devel packages.
Unpack the packages into "x:\your\choice\XEmacs\xemacs-packages",
for example "c:\Program Files\XEmacs\xemacs-packages".
** Extra tools and sources required for X
+NOTE: XEmacs has not been tested with X support under the native
+Windows build for a long, long time! It may not even compile any
+more. If you are interested in X support, you're better off compiling
+the Cygwin version of XEmacs, which can handle both Win32 native and X
+frames (in the same binary, in fact, but not at the same time), and is
+actively tested with X support.
+
If you want support for X you will also need:
-1. An X server. MI/X is available on the Internet as trialware; it is
- available from: http://www.microimages.com/www/html/mix/
+1. An X server. XEmacs has been tested and runs well under MI/X,
+ available from: http://www.microimages.com/mix/. (International aka
+ "Mule" support even works under this X server!) Unfortunately, this is
+ not free, but is trialware; you have to pay $25 if you want to use it
+ for more than 15 days. XEmacs also runs (barely) under the free XWin
+ server that comes as part of the Cygwin XFree86 package, available at
+
+ ftp://sources.redhat.com/pub/cygwin/xfree/
-2. Source for the MIT X11R6.3 libraries, available from: ftp.x.org
+ or numerous mirrors, such as
+
+ ftp://ftp.freesoftware.com/pub/sourceware/cygwin/xfree/
+
+ There are numerous other X servers available in the same package or at
+ the same location, but unfortunately most of them behave even worse
+ than XWin. If you have any luck with any of these, *PLEASE* email
+ the maintainers at xemacs-nt@xemacs.org, and we'll add the info here.
+
+2. Source for the MIT X11R6.3 libraries, available from ftp.x.org.
3. You'll need to compile the MIT libraries without multi-thread support.
To do this, there is an example Win32.cf and site.def provided which set
config.inc.samp to config.inc. Make any necessary modifications. This
file controls the options that XEmacs is built with:
+ -- If you want international (aka "Mule") support, modify the appropriate
+ line in config.inc as follows:
+
+ HAVE_MULE=1
+
+ NOTE: This support is still quite raw under the Win32 native GUI,
+ but works well if you compile the Cygwin version with X support
+ and disable native Win32 support (--with-msw=no).
+
-- If you're building with XPM support, modify the appropriate lines in
config.inc as follows:
(By default, XEmacs will be installed in directories under the directory
"c:\Program Files\XEmacs\XEmacs-21.2".)
-2. If you want to build xemacs on the command line, use
+3. If you want to build xemacs on the command line, use
`nmake install -f xemacs.mak', or just `nmake -f xemacs.mak' if you want
to run XEmacs from its build directory. nmake will build temacs, the DOC
file, update the elc's, dump xemacs and (optionally) install the relevant
You may want to create a shortcut to the file from your Desktop or
Start Menu.
-3. To build using MS Developer Studio, you can use the workspace file
- `nt/xemacs.dsw'. This was prepared for Visual C++ 5.0; if you have
- a different version and this file doesn't work, just open up
- `nt/xemacs.mak' from within MS Developer Studio and it will offer to
- wrap this Makefile in a workspace file, from which you can build.
- Assuming you want to run from the build directory (which you will
- want to do if you are planning on doing any development work on XEmacs),
- use the following settings in Project/Settings...:
+4. To build using MS Developer Studio, you can use the workspace file
+ `nt/xemacs.dsw'. This was prepared for Visual C++ 6.0. If you are using
+ Visual C++ 5.0, you can use the workspace file `nt/xemacs-vc50.dsw'. If
+ you have a different version and neither file works, just open up
+ `nt/xemacs.mak' from within MS Developer Studio and it will offer to wrap
+ this Makefile in a workspace file, from which you can build. Assuming
+ you want to run from the build directory (which you will want to do if
+ you are planning on doing any development work on XEmacs), use the
+ following settings in Project/Settings...:
Under the General tab:
The XEmacs NT Mailing List: xemacs-nt@xemacs.org
Subscribe address: xemacs-nt-request@xemacs.org
-David Hobley
-Marc Paquette
-August Hill
-Jonathan Harris
-Ben Wing
+Ben Wing (current primary MS Windows maintainer; author of the MS Windows
+ Mule code and some of the dialog box code)
+Andy Piper (MS Windows contributor; author of the Cygwin support and the
+ MS Windows glyph and widget code)
+Jonathan Harris (MS Windows contributor; author of the MS Windows redisplay
+ and underlying GUI code)
+Kirill Katsnelson (MS Windows contributor; author of the MS Windows process
+ and printing code and some of the dialog box code;
+ general guru on obscure MS Windows programming topics)
+David Hobley (early MS Windows contributor)
+Marc Paquette (early MS Windows contributor)
+August Hill (early MS Windows contributor)
and others.
#undef HAVE_SIGHOLD
#undef HAVE_SIGPROCMASK
#undef HAVE_SIGSETJMP
-#undef HAVE_STRCASECMP
#define HAVE_STRERROR
#undef HAVE_TZSET
#undef HAVE_UTIMES
/* If you wish to compile with support for the Network Audio System
system define HAVE_NAS_SOUND.
- NAS_NO_ERROR_JUMP means that the NAS libraries don't inlcude some
+ NAS_NO_ERROR_JUMP means that the NAS libraries don't include some
error handling changes.
*/
#undef HAVE_NAS_SOUND
# Makefile for Microsoft NMAKE
# Copyright (C) 1995 Board of Trustees, University of Illinois.
-# Copyright (C) 1995, 1996 Ben Wing.
+# Copyright (C) 1995, 1996, 2000 Ben Wing.
# Copyright (C) 1995 Sun Microsystems, Inc.
# Copyright (C) 1998 Free Software Foundation, Inc.
#
# #### here, it doesn't seem to matter if we double ^'s!
# results are the same with all single ^ and all double ^^!
# see comment below.
-! if [perl -p -e "s/^\x23ifdef (.+)/!if defined($$1)/; s/^\x23e/!e/;" \
+! if [perl -p -e "s/^\x23if defined(.+)/!if defined$$1/; s/^\x23e/!e/;" \
-e "s/([\s=^])([\w\d\.\-^]+\.[ch^])/$$1$(SRC:\=\\)\\$$2/g;" \
-e "s/^(.+)\.o:(.+)/$(OUTDIR:\=\\)\\$$1.obj:$$2 $(NT:\=\\)\\config.inc/;" \
< $(SRC)\depend > $(OUTDIR)\depend.tmp]
DOC_SRC1=\
$(SRC)\abbrev.c \
$(SRC)\alloc.c \
- $(SRC)\alloca.c \
$(SRC)\blocktype.c \
$(SRC)\buffer.c \
$(SRC)\bytecode.c \
$(SRC)\font-lock.c \
$(SRC)\frame.c \
$(SRC)\general.c \
+ $(SRC)\getloadavg.c \
$(SRC)\glyphs.c \
$(SRC)\glyphs-eimage.c \
$(SRC)\glyphs-widget.c \
$(SRC)\tparam.c \
$(SRC)\undo.c \
$(SRC)\window.c \
+ $(SRC)\win32.c \
$(SRC)\widget.c
!if $(HAVE_X_WINDOWS)
$(TEMACS_DUMP_OBJS)\
$(OUTDIR)\abbrev.obj \
$(OUTDIR)\alloc.obj \
- $(OUTDIR)\alloca.obj \
$(OUTDIR)\blocktype.obj \
$(OUTDIR)\buffer.obj \
$(OUTDIR)\bytecode.obj \
$(OUTDIR)\font-lock.obj \
$(OUTDIR)\frame.obj \
$(OUTDIR)\general.obj \
+ $(OUTDIR)\getloadavg.obj \
$(OUTDIR)\glyphs.obj \
$(OUTDIR)\glyphs-eimage.obj \
$(OUTDIR)\glyphs-widget.obj \
$(OUTDIR)\tparam.obj \
$(OUTDIR)\undo.obj \
$(OUTDIR)\widget.obj \
- $(OUTDIR)\window.obj
+ $(OUTDIR)\window.obj \
+ $(OUTDIR)\win32.obj
# Rules
if exist "$(MAKEINFO)" goto test_done
@$(XEMACS_BATCH) -eval "(condition-case nil (require (quote texinfo)) (t (kill-emacs 1)))"
@if not errorlevel 1 goto suggest_makeinfo
-@echo XEmacs `info' cannot be built!
-@echo Install XEmacs package `texinfo' (see README.packages).
+@echo XEmacs 'info' cannot be built!
+@echo Install XEmacs package 'texinfo' (see README.packages).
:suggest_makeinfo
@echo Consider specifying path to makeinfo program: MAKEINFO=path
-@echo as this will build info docs faster than XEmacs using `texinfo'.
+@echo as this will build info docs faster than XEmacs using 'texinfo'.
@if errorlevel 1 exit 1
:test_done
<<NOKEEP
cd $(TEMACS_DIR)
set EMACSBOOTSTRAPLOADPATH=$(LISP);$(PACKAGE_PATH)
set EMACSBOOTSTRAPMODULEPATH=$(MODULES)
- -1 $(TEMACS_BATCH) -l $(TEMACS_DIR)\..\lisp\loadup.el dump
+ $(TEMACS_BATCH) -l $(TEMACS_DIR)\..\lisp\loadup.el dump
!if $(USE_PORTABLE_DUMPER)
rc -d INCLUDE_DUMP -Fo $(OUTDIR)\xemacs.res $(NT)\xemacs.rc
link.exe @<<
# use this rule to build the complete system
all: installation $(OUTDIR)\nul $(LASTFILE) $(LWLIB) \
$(LIB_SRC_TOOLS) $(TEMACS) update-elc $(DOC) $(PROGNAME) \
- update-auto-and-custom info
+ update-elc-2 update-auto-and-custom info
temacs: $(LASTFILE) $(TEMACS)
@$(DEL) "$(PACKAGE_PREFIX)\xemacs-packages\PlaceHolder"
@$(DEL) PlaceHolder
-distclean:
- $(DEL) *.bak
- $(DEL) *.orig
- $(DEL) *.rej
- $(DEL) *.tmp
+mostlyclean:
$(DEL) $(XEMACS)\Installation
- cd $(OUTDIR)
- $(DEL) *.lib
- $(DEL) *.obj
- $(DEL) *.pdb
- $(DEL) *.res
- $(DEL) *.sbr
- cd $(XEMACS)\$(TEMACS_DIR)
- $(DEL) config.h
- $(DEL) paths.h
- $(DEL) Emacs.ad.h
- $(DEL) *.bak
- $(DEL) *.orig
- $(DEL) *.rej
- $(DEL) *.exe
- $(DEL) *.map
- $(DEL) *.bsc
- $(DEL) *.pdb
- cd $(LIB_SRC)
- $(DEL) DOC
- $(DEL) *.bak
- $(DEL) *.orig
- $(DEL) *.rej
- $(DEL) *.exe
- $(DEL) *.obj
- $(DEL) *.pdb
- $(DEL) *.res
- $(DEL) $(CONFIG_VALUES)
- cd $(LISP)
- $(DEL) /s /q *.bak *.elc *.orig *.rej
- cd $(INFODIR)
- $(DEL) *.info*
+ $(DEL) $(OUTDIR)\*.lib $(OUTDIR)\*.obj $(OUTDIR)\*.pdb
+ $(DEL) $(OUTDIR)\*.res $(OUTDIR)\*.sbr
+ $(DEL) $(SRC)\*.exe $(SRC)\*.map $(SRC)\*.bsc $(SRC)\*.pdb
+ $(DEL) $(LIB_SRC)\*.exe $(LIB_SRC)\*.obj $(LIB_SRC)\*.pdb
+ $(DEL) $(LIB_SRC)\*.res
+
+clean: mostlyclean versionclean
+ $(DEL) $(XEMACS)\TAGS
+
+nicenclean: clean
+ $(DEL) $(NT)\*.bak $(NT)\*.orig $(NT)\*.rej $(NT)\*.tmp
+ $(DEL) $(LIB_SRC)\*.bak $(LIB_SRC)\*.orig $(LIB_SRC)\*.rej
+ $(DEL) $(LIB_SRC)\*.tmp
+ $(DEL) $(SRC)\*.bak $(SRC)\*.orig $(SRC)\*.rej $(SRC)\*.tmp
+ $(DEL) /s $(LISP)\*.bak $(LISP)\*.orig $(LISP)\*.rej $(LISP)\*.tmp
+
+## This is used in making a distribution.
+## Do not use it on development directories!
+distclean: nicenclean
+ $(DEL) $(SRC)\config.h $(SRC)\paths.h $(SRC)\Emacs.ad.h
+ $(DEL) $(LIB_SRC)\$(CONFIG_VALUES)
+ $(DEL) $(INFODIR)\*.info*
+ $(DEL) /s /q $(LISP)\*.elc
+
+realclean: distclean
+
+versionclean:
+ $(DEL) $(SRC)\xemacs.exe $(LIB_SRC)\DOC
+
+#not sure about those wildcards. DOS wildcards are stupid compared to Unix,
+#and could end up deleting *everything* instead of just backup files or
+#whatever.
+#extraclean: realclean
+# $(DEL) *~ *.*~ #* m\*~ m\#* s\*~ s\#*
depend:
cd $(SRC)
@type $(XEMACS)\Installation
@echo --------------------------------------------------------------------
-# Update auto-autoloads.el and custom-load.el similar to what
-# XEmacs.rules does for xemacs-packages.
+# Update out-of-date .elcs, other than needed for dumping.
+update-elc-2:
+ $(XEMACS_BATCH) -l update-elc-2.el -f batch-update-elc-2 $(LISP)
+
+# Update auto-autoloads.el and custom-load.el, similar to what
+# XEmacs.rules does for xemacs-packages. This used to delete
+# auto-autoloads.el first, but that's a bad idea, because it forces
+# rebuilding from scratch, which is time-consuming; and the autoload
+# code is specifically written to do in-place updating. However, if
+# your auto-autoload file is messed up and you want it rebuilt from
+# scratch, delete it from the command line and then nmake with this
+# target.
update-auto-and-custom:
-# Don't delete this, because it forces rebuilding from scratch,
-# which is time-consuming; and the autoload code is specifically
-# written to do in-place updating.
-# @$(DEL) $(LISP)\auto-autoloads.el
# Combine into one invocation to avoid repeated startup penalty.
- $(XEMACS_BATCH) -l autoload -f batch-update-one-directory $(LISP) -f batch-byte-compile-one-file $(LISP)\auto-autoloads.el -l cus-dep -f Custom-make-dependencies $(LISP)
+ $(XEMACS_BATCH) -l autoload -f batch-update-one-directory $(LISP) -f batch-byte-compile-one-file $(LISP)\auto-autoloads.el -l cus-dep -f Custom-make-one-dependency $(LISP) -f batch-byte-compile-one-file $(LISP)\custom-load.el
@$(DEL) $(LISP)\auto-autoloads.el~
+ @$(DEL) $(LISP)\custom-load.el~
# DO NOT DELETE THIS LINE -- make depend depends on it.
* redisplay.c:
(generate_formatted_string_db): new flag to distinguish a modeline
string from a title or icon one, plus use a negative first pos to
- indicate the modeline hscroll ammount.
+ indicate the modeline hscroll amount.
(add_string_to_fstring_db_runes): completely rewrote this function
to handle the case of scrolled modelines.
(add_glyph_to_fstring_db_runes): handle the case of scrolled
* window.c:
(Fmodeline_hscroll): new function to return the modeline current
- horizontal scroll ammount.
+ horizontal scroll amount.
(Fset_modeline_hscroll): new function to scroll the modeline
horizontaly.
Plus some updates related to this new functionality (windows
HEAP_IN_DATA is defined. beef up error message about what to do if
sheap space runs out.
- * sysdep.c: make start_of_data reurn something sensible for
+ * sysdep.c: make start_of_data return something sensible for
HEAP_IN_DATA.
* systime.h: don't use itimer stuff on cygwin b19.
* opaque.c: opaque objects given hash and equal methods, so they
can be compared with 'equal. Menubar uses opaque pointers as
- hash keys in an 'equal style hastable.
+ hash keys in an 'equal style hashtable.
* Most of the above touched files: Eliminated compiler warnings.
(Ffile_newer_than_file_p): ditto
(Fset_visited_file_modtime): ditto
- *fileio.c (Ffile_truename): Unneccessary GC protection.
+ *fileio.c (Ffile_truename): Unnecessary GC protection.
(Fdelete_directory): Fix broken caller-must-GC-protect call.
* filelock.c (lock_file): New comments warning that this function
* keymap.c (lookup_keys): Wrong sense in test.
- * Makefile.in.in: Dont dump font.elc.
+ * Makefile.in.in: Don't dump font.elc.
Sat Feb 15 02:30:51 1997 Steven L Baur <steve@altair.xemacs.org>
$(lwlib_libs) :
cd ../lwlib && $(RECURSIVE_MAKE)
-x_objs=balloon_help.o balloon-x.o console-x.o device-x.o event-Xt.o frame-x.o\
+x_objs=console-x.o device-x.o event-Xt.o frame-x.o\
glyphs-x.o objects-x.o redisplay-x.o select-x.o xgccache.o
#ifdef AIX4
X11_libs = $(LIBI18N)
#endif /* HAVE_X_WINDOWS */
-#if defined (HEAP_IN_DATA) && !defined(PDUMP)
-sheap_obj=sheap.o
+#if defined (HEAP_IN_DATA) && !defined (PDUMP)
+sheap_objs=sheap.o
#endif
-#if defined(MINGW) || defined(CYGWIN)
-res_obj=xemacs_res.o
+#if defined (WIN32_NATIVE) || defined (CYGWIN)
+win32_objs=win32.o xemacs_res.o
#endif
## -Demacs is needed to make some files produce the correct version
macros.o marker.o md5.o minibuf.o objects.o opaque.o\
print.o process.o profile.o\
rangetab.o redisplay.o redisplay-output.o regex.o\
- search.o select.o $(sheap_obj) signal.o sound.o\
+ search.o select.o $(sheap_objs) signal.o sound.o\
specifier.o strftime.o symbols.o syntax.o sysdep.o\
- undo.o $(x_objs) widget.o window.o $(res_obj)
+ undo.o $(x_objs) widget.o window.o $(win32_objs)
obj_rtl = $(objs:.o=.c.rtl)
./${PROGNAME} -batch -vanilla -f list-load-path-shadows; fi; \
$(RM) SATISFIED; exit 0; fi; \
if test -f SATISFIED; then $(RM) SATISFIED; exit 1; fi; \
- @$(RM) $@; \
+ $(RM) $@; \
$(RECURSIVE_MAKE) $@;
#else
@$(RM) $@
-search-mmaps=yes\
#endif
-chain-length=32 -ignore-signals=SIGPOLL -threads=yes\
- -cache-dir=./purecache -always-use-cache-dir=yes
+ -cache-dir=${srcdir}/purecache -always-use-cache-dir=yes
PURIFY_LIBS = -lpthread
puremacs: $(temacs_deps)
$(CC) -dr -c $(cflags) -DDEFINE_TRANSIENT_EMACS_SHELL ${srcdir}/EmacsShell-sub.c
mv EmacsShell-sub.c.rtl TransientEmacsShell.c.rtl
+## The above rules are subject to a race condition if using a parallel make.
+TransientEmacsShell.o : TopLevelEmacsShell.o
+TransientEmacsShell.c.rtl : TopLevelEmacsShell.c.rtl
+
## Position-independent code for shared library creation
#if USE_GCC
pic_arg = -fpic
.PHONY: mostlyclean clean distclean realclean versionclean extraclean
mostlyclean:
- $(RM) temacs puremacs quantmacs prefix-args *.o *.i \
+ $(RM) temacs puremacs quantmacs *.o *.i \
core temacs.exe sheap-adjust.h
clean: mostlyclean versionclean
$(RM) libextcli* update-elc.stamp
GNUmakefile Makefile Makefile.in TAGS ${PROGNAME}.*
realclean: distclean
versionclean:
- $(RM) ${PROGNAME} ${PROGNAME}.exe ${libsrc}DOC
+ $(RM) ${EXE_TARGET} ${DUMP_TARGET} ${libsrc}DOC
extraclean: realclean
$(RM) *~ \#* m/*~ m/\#* s/*~ s/\#*
/* Synched up with: FSF 19.30. */
-/* Authorsip:
+/* Authorship:
FSF: A long time ago.
Very few changes for XEmacs.
unsigned size;
{
auto char probe; /* Probes stack depth: */
- REGISTER char *depth = ADDRESS_FUNCTION (probe);
+ register char *depth = ADDRESS_FUNCTION (probe);
#if STACK_DIRECTION == 0
if (STACK_DIR == 0) /* Unknown growth direction. */
was allocated from deeper in the stack than currently. */
{
- REGISTER header *hp; /* Traverses linked list. */
+ register header *hp; /* Traverses linked list. */
for (hp = last_alloca_header; hp != NULL;)
if ((STACK_DIR > 0 && hp->h.deep > depth)
|| (STACK_DIR < 0 && hp->h.deep < depth))
{
- REGISTER header *np = hp->h.next;
+ register header *np = hp->h.next;
free ((pointer) hp); /* Collect garbage. */
/* Allocate combined header + user data storage. */
{
- REGISTER pointer new = malloc (sizeof (header) + size);
+ register pointer new = malloc (sizeof (header) + size);
/* Address of header. */
((header *) new)->h.next = last_alloca_header;
funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
{
/* This function can GC */
- Lisp_Object symbol, tail;
int speccount = specpdl_depth();
REGISTER int i = 0;
Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
and local variables of fun. So just reserve it once. */
SPECPDL_RESERVE (f->specpdl_depth);
- /* Fmake_byte_code() guaranteed that f->arglist is a valid list
- containing only non-constant symbols. */
- LIST_LOOP_3 (symbol, f->arglist, tail)
- {
- if (EQ (symbol, Qand_rest))
- {
- tail = XCDR (tail);
- symbol = XCAR (tail);
- SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
- goto run_code;
- }
- else if (EQ (symbol, Qand_optional))
- optional = 1;
- else if (i == nargs && !optional)
- goto wrong_number_of_arguments;
- else
- SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
- }
+ {
+ /* Fmake_byte_code() guaranteed that f->arglist is a valid list
+ containing only non-constant symbols. */
+ LIST_LOOP_3 (symbol, f->arglist, tail)
+ {
+ if (EQ (symbol, Qand_rest))
+ {
+ tail = XCDR (tail);
+ symbol = XCAR (tail);
+ SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
+ goto run_code;
+ }
+ else if (EQ (symbol, Qand_optional))
+ optional = 1;
+ else if (i == nargs && !optional)
+ goto wrong_number_of_arguments;
+ else
+ SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
+ }
+ }
if (i < nargs)
goto wrong_number_of_arguments;
{
INIT_LRECORD_IMPLEMENTATION (compiled_function);
- deferror (&Qinvalid_byte_code, "invalid-byte-code",
- "Invalid byte code", Qerror);
+ DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
defsymbol (&Qbyte_code, "byte-code");
defsymbol (&Qcompiled_functionp, "compiled-function-p");
if (fd_error < 0)
{
+ int save_errno = errno;
close (filefd);
close (fd[0]);
if (fd1 >= 0)
close (fd1);
+ errno = save_errno;
report_file_error ("Cannot open", Fcons(error_file, Qnil));
}
#ifndef WIN32_NATIVE
if (pid < 0)
{
+ int save_errno = errno;
if (fd[0] >= 0)
close (fd[0]);
+ errno = save_errno;
report_file_error ("Doing fork", Qnil);
}
#endif
char *
egetenv (const char *var)
{
+ /* This cannot GC -- 7-28-00 ben */
Bufbyte *value;
Bytecount valuelen;
void
mswindows_show_console (void)
{
+ /* What I really want is for the console window to appear on top of other
+ windows, but NOT get the focus. This seems hard-to-impossible under
+ Windows. The following sequence seems to do the best possible, along
+ with keeping the console window on top when xemacs --help is used. */
HWND hwnd = mswindows_get_console_hwnd ();
- ShowWindow (hwnd, SW_SHOWNA);
-
- /* I tried to raise the window to the top without activating
- it, but this fails. Apparently Windows just doesn't like
- having the active window not be on top. So instead, we
- at least put it just below our own window, where part of it
- will likely be seen. */
- SetWindowPos (hwnd, GetForegroundWindow (), 0, 0, 0, 0,
- SWP_NOSIZE | SWP_NOMOVE | SWP_NOSENDCHANGING |
- SWP_NOACTIVATE);
+ HWND hwndf = GetFocus ();
+ ShowWindow (hwnd, SW_SHOW);
+ BringWindowToTop (hwnd);
+ SetFocus (hwndf);
}
static int mswindows_console_buffered = 0;
return GetVersion () & 0x80000000;
}
+DEFUN ("mswindows-debugging-output", Fmswindows_debugging_output, 1, 1, 0, /*
+Write CHAR-OR-STRING to the Windows debugger, using OutputDebugString().
+This function can be used as the STREAM argument of Fprint() or the like.
+*/
+ (char_or_string))
+{
+ Extbyte *extstr;
+
+ if (STRINGP (char_or_string))
+ {
+ TO_EXTERNAL_FORMAT (LISP_STRING, char_or_string,
+ C_STRING_ALLOCA, extstr,
+ Qmswindows_tstr);
+ OutputDebugString (extstr);
+ }
+ else
+ {
+ Bufbyte str[MAX_EMCHAR_LEN + 1];
+ Bytecount len;
+
+ CHECK_CHAR_COERCE_INT (char_or_string);
+ len = set_charptr_emchar (str, XCHAR (char_or_string));
+ str[len] = '\0';
+ TO_EXTERNAL_FORMAT (C_STRING, str,
+ C_STRING_ALLOCA, extstr,
+ Qmswindows_tstr);
+ OutputDebugString (extstr);
+ }
+
+ return char_or_string;
+}
#ifdef DEBUG_XEMACS
Extbyte *titleout = 0;
UINT sty = 0;
- if (noninteractive)
- return Qcancel;
-
- if (!CONSP (flags))
+ if (!LISTP (flags))
{
CHECK_SYMBOL (flags);
flags = list1 (flags);
frob, errval, (char*)lpMsgBuf);
}
+static Lisp_Object
+msprinter_canonicalize_console_connection (Lisp_Object connection,
+ Error_behavior errb)
+{
+ /* If nil connection is specified, transform it into the name
+ of the default printer */
+ if (NILP (connection))
+ {
+ connection = msprinter_default_printer ();
+ if (NILP (connection))
+ {
+ if (ERRB_EQ (errb, ERROR_ME))
+ error ("There is no default printer in the system");
+ else
+ return Qunbound;
+ }
+ }
+
+ CHECK_STRING (connection);
+ return connection;
+}
+
+static Lisp_Object
+msprinter_canonicalize_device_connection (Lisp_Object connection,
+ Error_behavior errb)
+{
+ return msprinter_canonicalize_console_connection (connection, errb);
+}
+
\f
/************************************************************************/
/* initialization */
void
syms_of_console_mswindows (void)
{
+ DEFSUBR (Fmswindows_debugging_output);
+
defsymbol (&Qabortretryignore, "abortretryignore");
defsymbol (&Qapplmodal, "applmodal");
defsymbol (&Qdefault_desktop_only, "default-desktop-only");
/* CONSOLE_HAS_METHOD (mswindows, semi_canonicalize_device_connection); */
INITIALIZE_CONSOLE_TYPE (msprinter, "msprinter", "console-msprinter-p");
+ CONSOLE_HAS_METHOD (msprinter, canonicalize_console_connection);
+ CONSOLE_HAS_METHOD (msprinter, canonicalize_device_connection);
}
void
typedef struct Lisp_Devmode
{
struct lcrecord_header header;
-
+
/* Pointer to the DEVMODE structure */
DEVMODE* devmode;
/* Full printer name. It can be longer than devmode->dmDeviceName
- can accomodate, so need to keep it separately */
+ can accommodate, so need to keep it separately */
char* printer_name;
/* Printer device this object is currently selected in, or Qnil
Lisp_Object fontlist; /* List of strings, device fonts */
HDC hcdc; /* Compatible DC */
DWORD update_tick; /* Used when device is modified through
- Windows mwssages, see WM_DISPLAYCHANGE
+ Windows messages, see WM_DISPLAYCHANGE
in event-msw.c */
};
/* Time of last click event, for button 2 emul */
DWORD last_click_time;
+ /* Mods of last click event */
+ DWORD last_click_mods;
+
/* Coordinates of last click event, screen-relative */
POINTS last_click_point;
#ifdef HAVE_TOOLBARS
int ignore_next_rbutton_up : 1;
int sizing : 1;
int paint_pending : 1; /* Whether a WM_PAINT magic event has been queued */
+ int popup : 1; /* frame is a popup frame */
/* Geometry, in characters, as specified by proplist during frame
- creation. Memebers are set to -1 for unspecified */
+ creation. Members are set to -1 for unspecified */
XEMACS_RECT_WH* target_rect;
};
#define FRAME_MSWINDOWS_CHARWIDTH(f) (FRAME_MSWINDOWS_DATA (f)->charwidth)
#define FRAME_MSWINDOWS_CHARHEIGHT(f) (FRAME_MSWINDOWS_DATA (f)->charheight)
#define FRAME_MSWINDOWS_TARGET_RECT(f) (FRAME_MSWINDOWS_DATA (f)->target_rect)
+#define FRAME_MSWINDOWS_POPUP(f) (FRAME_MSWINDOWS_DATA (f)->popup)
/* Frame check and validation macros */
#define FRAME_MSWINDOWS_P(frm) CONSOLE_TYPESYM_MSWINDOWS_P (FRAME_TYPE (frm))
{
int left_margin, top_margin, /* All in twips */
right_margin, bottom_margin;
- int charheight, charwidth; /* As per proplist or -1 if not gven */
+ int charheight, charwidth; /* As per proplist or -1 if not given */
int pix_left, pix_top; /* Calculated in init_frame_*, VP offset */
int job_started : 1;
int page_started : 1;
UINT msg, WPARAM wParam,
LPARAM lParam);
-void mswindows_redraw_exposed_area (struct frame *f, int x, int y,
+void mswindows_redraw_exposed_area (struct frame *f, int x, int y,
int width, int height);
void mswindows_size_frame_internal (struct frame* f, XEMACS_RECT_WH* dest);
HWND mswindows_get_selected_frame_hwnd (void);
void mswindows_enqueue_magic_event (HWND hwnd, UINT msg);
+int mswindows_is_dialog_msg (MSG *msg);
/* win32 DDE management library */
#define MSWINDOWS_DDE_ITEM_OPEN "Open"
int mswindows_windows9x_p (void);
-
void mswindows_output_last_error (char *frob);
+Lisp_Object mswindows_handle_print_dialog_box (struct frame *f,
+ Lisp_Object keys);
+Lisp_Object mswindows_handle_page_setup_dialog_box (struct frame *f,
+ Lisp_Object keys);
+Lisp_Object mswindows_handle_print_setup_dialog_box (struct frame *f,
+ Lisp_Object keys);
+
+void mswindows_register_popup_frame (Lisp_Object frame);
+void mswindows_unregister_popup_frame (Lisp_Object frame);
+
+void mswindows_destroy_selection (Lisp_Object selection);
+
+Lisp_Object msprinter_default_printer (void);
+
+struct mswindows_dialog_id
+{
+ struct lcrecord_header header;
+
+ Lisp_Object frame;
+ Lisp_Object callbacks;
+ HWND hwnd;
+};
+
+DECLARE_LRECORD (mswindows_dialog_id, struct mswindows_dialog_id);
+#define XMSWINDOWS_DIALOG_ID(x) XRECORD (x, mswindows_dialog_id, struct mswindows_dialog_id)
+#define XSETMSWINDOWS_DIALOG_ID(x, p) XSETRECORD (x, p, mswindows_dialog_id)
+#define MSWINDOWS_DIALOG_IDP(x) RECORDP (x, mswindows_dialog_id)
+#define CHECK_MSWINDOWS_DIALOG_ID(x) CHECK_RECORD (x, mswindows_dialog_id)
+#define CONCHECK_MSWINDOWS_DIALOG_ID(x) CONCHECK_RECORD (x, mswindows_dialog_id)
+
#endif /* INCLUDED_console_msw_h_ */
if (NILP (CONSOLE_NAME (con)))
CONSOLE_NAME (con) = Ffile_name_nondirectory (tty);
{
- int tty_pg;
- int controlling_tty_pg;
+ pid_t tty_pg;
+ pid_t controlling_tty_pg;
int cfd;
/* OK, the only sure-fire way I can think of to determine
/* Synched up with: Not in FSF. */
+/* This file Mule-ized by Ben Wing, 7-10-00. */
+
/* Authorship:
Ben Wing: January 1996, for 19.14.
#include "lisp.h"
#include "console-x.h"
+#include "buffer.h"
#include "process.h" /* canonicalize_host_name */
#include "redisplay.h" /* for display_arg */
split_up_display_spec (Lisp_Object display, int *hostname_length,
int *display_length, int *screen_length)
{
- char *dotptr;
+ Bufbyte *dotptr;
dotptr = strrchr ((char *) XSTRING_DATA (display), ':');
if (!dotptr)
}
else
{
- *hostname_length = dotptr - (char *) XSTRING_DATA (display);
+ *hostname_length = dotptr - XSTRING_DATA (display);
- dotptr = strchr (dotptr, '.');
+ dotptr = strchr ((char *) dotptr, '.');
if (dotptr)
- *display_length = (dotptr - (char *) XSTRING_DATA (display)
- - *hostname_length);
+ *display_length = (dotptr - XSTRING_DATA (display) - *hostname_length);
else
*display_length = XSTRING_LENGTH (display) - *hostname_length;
}
static Lisp_Object
get_display_arg_connection (void)
{
- const char *disp_name;
+ const Extbyte *disp_name;
/* If the user didn't explicitly specify a display to use when
they called make-x-device, then we first check to see if a
{
int elt;
int argc;
- char **argv;
+ Extbyte **argv;
Lisp_Object conn;
make_argc_argv (Vx_initial_argv_list, &argc, &argv);
if (elt + 1 == argc)
{
suppress_early_error_handler_backtrace = 1;
- error ("-display specified with no arg");
+ type_error (Qinvalid_argument,
+ "-display specified with no arg");
}
else
{
/* assert: display_arg is only set if we found the display
arg earlier so we can't fail to find it now. */
assert (disp_name != NULL);
- conn = build_ext_string (disp_name, Qctext);
+ conn = build_ext_string (disp_name, Qcommand_argument_encoding);
free_argc_argv (argv);
return conn;
}
else
- return build_ext_string (XDisplayName (0), Qctext);
+ return build_ext_string (XDisplayName (0), Qx_display_name_encoding);
}
/* "semi-canonicalize" means convert to a nicer form for printing, but
/* Check for a couple of standard special cases */
if (string_byte (XSTRING (connection), 0) == ':')
connection = concat2 (build_string ("localhost"), connection);
- else if (!strncmp ((const char *) XSTRING_DATA (connection),
- "unix:", 5))
+ else if (!strncmp (XSTRING_DATA (connection), "unix:", 5))
connection = concat2 (build_string ("localhost:"),
Fsubstring (connection, make_int (5), Qnil));
split_up_display_spec (connection, &hostname_length, &display_length,
&screen_length);
- screen_str = build_string ((const char *) XSTRING_DATA (connection)
+ screen_str = build_string (XSTRING_DATA (connection)
+ hostname_length + display_length);
connection = x_canonicalize_console_connection (connection, errb);
#include "frame.h"
#include "sysdep.h"
-/* #### Andy, these includes might break cygwin compilation - kkm*/
#include <commdlg.h>
-#include <winspool.h>
#if !(defined (CYGWIN) || defined(MINGW))
-# include <objbase.h> /* For CoInitialize */
+#include <objbase.h> /* For CoInitialize */
#endif
/* win32 DDE management library globals */
nil means no, t means yes. */
Lisp_Object Vmswindows_downcase_file_names;
-/* Control whether stat() attempts to determine file type and link count
+/* Control whether xemacs_stat() attempts to determine file type and link count
exactly, at the expense of slower operation. Since true hard links
are supported on NTFS volumes, this is only relevant on NT. */
Lisp_Object Vmswindows_get_true_file_attributes;
wc.cbWndExtra = MSWINDOWS_WINDOW_EXTRA_BYTES;
/* This must match whatever is passed to CreateWIndowEx, NULL is ok
for this. */
- wc.hInstance = NULL;
+ wc.hInstance = NULL;
wc.hIcon = LoadIcon (GetModuleHandle(NULL), XEMACS_CLASS);
wc.hCursor = LoadCursor (NULL, IDC_ARROW);
/* Background brush is only used during sizing, when XEmacs cannot
wc.lpszMenuName = NULL;
wc.lpszClassName = XEMACS_CLASS;
- wc.hIconSm = (HICON) LoadImage (GetModuleHandle (NULL), XEMACS_CLASS,
- IMAGE_ICON, 16, 16, 0);
- RegisterClassEx (&wc);
+ if (xLoadImageA) /* not in NT 3.5 */
+ wc.hIconSm = (HICON) xLoadImageA (GetModuleHandle (NULL), XEMACS_CLASS,
+ IMAGE_ICON, 16, 16, 0);
+ else
+ wc.hIconSm = 0;
+
+ if (xRegisterClassExA) /* not in NT 3.5 */
+ xRegisterClassExA (&wc);
+ else
+ RegisterClassA ((WNDCLASS *) &wc.style);
#ifdef HAVE_WIDGETS
xzero (wc);
wc.lpfnWndProc = (WNDPROC) mswindows_control_wnd_proc;
wc.lpszClassName = XEMACS_CONTROL_CLASS;
wc.hInstance = NULL;
- RegisterClassEx (&wc);
+ if (xRegisterClassExA) /* not in NT 3.5 */
+ xRegisterClassExA (&wc);
+ else
+ RegisterClassA ((WNDCLASS *) &wc.style);
#endif
#if defined (HAVE_TOOLBARS) || defined (HAVE_WIDGETS)
APPCMD_FILTERINITS|CBF_FAIL_SELFCONNECTIONS|CBF_FAIL_ADVISES|
CBF_FAIL_POKES|CBF_FAIL_REQUESTS|CBF_SKIP_ALLNOTIFICATIONS,
0);
-
+
mswindows_dde_service = DdeCreateStringHandle (mswindows_dde_mlid,
XEMACS_CLASS, 0);
mswindows_dde_topic_system = DdeCreateStringHandle (mswindows_dde_mlid,
#define FROB(met, fore, back) \
case DM_##met: \
return build_syscolor_cons (fore, back);
-
+
FROB (color_default, COLOR_WINDOWTEXT, COLOR_WINDOW);
FROB (color_select, COLOR_HIGHLIGHTTEXT, COLOR_HIGHLIGHT);
FROB (color_balloon, COLOR_INFOTEXT, COLOR_INFOBK);
static void
signal_open_printer_error (struct device *d)
{
- signal_simple_error ("Failed to open printer", DEVICE_CONNECTION (d));
+ invalid_operation ("Failed to open printer", DEVICE_CONNECTION (d));
}
DEVICE_MSPRINTER_FONTLIST (d) = Qnil;
}
-static int msprinter_reinit_device (struct device *d, char* devname)
+static int
+msprinter_reinit_device (struct device *d, char* devname)
{
msprinter_delete_device_internal (d);
return msprinter_init_device_internal (d, devname);
}
+Lisp_Object
+msprinter_default_printer (void)
+{
+ Extbyte name[666];
+ Bufbyte *nameint;
+
+ if (GetProfileString (XETEXT ("windows"), XETEXT ("device"), NULL, name,
+ sizeof (name) / XETCHAR_SIZE) <= 0)
+ return Qnil;
+ EXTERNAL_TO_C_STRING (name, nameint, Qmswindows_tstr);
+
+ if (name[0] == '\0')
+ return Qnil;
+ strtok (name, ",");
+
+ return build_string (name);
+}
+
\f
/************************************************************************/
/* printer methods */
if (!msprinter_init_device_internal (d, printer_name))
signal_open_printer_error (d);
-
- /* Determinie DEVMODE size and store the default DEVMODE */
- dm_size = DocumentProperties (NULL, DEVICE_MSPRINTER_HPRINTER(d),
+
+ /* Determine DEVMODE size and store the default DEVMODE */
+ dm_size = DocumentProperties (NULL, DEVICE_MSPRINTER_HPRINTER (d),
printer_name, NULL, NULL, 0);
if (dm_size <= 0)
signal_open_printer_error (d);
assert (DEVMODE_SIZE (pdm) <= dm_size);
- DEVICE_MSPRINTER_DEVMODE(d) =
+ DEVICE_MSPRINTER_DEVMODE(d) =
allocate_devmode (pdm, 0, printer_name, d);
}
therefore useless */
return make_int (GetDeviceCaps (DEVICE_MSPRINTER_HDC(d), BITSPIXEL));
- case DM_num_color_cells: /* Prnters are non-palette devices */
+ case DM_num_color_cells: /* Printers are non-palette devices */
case DM_slow_device: /* Animation would be a really bad idea */
case DM_security: /* Not provided by windows */
return Qzero;
DEVICE_MSPRINTER_HDC (d) =
CreateDC ("WINSPOOL", DEVICE_MSPRINTER_NAME(d), NULL, devmode_out);
}
-
+
return 1;
}
{
Lisp_Object device;
XSETDEVICE (device, d);
- signal_simple_error ("Cannot change settings while print job is active",
- device);
+ invalid_operation ("Cannot change settings while print job is active",
+ device);
}
}
return XDEVMODE (dev);
else
{
- struct device* d = decode_device (dev);
- Lisp_Object device;
- XSETDEVICE (device, d);
- CHECK_MSPRINTER_DEVICE (device);
- ensure_not_printing (d);
- return XDEVMODE (DEVICE_MSPRINTER_DEVMODE (d));
+ ensure_not_printing (XDEVICE (dev));
+ return XDEVMODE (DEVICE_MSPRINTER_DEVMODE (XDEVICE (dev)));
}
}
}
}
-DEFUN ("msprinter-print-setup-dialog", Fmsprinter_print_setup_dialog, 1, 1, 0, /*
-Invoke Windows standard Printer Setup dialog.
-This dialog is usually invoked when the user selects the Printer Setup
-command.
-
-DEVICE must be either an 'msprinter device, or a printer settings
-object. The function brings up the Printer Setup dialog, where the user
-can select a different printer and/or change printer options.
-Connection name can change as a result of selecting a different printer
-device. If a printer is specified, then changes are stored into the
-settings object currently selected into that printer. If a settings
-object is supplied, then changes are recorded into it, and, it it is
-selected into a printer, then changes are propagated to that printer
-too.
-
-Return value is nil if the user has canceled the dialog. Otherwise, it
-is a new plist, with the following properties:
- name Printer device name, even if unchanged by the user.
-
-The printer device is destroyed and an error is signaled if new printer
-is selected by the user, but cannot be initialized.
-
-See also `msprinter-print-dialog' and `msprinter-page-setup-dialog'.
-*/
- (device))
+Lisp_Object
+mswindows_handle_print_setup_dialog_box (struct frame *f, Lisp_Object keys)
{
- return print_dialog_worker (device, 0);
+ Lisp_Object device = Qunbound, settings = Qunbound;
+
+ {
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, keys)
+ {
+ if (EQ (key, Q_device))
+ {
+ device = wrap_device (decode_device (value));
+ CHECK_MSPRINTER_DEVICE (device);
+ }
+ else if (EQ (key, Q_printer_settings))
+ {
+ CHECK_DEVMODE (value);
+ settings = value;
+ }
+ else
+ syntax_error ("Unrecognized print-dialog keyword", key);
+ }
+ }
+
+ if ((UNBOUNDP (device) && UNBOUNDP (settings)) ||
+ (!UNBOUNDP (device) && !UNBOUNDP (settings)))
+ syntax_error ("Exactly one of :device and :printer-settings must be given",
+ keys);
+
+ return print_dialog_worker (!UNBOUNDP (device) ? device : settings, 0);
}
-DEFUN ("msprinter-print-dialog", Fmsprinter_print_dialog, 1, 1, 0, /*
-Invoke Windows standard Print dialog.
-This dialog is usually invoked when the user selects the Print command.
-After the user presses OK, the program should start actual printout.
-
-DEVICE must be either an 'msprinter device, or a printer settings
-object. The function brings up the Print dialog, where the user can
-select a different printer and/or change printer options. Connection
-name can change as a result of selecting a different printer device. If
-a printer is specified, then changes are stored into the settings object
-currently selected into that printer. If a settings object is supplied,
-then changes are recorded into it, and, it it is selected into a
-printer, then changes are propagated to that printer
-too.
-
-Return value is nil if the user has canceled the dialog. Otherwise, it
-is a new plist, with the following properties:
- name Printer device name, even if unchanged by the user.
- from-page First page to print, 1-based. If not specified by the user,
- then this value is not included in the plist.
- to-page Last page to print, inclusive, 1-based. If not specified by
- the user, then this value is not included in the plist.
- copies Number of copies to print. Always returned.
-
-The DEVICE is destroyed and an error is signaled in case of
-initialization problem with the new printer.
-
-See also `msprinter-setup-print-dialog' and
-`msprinter-page-setup-dialog'.
-*/
- (device))
+Lisp_Object
+mswindows_handle_print_dialog_box (struct frame *f, Lisp_Object keys)
{
- return print_dialog_worker (device, 1);
-}
+ Lisp_Object device = Qunbound, settings = Qunbound;
+
+ {
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, keys)
+ {
+ if (EQ (key, Q_device))
+ {
+ device = wrap_device (decode_device (value));
+ CHECK_MSPRINTER_DEVICE (device);
+ }
+ else if (EQ (key, Q_printer_settings))
+ {
+ CHECK_DEVMODE (value);
+ settings = value;
+ }
+ else
+ syntax_error ("Unrecognized print-dialog keyword", key);
+ }
+ }
+ if ((UNBOUNDP (device) && UNBOUNDP (settings)) ||
+ (!UNBOUNDP (device) && !UNBOUNDP (settings)))
+ syntax_error ("Exactly one of :device and :printer-settings must be given",
+ keys);
+
+ return print_dialog_worker (!UNBOUNDP (device) ? device : settings, 1);
+}
static int
plist_get_margin (Lisp_Object plist, Lisp_Object prop)
{
Lisp_Object val = Fplist_get (plist, prop, make_int (1440));
if (!INTP (val))
- signal_simple_error ("Margin value must be an integer", val);
+ invalid_argument ("Margin value must be an integer", val);
return MulDiv (XINT (val), 100, 144);
}
return Fcons (prop, Fcons (val, plist));
}
-DEFUN ("msprinter-page-setup-dialog", Fmsprinter_page_setup_dialog, 1, 2, 0, /*
-Invoke Windows standard Page Setup dialog.
-This dialog is usually invoked in response to Page Setup command, and
-used to chose such parameters as page orientation, print margins etc.
-Note that this dialog contains the "Printer" button, which invokes
-Printer Setup dialog (see `msprinter-print-setup-dialog') so that the
-user can update the printer options or even select a different printer
-as well.
-
-DEVICE must be either an 'msprinter device, or a printer settings
-object. The function brings up the Page Setup dialog, where the user
-can select a different printer and/or change printer options.
-Connection name can change as a result of selecting a different printer
-device. If a printer is specified, then changes are stored into the
-settings object currently selected into that printer. If a settings
-object is supplied, then changes are recorded into it, and, it it is
-selected into a printer, then changes are propagated to that printer
-too.
-
-PLIST is a plist of job properties;
-see `default-msprinter-frame-plist' for the complete list. The plist
-is used to initialize the dialog.
-
-Return value is nil if the user has canceled the dialog. Otherwise,
-it is a new plist, containing the new list of properties.
-
-The DEVICE is destroyed and an error is signaled in case of
-initialization problem with the new printer.
-
-See also `msprinter-print-setup-dialog' and `msprinter-print-dialog'.
-*/
- (device, plist))
+Lisp_Object
+mswindows_handle_page_setup_dialog_box (struct frame *f, Lisp_Object keys)
{
- Lisp_Devmode *ldm = decode_devmode (device);
- PAGESETUPDLG pd;
+ Lisp_Object device = Qunbound, settings = Qunbound;
+ Lisp_Object plist = Qnil;
- memset (&pd, 0, sizeof (pd));
- pd.lStructSize = sizeof (pd);
- pd.hwndOwner = mswindows_get_selected_frame_hwnd ();
- pd.Flags = PSD_MARGINS;
- pd.rtMargin.left = plist_get_margin (plist, Qleft_margin);
- pd.rtMargin.top = plist_get_margin (plist, Qtop_margin);
- pd.rtMargin.right = plist_get_margin (plist, Qright_margin);
- pd.rtMargin.bottom = plist_get_margin (plist, Qbottom_margin);
- pd.hDevMode = devmode_to_hglobal (ldm);
+ {
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, keys)
+ {
+ if (EQ (key, Q_device))
+ {
+ device = wrap_device (decode_device (value));
+ CHECK_MSPRINTER_DEVICE (device);
+ }
+ else if (EQ (key, Q_printer_settings))
+ {
+ CHECK_DEVMODE (value);
+ settings = value;
+ }
+ else if (EQ (key, Q_properties))
+ {
+ CHECK_LIST (value);
+ plist = value;
+ }
+ else
+ syntax_error ("Unrecognized page-setup dialog keyword", key);
+ }
+ }
- if (!PageSetupDlg (&pd))
- {
- global_free_2_maybe (pd.hDevNames, pd.hDevMode);
- return Qnil;
- }
+ if ((UNBOUNDP (device) && UNBOUNDP (settings)) ||
+ (!UNBOUNDP (device) && !UNBOUNDP (settings)))
+ syntax_error ("Exactly one of :device and :printer-settings must be given",
+ keys);
- if (pd.hDevMode)
- handle_devmode_changes (ldm, pd.hDevNames, pd.hDevMode);
+ if (UNBOUNDP (device))
+ device = settings;
- /* Finally, build the resulting plist */
{
- Lisp_Object result = Qnil;
- int mm_p = pd.Flags & PSD_INHUNDREDTHSOFMILLIMETERS;
- result = plist_set_margin (result, Qbottom_margin, pd.rtMargin.bottom, mm_p);
- result = plist_set_margin (result, Qright_margin, pd.rtMargin.right, mm_p);
- result = plist_set_margin (result, Qtop_margin, pd.rtMargin.top, mm_p);
- result = plist_set_margin (result, Qleft_margin, pd.rtMargin.left, mm_p);
- return result;
+ Lisp_Devmode *ldm = decode_devmode (device);
+ PAGESETUPDLG pd;
+
+ memset (&pd, 0, sizeof (pd));
+ pd.lStructSize = sizeof (pd);
+ pd.hwndOwner = mswindows_get_selected_frame_hwnd ();
+ pd.Flags = PSD_MARGINS;
+ pd.rtMargin.left = plist_get_margin (plist, Qleft_margin);
+ pd.rtMargin.top = plist_get_margin (plist, Qtop_margin);
+ pd.rtMargin.right = plist_get_margin (plist, Qright_margin);
+ pd.rtMargin.bottom = plist_get_margin (plist, Qbottom_margin);
+ pd.hDevMode = devmode_to_hglobal (ldm);
+
+ if (!PageSetupDlg (&pd))
+ {
+ global_free_2_maybe (pd.hDevNames, pd.hDevMode);
+ return Qnil;
+ }
+
+ if (pd.hDevMode)
+ handle_devmode_changes (ldm, pd.hDevNames, pd.hDevMode);
+
+ /* Finally, build the resulting plist */
+ {
+ Lisp_Object result = Qnil;
+ int mm_p = pd.Flags & PSD_INHUNDREDTHSOFMILLIMETERS;
+ result = plist_set_margin (result, Qbottom_margin, pd.rtMargin.bottom,
+ mm_p);
+ result = plist_set_margin (result, Qright_margin, pd.rtMargin.right,
+ mm_p);
+ result = plist_set_margin (result, Qtop_margin, pd.rtMargin.top, mm_p);
+ result = plist_set_margin (result, Qleft_margin, pd.rtMargin.left, mm_p);
+ return result;
+ }
}
}
If the supplied settings object is not specialized, it is specialized
for the printer immediately upon selection. The object can be
despecialized after it is unselected by calling the function
-`msprinter-settings-despecialize'.
+`msprinter-settings-despecialize'.
Return value is the previously selected settings object.
*/
ldm = XDEVMODE (settings);
if (!NILP (ldm->device))
- signal_simple_error ("The object is currently selected into a device",
- settings);
+ invalid_operation ("The object is currently selected into a device",
+ settings);
/* If the object being selected is de-specialized, then its
size is perhaps not enough to receive the new devmode. We can ask
DocumentProperties (NULL, DEVICE_MSPRINTER_HPRINTER(d),
DEVICE_MSPRINTER_NAME(d), NULL, NULL, 0);
if (dm_size <= 0)
- signal_simple_error ("Unable to specialize settings, printer error",
- device);
+ invalid_operation ("Unable to specialize settings, printer error",
+ device);
assert (XDEVMODE_SIZE (ldm) <= dm_size);
ldm->devmode = xrealloc (ldm->devmode, dm_size);
}
/* If we bail out on signal here, no damage is done, except that
- the stirage for the DEVMODE structure might be reallocated to
+ the storage for the DEVMODE structure might be reallocated to
hold a larger one - not a big deal */
if (!sync_printer_with_devmode (d, ldm->devmode, ldm->devmode,
ldm->printer_name))
/* If the supplied devmode is not specialized, then the current
devmode size will always be sufficient, as the printer does
- not change. If it is specialized, we must reallocate the cuttent
+ not change. If it is specialized, we must reallocate the current
devmode storage to match with the supplied one, as it has the right
size for the new printer, if it is going to change. The correct
way is to use the largest of the two though, to keep the old
ldm_current->devmode,
ldm_new->printer_name))
error ("Printer device initialization I/O error, device deleted.");
-
+
if (ldm_new->printer_name != NULL)
{
xfree (ldm_current->printer_name);
{
Lisp_Object devmode;
XSETDEVMODE (devmode, dm);
- signal_simple_error (
- "Cannot dump XEmacs containing an msprinter-settings object",
- devmode);
+ invalid_operation
+ ("Cannot dump XEmacs containing an msprinter-settings object",
+ devmode);
}
assert (NILP (dm->device));
ldm = XDEVMODE (settings);
if (!NILP (ldm->device))
- signal_simple_error ("The object is currently selected into a device",
- settings);
+ invalid_operation ("The object is currently selected into a device",
+ settings);
dm = ldm->devmode;
return Qnil;
}
+DEFUN ("mswindows-get-default-printer", Fmswindows_get_default_printer, 0, 0, 0, /*
+Return name of the default printer, as string, on nil if there is no default.
+*/
+ ())
+{
+ return msprinter_default_printer ();
+}
+
+static void
+signal_enum_printer_error (void)
+{
+ invalid_operation ("Error enumerating printers", make_int (GetLastError ()));
+}
+
+DEFUN ("mswindows-printer-list", Fmswindows_printer_list, 0, 0, 0, /*
+Return a list of string names of installed printers.
+If there is a default printer, it is returned as the first element of
+the list. If there is no default printer, the first element of the
+list will be nil. The rest of elements are guaranteed to have string
+values. Return value is nil if there are no printers installed.
+*/
+ ())
+{
+ int have_nt, ok;
+ BYTE *data_buf, dummy_byte;
+ size_t enum_entry_size;
+ DWORD enum_flags, enum_level, bytes_needed, num_printers;
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object result = Qnil, def_printer = Qnil;
+
+ /* Determine OS flavor, to use the fastest enumeration method available */
+ have_nt = !mswindows_windows9x_p ();
+ enum_flags = PRINTER_ENUM_LOCAL | (have_nt ? PRINTER_ENUM_CONNECTIONS : 0);
+ enum_level = have_nt ? 4 : 5;
+ enum_entry_size = have_nt ? sizeof (PRINTER_INFO_4) : sizeof (PRINTER_INFO_5);
+
+ /* Allocate memory for printer enum structure */
+ ok = EnumPrinters (enum_flags, NULL, enum_level, &dummy_byte, 1,
+ &bytes_needed, &num_printers);
+ if (ok)
+ /* No printers, if just 1 byte is enough */
+ return Qnil;
+
+ if (GetLastError () != ERROR_INSUFFICIENT_BUFFER)
+ signal_enum_printer_error ();
+
+ data_buf = alloca (bytes_needed);
+ ok = EnumPrinters (enum_flags, NULL, enum_level, data_buf, bytes_needed,
+ &bytes_needed, &num_printers);
+ if (!ok)
+ signal_enum_printer_error ();
+
+ if (num_printers == 0)
+ /* Strange but... */
+ return Qnil;
+
+ GCPRO2 (result, def_printer);
+
+ while (num_printers--)
+ {
+ LPCTSTR printer_name;
+ if (have_nt)
+ {
+ PRINTER_INFO_4 *info = (PRINTER_INFO_4*) data_buf;
+ printer_name = info->pPrinterName;
+ }
+ else
+ {
+ PRINTER_INFO_5 *info = (PRINTER_INFO_5*) data_buf;
+ printer_name = info->pPrinterName;
+ }
+ data_buf += enum_entry_size;
+
+ result = Fcons (build_ext_string (printer_name, Qmswindows_tstr),
+ result);
+ }
+
+ def_printer = msprinter_default_printer ();
+ result = Fdelete (def_printer, result);
+ result = Fcons (def_printer, result);
+
+ RETURN_UNGCPRO (result);
+}
+
\f
/************************************************************************/
/* initialization */
{
INIT_LRECORD_IMPLEMENTATION (devmode);
- DEFSUBR (Fmsprinter_print_setup_dialog);
- DEFSUBR (Fmsprinter_print_dialog);
- DEFSUBR (Fmsprinter_page_setup_dialog);
DEFSUBR (Fmsprinter_get_settings);
DEFSUBR (Fmsprinter_select_settings);
DEFSUBR (Fmsprinter_apply_settings);
DEFSUBR (Fmsprinter_settings_copy);
DEFSUBR (Fmsprinter_settings_despecialize);
+ DEFSUBR (Fmswindows_get_default_printer);
+ DEFSUBR (Fmswindows_printer_list);
defsymbol (&Qinit_pre_mswindows_win, "init-pre-mswindows-win");
defsymbol (&Qinit_post_mswindows_win, "init-post-mswindows-win");
/* Synched up with: Not in FSF. */
+/* 7-8-00 !!#### This file needs definite Mule review. */
+
/* Original authors: Jamie Zawinski and the FSF */
/* Rewritten by Ben Wing and Chuck Thompson. */
* Finally, if all else fails, return `xemacs', as it is more
* appropriate (X11R5 returns `main').
*/
-static char *
-compute_x_app_name (int argc, char **argv)
+static Extbyte *
+compute_x_app_name (int argc, Extbyte **argv)
{
int i;
- char *ptr;
+ Extbyte *ptr;
for (i = 1; i < argc - 1; i++)
if (!strncmp(argv[i], "-name", max (2, strlen (argv[1]))))
Display *dpy;
Widget app_shell;
int argc;
- char **argv;
+ Extbyte **argv;
const char *app_class;
const char *app_name;
const char *disp_name;
make_argc_argv (Vx_initial_argv_list, &argc, &argv);
- TO_EXTERNAL_FORMAT (LISP_STRING, display,
- C_STRING_ALLOCA, disp_name,
- Qctext);
+ LISP_STRING_TO_EXTERNAL (display, disp_name, Qctext);
/*
* Break apart the old XtOpenDisplay call into XOpenDisplay and
if (STRINGP (Vx_emacs_application_class) &&
XSTRING_LENGTH (Vx_emacs_application_class) > 0)
- TO_EXTERNAL_FORMAT (LISP_STRING, Vx_emacs_application_class,
- C_STRING_ALLOCA, app_class,
- Qctext);
+ LISP_STRING_TO_EXTERNAL (Vx_emacs_application_class, app_class, Qctext);
else
{
app_class = (NILP (Vx_emacs_application_class) &&
Yuck. */
XtDisplayInitialize (Xt_app_con, dpy, compute_x_app_name (argc, argv),
app_class, emacs_options,
- XtNumber (emacs_options), &argc, argv);
+ XtNumber (emacs_options), &argc, (char **) argv);
speed_up_interrupts ();
screen = DefaultScreen (dpy);
if (STRINGP (Vx_app_defaults_directory) &&
XSTRING_LENGTH (Vx_app_defaults_directory) > 0)
{
- TO_EXTERNAL_FORMAT (LISP_STRING, Vx_app_defaults_directory,
- C_STRING_ALLOCA, data_dir,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (Vx_app_defaults_directory, data_dir, Qfile_name);
path = (char *)alloca (strlen (data_dir) + strlen (locale) + 7);
sprintf (path, "%s%s/Emacs", data_dir, locale);
if (!access (path, R_OK))
}
else if (STRINGP (Vdata_directory) && XSTRING_LENGTH (Vdata_directory) > 0)
{
- TO_EXTERNAL_FORMAT (LISP_STRING, Vdata_directory,
- C_STRING_ALLOCA, data_dir,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (Vdata_directory, data_dir, Qfile_name);
path = (char *)alloca (strlen (data_dir) + 13 + strlen (locale) + 7);
sprintf (path, "%sapp-defaults/%s/Emacs", data_dir, locale);
if (!access (path, R_OK))
#ifdef HAVE_WMCOMMAND
{
int new_argc;
- char **new_argv;
+ Extbyte **new_argv;
make_argc_argv (Vcommand_line_args, &new_argc, &new_argv);
- XSetCommand (XtDisplay (app_shell), XtWindow (app_shell), new_argv, new_argc);
+ XSetCommand (XtDisplay (app_shell), XtWindow (app_shell),
+ (char **) new_argv, new_argc);
free_argc_argv (new_argv);
}
#endif /* HAVE_WMCOMMAND */
#endif /* 0 */
+/* strcasecmp() is not sufficiently portable or standard,
+ and it's easier just to write our own. */
+static int
+ascii_strcasecmp (const char *s1, const char *s2)
+{
+ while (1)
+ {
+ char c1 = *s1++;
+ char c2 = *s2++;
+ if (c1 >= 'A' && c1 <= 'Z') c1 += 'a' - 'A';
+ if (c2 >= 'A' && c2 <= 'Z') c2 += 'a' - 'A';
+ if (c1 != c2) return c1 - c2;
+ if (c1 == '\0') return 0;
+ }
+}
+
static char_dynarr *name_char_dynarr;
static char_dynarr *class_char_dynarr;
return build_string (raw_result);
else if (EQ (type, Qboolean))
{
- if (!strcasecmp (raw_result, "off") ||
- !strcasecmp (raw_result, "false") ||
- !strcasecmp (raw_result, "no"))
+ if (!ascii_strcasecmp (raw_result, "off") ||
+ !ascii_strcasecmp (raw_result, "false") ||
+ !ascii_strcasecmp (raw_result, "no"))
return Fcons (Qnil, Qnil);
- if (!strcasecmp (raw_result, "on") ||
- !strcasecmp (raw_result, "true") ||
- !strcasecmp (raw_result, "yes"))
+ if (!ascii_strcasecmp (raw_result, "on") ||
+ !ascii_strcasecmp (raw_result, "true") ||
+ !ascii_strcasecmp (raw_result, "yes"))
return Fcons (Qt, Qnil);
return maybe_continuable_error
(Qresource, errb,
const char *keysym_ext;
CHECK_STRING (keysym);
- TO_EXTERNAL_FORMAT (LISP_STRING, keysym,
- C_STRING_ALLOCA, keysym_ext,
- Qctext);
+ LISP_STRING_TO_EXTERNAL (keysym, keysym_ext, Qctext);
return XStringToKeysym (keysym_ext) ? Qt : Qnil;
}
EXTERNAL_LIST_LOOP (path_entry, font_path)
{
- TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (path_entry),
- C_STRING_ALLOCA, directories[i++],
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (XCAR (path_entry), directories[i++], Qfile_name);
}
expect_x_error (dpy);
size-icon-small Small icon dimensions.
size-device Device screen or paper size in pixels.
size-workspace Workspace size in pixels. This can be less than or
- equal to the above. For diplays, this is the area
+ equal to the above. For displays, this is the area
available to applications less window manager
decorations. For printers, this is the size of
printable area.
DECLARE_LRECORD (device, struct device);
#define XDEVICE(x) XRECORD (x, device, struct device)
#define XSETDEVICE(x, p) XSETRECORD (x, p, device)
+#define wrap_device(p) wrap_object (p)
#define DEVICEP(x) RECORDP (x, device)
#define CHECK_DEVICE(x) CHECK_RECORD (x, device)
#define CONCHECK_DEVICE(x) CONCHECK_RECORD (x, device)
/* Implements elisp-programmable dialog boxes -- MS Windows interface.
Copyright (C) 1998 Kirill M. Katsnelson <kkm@kis.ru>
+ Copyright (C) 2000 Ben Wing.
This file is part of XEmacs.
#include "gui.h"
#include "opaque.h"
+#include <cderr.h>
+#include <commdlg.h>
+
+Lisp_Object Qdialog_box_error;
+
+static Lisp_Object Q_initial_directory;
+static Lisp_Object Q_initial_filename;
+static Lisp_Object Q_filter_list;
+static Lisp_Object Q_title;
+static Lisp_Object Q_allow_multi_select;
+static Lisp_Object Q_create_prompt_on_nonexistent;
+static Lisp_Object Q_overwrite_prompt;
+static Lisp_Object Q_file_must_exist;
+static Lisp_Object Q_no_network_button;
+static Lisp_Object Q_no_read_only_return;
+
/* List containing all dialog data structures of currently popped up
- dialogs. Each item is a cons of frame object and a vector of
- callbacks for buttons in the dialog, in order */
+ dialogs. */
static Lisp_Object Vdialog_data_list;
+/* List of popup frames wanting keyboard traversal handled */
+static Lisp_Object Vpopup_frame_list;
+
+Lisp_Object Vdefault_file_dialog_filter_alist;
+
/* DLUs per character metrics */
#define X_DLU_PER_CHAR 4
#define Y_DLU_PER_CHAR 8
#define ID_ITEM_BIAS 32
+void
+mswindows_register_popup_frame (Lisp_Object frame)
+{
+ Vpopup_frame_list = Fcons (frame, Vpopup_frame_list);
+}
+
+void
+mswindows_unregister_popup_frame (Lisp_Object frame)
+{
+ Vpopup_frame_list = delq_no_quit (frame, Vpopup_frame_list);
+}
+
+/* Dispatch message to any dialog boxes. Return non-zero if dispatched. */
+int
+mswindows_is_dialog_msg (MSG *msg)
+{
+ LIST_LOOP_2 (data, Vdialog_data_list)
+ {
+ if (IsDialogMessage (XMSWINDOWS_DIALOG_ID (data)->hwnd, msg))
+ return 1;
+ }
+
+ {
+ LIST_LOOP_2 (popup, Vpopup_frame_list)
+ {
+ HWND hwnd = FRAME_MSWINDOWS_HANDLE (XFRAME (popup));
+ if (IsDialogMessage (hwnd, msg))
+ return 1;
+ }
+ }
+ return 0;
+}
+
+static Lisp_Object
+mark_mswindows_dialog_id (Lisp_Object obj)
+{
+ struct mswindows_dialog_id *data = XMSWINDOWS_DIALOG_ID (obj);
+ mark_object (data->frame);
+ return data->callbacks;
+}
+
+DEFINE_LRECORD_IMPLEMENTATION ("mswindows-dialog-id", mswindows_dialog_id,
+ mark_mswindows_dialog_id, 0, 0, 0, 0, 0,
+ struct mswindows_dialog_id);
+
/* Dialog procedure */
static BOOL CALLBACK
dialog_proc (HWND hwnd, UINT msg, WPARAM w_param, LPARAM l_param)
case WM_COMMAND:
{
Lisp_Object fn, arg, data;
+ struct mswindows_dialog_id *did;
+
VOID_TO_LISP (data, GetWindowLong (hwnd, DWL_USER));
-
- assert (w_param >= ID_ITEM_BIAS
- && w_param < XVECTOR_LENGTH (XCDR (data)) + ID_ITEM_BIAS);
-
- get_gui_callback (XVECTOR_DATA (XCDR (data)) [w_param - ID_ITEM_BIAS],
- &fn, &arg);
- mswindows_enqueue_misc_user_event (XCAR (data), fn, arg);
+ did = XMSWINDOWS_DIALOG_ID (data);
+ if (w_param != IDCANCEL) /* user pressed escape */
+ {
+ assert (w_param >= ID_ITEM_BIAS
+ && w_param
+ < XVECTOR_LENGTH (did->callbacks) + ID_ITEM_BIAS);
+
+ get_gui_callback (XVECTOR_DATA (did->callbacks)
+ [w_param - ID_ITEM_BIAS],
+ &fn, &arg);
+ mswindows_enqueue_misc_user_event (did->frame, fn, arg);
+ }
+ else
+ mswindows_enqueue_misc_user_event (did->frame, Qrun_hooks,
+ Qmenu_no_selection_hook);
+ /* #### need to error-protect! will do so when i merge in
+ my working ws */
+ va_run_hook_with_args (Qdelete_dialog_box_hook, 1, data);
DestroyWindow (hwnd);
}
Dynarr_add_many (template, &zeroes, slippage); \
}
-static void
-mswindows_popup_dialog_box (struct frame* f, Lisp_Object desc)
+static struct
+{
+ int errmess;
+ char *errname;
+} common_dialog_errors[] =
+{
+ { CDERR_DIALOGFAILURE, "CDERR_DIALOGFAILURE" },
+ { CDERR_FINDRESFAILURE, "CDERR_FINDRESFAILURE" },
+ { CDERR_INITIALIZATION, "CDERR_INITIALIZATION" },
+ { CDERR_LOADRESFAILURE, "CDERR_LOADRESFAILURE" },
+ { CDERR_LOADSTRFAILURE, "CDERR_LOADSTRFAILURE" },
+ { CDERR_LOCKRESFAILURE, "CDERR_LOCKRESFAILURE" },
+ { CDERR_MEMALLOCFAILURE, "CDERR_MEMALLOCFAILURE" },
+ { CDERR_MEMLOCKFAILURE, "CDERR_MEMLOCKFAILURE" },
+ { CDERR_NOHINSTANCE, "CDERR_NOHINSTANCE" },
+ { CDERR_NOHOOK, "CDERR_NOHOOK" },
+ { CDERR_NOTEMPLATE, "CDERR_NOTEMPLATE" },
+ { CDERR_REGISTERMSGFAIL, "CDERR_REGISTERMSGFAIL" },
+ { CDERR_STRUCTSIZE, "CDERR_STRUCTSIZE" },
+ { PDERR_CREATEICFAILURE, "PDERR_CREATEICFAILURE" },
+ { PDERR_DEFAULTDIFFERENT, "PDERR_DEFAULTDIFFERENT" },
+ { PDERR_DNDMMISMATCH, "PDERR_DNDMMISMATCH" },
+ { PDERR_GETDEVMODEFAIL, "PDERR_GETDEVMODEFAIL" },
+ { PDERR_INITFAILURE, "PDERR_INITFAILURE" },
+ { PDERR_LOADDRVFAILURE, "PDERR_LOADDRVFAILURE" },
+ { PDERR_NODEFAULTPRN, "PDERR_NODEFAULTPRN" },
+ { PDERR_NODEVICES, "PDERR_NODEVICES" },
+ { PDERR_PARSEFAILURE, "PDERR_PARSEFAILURE" },
+ { PDERR_PRINTERNOTFOUND, "PDERR_PRINTERNOTFOUND" },
+ { PDERR_RETDEFFAILURE, "PDERR_RETDEFFAILURE" },
+ { PDERR_SETUPFAILURE, "PDERR_SETUPFAILURE" },
+ { CFERR_MAXLESSTHANMIN, "CFERR_MAXLESSTHANMIN" },
+ { CFERR_NOFONTS, "CFERR_NOFONTS" },
+ { FNERR_BUFFERTOOSMALL, "FNERR_BUFFERTOOSMALL" },
+ { FNERR_INVALIDFILENAME, "FNERR_INVALIDFILENAME" },
+ { FNERR_SUBCLASSFAILURE, "FNERR_SUBCLASSFAILURE" },
+ { FRERR_BUFFERLENGTHZERO, "FRERR_BUFFERLENGTHZERO" },
+};
+
+static Lisp_Object
+handle_file_dialog_box (struct frame *f, Lisp_Object keys)
+{
+ OPENFILENAME ofn;
+ char fnbuf[8000];
+
+ xzero (ofn);
+ ofn.lStructSize = sizeof (ofn);
+ ofn.hwndOwner = FRAME_MSWINDOWS_HANDLE (f);
+ ofn.lpstrFile = fnbuf;
+ ofn.nMaxFile = sizeof (fnbuf) / XETCHAR_SIZE;
+ xetcscpy (fnbuf, XETEXT (""));
+
+ LOCAL_FILE_FORMAT_TO_TSTR (Fexpand_file_name (build_string (""), Qnil),
+ ofn.lpstrInitialDir);
+
+ {
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, keys)
+ {
+ if (EQ (key, Q_initial_filename))
+ {
+ Extbyte *fnout;
+
+ CHECK_STRING (value);
+ LOCAL_FILE_FORMAT_TO_TSTR (value, fnout);
+ xetcscpy (fnbuf, fnout);
+ }
+ else if (EQ (key, Q_title))
+ {
+ CHECK_STRING (value);
+ LISP_STRING_TO_EXTERNAL (value, ofn.lpstrTitle, Qmswindows_tstr);
+ }
+ else if (EQ (key, Q_initial_directory))
+ LOCAL_FILE_FORMAT_TO_TSTR (Fexpand_file_name (value, Qnil),
+ ofn.lpstrInitialDir);
+ else if (EQ (key, Q_file_must_exist))
+ {
+ if (!NILP (value))
+ ofn.Flags |= OFN_FILEMUSTEXIST | OFN_PATHMUSTEXIST;
+ else
+ ofn.Flags &= ~(OFN_FILEMUSTEXIST | OFN_PATHMUSTEXIST);
+ }
+ else
+ syntax_error ("Unrecognized file-dialog keyword", key);
+ }
+ }
+
+ if (!GetOpenFileName (&ofn))
+ {
+ DWORD err = CommDlgExtendedError ();
+ if (!err)
+ {
+ while (1)
+ signal_quit ();
+ }
+ else
+ {
+ int i;
+
+ for (i = 0; i < countof (common_dialog_errors); i++)
+ {
+ if (common_dialog_errors[i].errmess == err)
+ signal_type_error (Qdialog_box_error,
+ "Creating file-dialog-box",
+ build_string
+ (common_dialog_errors[i].errname));
+ }
+
+ signal_type_error (Qdialog_box_error,
+ "Unknown common dialog box error???",
+ make_int (err));
+ }
+ }
+
+ return tstr_to_local_file_format (ofn.lpstrFile);
+}
+
+static Lisp_Object
+handle_question_dialog_box (struct frame *f, Lisp_Object keys)
{
Lisp_Object_dynarr *dialog_items = Dynarr_new (Lisp_Object);
unsigned_char_dynarr *template = Dynarr_new (unsigned_char);
unsigned int button_row_width = 0;
unsigned int text_width, text_height;
+ Lisp_Object question = Qnil, title = Qnil;
int unbind_count = specpdl_depth ();
record_unwind_protect (free_dynarr_opaque_ptr,
make_opaque_ptr (template));
/* A big NO NEED to GCPRO gui_items stored in the array: they are just
- pointers into DESC list, which is GC-protected by the caller */
+ pointers into KEYS list, which is GC-protected by the caller */
- /* Parse each item in the dialog into gui_item structs, and stuff a dynarr
- of these. Calculate button row width in this loop too */
{
- Lisp_Object item_cons;
-
- EXTERNAL_LIST_LOOP (item_cons, XCDR (desc))
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, keys)
{
- if (!NILP (XCAR (item_cons)))
+ if (EQ (key, Q_question))
{
- Lisp_Object gitem = gui_parse_item_keywords (XCAR (item_cons));
- Dynarr_add (dialog_items, gitem);
- button_row_width += button_width (XGUI_ITEM (gitem)->name)
- + X_BUTTON_MARGIN;
+ CHECK_STRING (value);
+ question = value;
}
+ else if (EQ (key, Q_title))
+ {
+ CHECK_STRING (value);
+ title = value;
+ }
+ else if (EQ (key, Q_buttons))
+ {
+ Lisp_Object item_cons;
+
+ /* Parse each item in the dialog into gui_item structs,
+ and stuff a dynarr of these. Calculate button row width
+ in this loop too */
+ EXTERNAL_LIST_LOOP (item_cons, value)
+ {
+ if (!NILP (XCAR (item_cons)))
+ {
+ Lisp_Object gitem =
+ gui_parse_item_keywords (XCAR (item_cons));
+ Dynarr_add (dialog_items, gitem);
+ button_row_width += button_width (XGUI_ITEM (gitem)->name)
+ + X_BUTTON_MARGIN;
+ }
+ }
+
+ button_row_width -= X_BUTTON_MARGIN;
+ }
+ else
+ syntax_error ("Unrecognized question-dialog keyword", key);
}
- if (Dynarr_length (dialog_items) == 0)
- signal_simple_error ("Dialog descriptor provides no active items", desc);
- button_row_width -= X_BUTTON_MARGIN;
}
+ if (Dynarr_length (dialog_items) == 0)
+ syntax_error ("Dialog descriptor provides no buttons", keys);
+
+ if (NILP (question))
+ syntax_error ("Dialog descriptor provides no question", keys);
+
/* Determine the final width layout */
{
- Bufbyte *p = XSTRING_DATA (XCAR (desc));
+ Bufbyte *p = XSTRING_DATA (question);
Charcount string_max = 0, this_length = 0;
while (1)
{
/* Now calculate the height for the text control */
{
- Bufbyte *p = XSTRING_DATA (XCAR (desc));
+ Bufbyte *p = XSTRING_DATA (question);
Charcount break_at = text_width / X_DLU_PER_CHAR;
Charcount char_pos = 0;
int num_lines = 1;
Emchar ch;
- while ((ch = charptr_emchar (p)) != (Emchar)'\0')
+ while ((ch = charptr_emchar (p)) != (Emchar) '\0')
{
INC_CHARPTR (p);
- char_pos += ch != (Emchar)'\n';
- if (ch == (Emchar)'\n' || char_pos == break_at)
+ char_pos += ch != (Emchar) '\n';
+ if (ch == (Emchar) '\n' || char_pos == break_at)
{
++num_lines;
char_pos = 0;
/* We want no menu and standard class */
Dynarr_add_many (template, &zeroes, 4);
- /* And the third is the dialog title. "XEmacs" as long as we do not supply
- one in descriptor. Note that the string must be in Unicode. */
- Dynarr_add_many (template, L"XEmacs", 14);
+ /* And the third is the dialog title. "XEmacs" unless one is supplied.
+ Note that the string must be in Unicode. */
+ if (NILP (title))
+ Dynarr_add_many (template, L"XEmacs", 14);
+ else
+ push_lisp_string_as_unicode (template, title);
/* We want standard dialog font */
Dynarr_add_many (template, L"\x08MS Shell Dlg", 28);
Dynarr_add_many (template, &static_class_id, sizeof (static_class_id));
/* Next thing to add is control text, as Unicode string */
- push_lisp_string_as_unicode (template, XCAR (desc));
+ push_lisp_string_as_unicode (template, question);
/* Specify 0 length creation data */
Dynarr_add_many (template, &zeroes, 2);
/* Now the Windows dialog structure is ready. We need to prepare a
data structure for the new dialog, which will contain callbacks
- and the frame for these callbacks. This structure has to be
- GC-protected. The data structure itself is a cons of frame object
- and a vector of callbacks; for the protection reasons it is put
- into a statically protected list. */
+ and the frame for these callbacks. This structure has to be
+ GC-protected and thus it is put into a statically protected
+ list. */
{
- Lisp_Object frame, vector, dialog_data;
+ Lisp_Object dialog_data;
int i;
-
- XSETFRAME (frame, f);
- vector = make_vector (Dynarr_length (dialog_items), Qunbound);
- dialog_data = Fcons (frame, vector);
+ struct mswindows_dialog_id *did =
+ alloc_lcrecord_type (struct mswindows_dialog_id,
+ &lrecord_mswindows_dialog_id);
+
+ XSETMSWINDOWS_DIALOG_ID (dialog_data, did);
+
+ did->frame = wrap_frame (f);
+ did->callbacks = make_vector (Dynarr_length (dialog_items), Qunbound);
for (i = 0; i < Dynarr_length (dialog_items); i++)
- XVECTOR_DATA (vector) [i] =
+ XVECTOR_DATA (did->callbacks) [i] =
XGUI_ITEM (*Dynarr_atp (dialog_items, i))->callback;
-
+
/* Woof! Everything is ready. Pop pop pop in now! */
- if (!CreateDialogIndirectParam (NULL,
- (LPDLGTEMPLATE) Dynarr_atp (template, 0),
- FRAME_MSWINDOWS_HANDLE (f), dialog_proc,
- (LPARAM) LISP_TO_VOID (dialog_data)))
+ did->hwnd =
+ CreateDialogIndirectParam (NULL,
+ (LPDLGTEMPLATE) Dynarr_atp (template, 0),
+ FRAME_MSWINDOWS_HANDLE (f), dialog_proc,
+ (LPARAM) LISP_TO_VOID (dialog_data));
+ if (!did->hwnd)
/* Something went wrong creating the dialog */
- signal_simple_error ("System error creating dialog", desc);
+ signal_type_error (Qdialog_box_error, "Creating dialog", keys);
Vdialog_data_list = Fcons (dialog_data, Vdialog_data_list);
+
+ /* Cease protection and free dynarrays */
+ unbind_to (unbind_count, Qnil);
+ return dialog_data;
}
+}
- /* Cease protection and free dynarrays */
- unbind_to (unbind_count, Qnil);
+static Lisp_Object
+mswindows_make_dialog_box_internal (struct frame* f, Lisp_Object type,
+ Lisp_Object keys)
+{
+ if (EQ (type, Qfile))
+ return handle_file_dialog_box (f, keys);
+ else if (EQ (type, Qquestion))
+ return handle_question_dialog_box (f, keys);
+ else if (EQ (type, Qprint))
+ return mswindows_handle_print_dialog_box (f, keys);
+ else if (EQ (type, Qpage_setup))
+ return mswindows_handle_page_setup_dialog_box (f, keys);
+ else if (EQ (type, Qprint_setup))
+ return mswindows_handle_print_setup_dialog_box (f, keys);
+ else
+ signal_type_error (Qunimplemented, "Dialog box type", type);
+ return Qnil;
}
void
console_type_create_dialog_mswindows (void)
{
- CONSOLE_HAS_METHOD (mswindows, popup_dialog_box);
+ CONSOLE_HAS_METHOD (mswindows, make_dialog_box_internal);
+}
+
+void
+syms_of_dialog_mswindows (void)
+{
+ INIT_LRECORD_IMPLEMENTATION (mswindows_dialog_id);
+
+ DEFKEYWORD (Q_initial_directory);
+ DEFKEYWORD (Q_initial_filename);
+ DEFKEYWORD (Q_filter_list);
+ DEFKEYWORD (Q_title);
+ DEFKEYWORD (Q_allow_multi_select);
+ DEFKEYWORD (Q_create_prompt_on_nonexistent);
+ DEFKEYWORD (Q_overwrite_prompt);
+ DEFKEYWORD (Q_file_must_exist);
+ DEFKEYWORD (Q_no_network_button);
+ DEFKEYWORD (Q_no_read_only_return);
+
+ /* Errors */
+ DEFERROR_STANDARD (Qdialog_box_error, Qinvalid_operation);
}
void
vars_of_dialog_mswindows (void)
{
+ Vpopup_frame_list = Qnil;
+ staticpro (&Vpopup_frame_list);
+
Vdialog_data_list = Qnil;
staticpro (&Vdialog_data_list);
+
+ DEFVAR_LISP ("default-file-dialog-filter-alist",
+ &Vdefault_file_dialog_filter_alist /*
+*/ );
+ Vdefault_file_dialog_filter_alist =
+ list5 (Fcons (build_string ("Text Files"), build_string ("*.txt")),
+ Fcons (build_string ("C Files"), build_string ("*.c;*.h")),
+ Fcons (build_string ("Elisp Files"), build_string ("*.el")),
+ Fcons (build_string ("HTML Files"), build_string ("*.html;*.html")),
+ Fcons (build_string ("All Files"), build_string ("*.*")));
}
/* Implements elisp-programmable dialog boxes -- X interface.
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+ Copyright (C) 2000 Ben Wing.
This file is part of XEmacs.
/* Synched up with: Not in FSF. */
+/* This file Mule-ized by Ben Wing, 7-8-00. */
+
#include <config.h>
#include "lisp.h"
static void
maybe_run_dbox_text_callback (LWLIB_ID id)
{
- /* !!#### This function has not been Mule-ized */
widget_value *wv;
int got_some;
wv = xmalloc_widget_value ();
if (got_some)
{
Lisp_Object text_field_callback;
- char *text_field_value = wv->value;
+ Extbyte *text_field_value = wv->value;
VOID_TO_LISP (text_field_callback, wv->call_data);
text_field_callback = XCAR (XCDR (text_field_callback));
if (text_field_value)
void *tmp =
LISP_TO_VOID (cons3 (Qnil,
list2 (text_field_callback,
- build_string (text_field_value)),
+ build_ext_string (text_field_value,
+ Qlwlib_encoding)),
Qnil));
popup_selection_callback (0, id, (XtPointer) tmp);
}
}
/* This code tried to optimize, newing/freeing. This is generally
- unsafe so we will alwats strdup and always use
+ unsafe so we will always strdup and always use
free_widget_value_tree. */
free_widget_value_tree (wv);
}
popup_up_p--;
maybe_run_dbox_text_callback (id);
popup_selection_callback (widget, id, client_data);
+ /* #### need to error-protect! will do so when i merge in
+ my working ws */
+ va_run_hook_with_args (Qdelete_dialog_box_hook, 1, make_int (id));
lw_destroy_all_widgets (id);
/* The Motif dialog box sets the keyboard focus to itself. When it
lw_set_keyboard_focus (FRAME_X_SHELL_WIDGET (f), FRAME_X_TEXT_WIDGET (f));
}
-static const char * const button_names [] = {
+static const Extbyte * const button_names [] = {
"button1", "button2", "button3", "button4", "button5",
"button6", "button7", "button8", "button9", "button10" };
-/* can't have static frame locals because of some broken compilers */
-static char tmp_dbox_name [255];
-
static widget_value *
-dbox_descriptor_to_widget_value (Lisp_Object desc)
+dbox_descriptor_to_widget_value (Lisp_Object keys)
{
- /* !!#### This function has not been Mule-ized */
/* This function can GC */
- char *name;
int lbuttons = 0, rbuttons = 0;
int partition_seen = 0;
int text_field_p = 0;
int n = 0;
int count = specpdl_depth ();
Lisp_Object wv_closure, gui_item;
+ Lisp_Object question = Qnil, title = Qnil, buttons = Qnil;
- CHECK_CONS (desc);
- CHECK_STRING (XCAR (desc));
- name = (char *) XSTRING_DATA (LISP_GETTEXT (XCAR (desc)));
- desc = XCDR (desc);
- if (!CONSP (desc))
- error ("dialog boxes must have some buttons");
+ {
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, keys)
+ {
+ if (EQ (key, Q_question))
+ {
+ CHECK_STRING (value);
+ question = value;
+ }
+ else if (EQ (key, Q_title))
+ {
+ CHECK_STRING (value);
+ title = value;
+ }
+ else if (EQ (key, Q_buttons))
+ {
+ CHECK_LIST (value);
+ buttons = value;
+ }
+ else
+ syntax_error ("Unrecognized question-dialog keyword", key);
+ }
+ }
+
+ if (NILP (question))
+ syntax_error ("Dialog descriptor provides no question", keys);
/* Inhibit GC during this conversion. The reasons for this are
the same as in menu_item_descriptor_to_widget_value(); see
wv_closure = make_opaque_ptr (kids);
record_unwind_protect (widget_value_unwind, wv_closure);
prev->name = xstrdup ("message");
- prev->value = xstrdup (name);
+ LISP_STRING_TO_EXTERNAL_MALLOC (question, prev->value, Qlwlib_encoding);
prev->enabled = 1;
- for (; !NILP (desc); desc = Fcdr (desc))
- {
- Lisp_Object button = XCAR (desc);
- widget_value *wv;
-
- if (NILP (button))
- {
- if (partition_seen)
- error ("more than one partition (nil) seen in dbox spec");
- partition_seen = 1;
- continue;
- }
- CHECK_VECTOR (button);
- wv = xmalloc_widget_value ();
-
- gui_item = gui_parse_item_keywords (button);
- if (!button_item_to_widget_value (Qdialog,
- gui_item, wv, allow_text_p, 1, 0))
- {
- free_widget_value_tree (wv);
- continue;
- }
-
- if (wv->type == TEXT_TYPE)
- {
- text_field_p = 1;
- allow_text_p = 0; /* only allow one */
- }
- else /* it's a button */
- {
- allow_text_p = 0; /* only allow text field at the front */
- if (wv->value) xfree (wv->value);
- wv->value = wv->name; /* what a mess... */
- wv->name = xstrdup (button_names [n]);
-
- if (partition_seen)
- rbuttons++;
- else
- lbuttons++;
- n++;
-
- if (lbuttons > 9 || rbuttons > 9)
- error ("too many buttons (9)"); /* #### this leaks */
- }
-
- prev->next = wv;
- prev = wv;
- }
+ {
+ EXTERNAL_LIST_LOOP_2 (button, buttons)
+ {
+ widget_value *wv;
+
+ if (NILP (button))
+ {
+ if (partition_seen)
+ syntax_error ("More than one partition (nil) seen in dbox spec",
+ keys);
+ partition_seen = 1;
+ continue;
+ }
+ CHECK_VECTOR (button);
+ wv = xmalloc_widget_value ();
+
+ gui_item = gui_parse_item_keywords (button);
+ if (!button_item_to_widget_value (Qdialog,
+ gui_item, wv, allow_text_p, 1, 0, 1))
+ {
+ free_widget_value_tree (wv);
+ continue;
+ }
+
+ if (wv->type == TEXT_TYPE)
+ {
+ text_field_p = 1;
+ allow_text_p = 0; /* only allow one */
+ }
+ else /* it's a button */
+ {
+ allow_text_p = 0; /* only allow text field at the front */
+ if (wv->value)
+ xfree (wv->value);
+ wv->value = wv->name; /* what a mess... */
+ wv->name = xstrdup (button_names [n]);
+
+ if (partition_seen)
+ rbuttons++;
+ else
+ lbuttons++;
+ n++;
+
+ if (lbuttons > 9 || rbuttons > 9)
+ syntax_error ("Too many buttons (9)",
+ keys); /* #### this leaks */
+ }
+
+ prev->next = wv;
+ prev = wv;
+ }
+ }
if (n == 0)
- error ("dialog boxes must have some buttons");
+ syntax_error ("Dialog boxes must have some buttons", keys);
+
{
- char type = (text_field_p ? 'P' : 'Q');
+ Extbyte type = (text_field_p ? 'P' : 'Q');
+ static Extbyte tmp_dbox_name [255];
+
widget_value *dbox;
sprintf (tmp_dbox_name, "%c%dBR%d", type, lbuttons + rbuttons, rbuttons);
dbox = xmalloc_widget_value ();
}
}
-static void
-x_popup_dialog_box (struct frame* f, Lisp_Object dbox_desc)
+static Lisp_Object
+x_make_dialog_box_internal (struct frame* f, Lisp_Object type,
+ Lisp_Object keys)
{
int dbox_id;
widget_value *data;
Widget parent, dbox;
- data = dbox_descriptor_to_widget_value (dbox_desc);
+ if (!EQ (type, Qquestion))
+ signal_type_error (Qunimplemented, "Dialog box type", type);
+
+ data = dbox_descriptor_to_widget_value (keys);
parent = FRAME_X_SHELL_WIDGET (f);
popup_up_p++;
lw_pop_up_all_widgets (dbox_id);
+
+ /* #### this could (theoretically) cause problems if we are up for
+ a REALLY REALLY long time -- too big to fit into lisp integer. */
+ return make_int (dbox_id);
}
void
void
console_type_create_dialog_x (void)
{
- CONSOLE_HAS_METHOD (x, popup_dialog_box);
+ CONSOLE_HAS_METHOD (x, make_dialog_box_internal);
}
void
/* Implements elisp-programmable dialog boxes -- generic.
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+ Copyright (C) 2000 Ben Wing.
This file is part of XEmacs.
#include <config.h>
#include "lisp.h"
+
#include "frame.h"
#include "device.h"
-DEFUN ("popup-dialog-box", Fpopup_dialog_box, 1, 1, 0, /*
-Pop up a dialog box.
-A dialog box description is a list.
-
-The first element of a dialog box must be a string, which is the title or
-question.
-
-The rest of the elements are descriptions of the dialog box's buttons.
-Each of these is a vector, the syntax of which is essentially the same as
-that of popup menu items. They may have any of the following forms:
-
- [ "name" callback <active-p> ]
- [ "name" callback <active-p> "suffix" ]
- [ "name" callback :<keyword> <value> :<keyword> <value> ... ]
-
-The name is the string to display on the button; it is filtered through the
-resource database, so it is possible for resources to override what string
-is actually displayed.
-
-Accelerators can be indicated in the string by putting the sequence
-"%_" before the character corresponding to the key that will invoke
-the button. Uppercase and lowercase accelerators are equivalent. The
-sequence "%%" is also special, and is translated into a single %.
+Lisp_Object Vdelete_dialog_box_hook;
+Lisp_Object Qdelete_dialog_box_hook;
-If the `callback' of a button is a symbol, then it must name a command.
-It will be invoked with `call-interactively'. If it is a list, then it is
-evaluated with `eval'.
-
-One (and only one) of the buttons may be `nil'. This marker means that all
-following buttons should be flushright instead of flushleft.
-
-Though the keyword/value syntax is supported for dialog boxes just as in
-popup menus, the only keyword which is both meaningful and fully implemented
-for dialog box buttons is `:active'. */
- (dbox_desc))
+DEFUN ("make-dialog-box-internal", Fmake_dialog_box_internal, 2, 2, 0, /*
+Internal helper function for `make-dialog-box'.
+This handles all dialog-box types except `general'.
+TYPE is the same as the first argument to `make-dialog-box', and KEYS
+a list of the remaining arguments.
+*/
+ (type, keys))
{
struct frame *f = selected_frame ();
struct device *d = XDEVICE (f->device);
- if (!HAS_DEVMETH_P (d, popup_dialog_box))
- signal_simple_error ("Device does not support dialogs", f->device);
-
- if (SYMBOLP (dbox_desc))
- dbox_desc = Fsymbol_value (dbox_desc);
- CHECK_CONS (dbox_desc);
- CHECK_STRING (XCAR (dbox_desc));
- if (!CONSP (XCDR (dbox_desc)))
- signal_simple_error ("Dialog descriptor must supply at least one button",
- dbox_desc);
+ CHECK_SYMBOL (type);
- DEVMETH (d, popup_dialog_box, (f, dbox_desc));
+ if (!HAS_DEVMETH_P (d, make_dialog_box_internal))
+ signal_type_error (Qunimplemented,
+ "Device does not support dialogs", f->device);
- return Qnil;
+ return DEVMETH (d, make_dialog_box_internal, (f, type, keys));
}
void
syms_of_dialog (void)
{
- DEFSUBR (Fpopup_dialog_box);
+ DEFSUBR (Fmake_dialog_box_internal);
+
+ DEFSYMBOL (Qdelete_dialog_box_hook);
}
void
vars_of_dialog (void)
{
Fprovide (intern ("dialog"));
+
+ DEFVAR_LISP ("delete-dialog-box-hook", &Vdelete_dialog_box_hook /*
+Function or functions to call when a dialog box is about to be deleted.
+One arg, the dialog box id.
+*/ );
+ Vdelete_dialog_box_hook = Qnil;
}
/*
* Here, we use FindFirstFile()/FindNextFile() instead of opendir(),
- * stat(), & friends, because stat() is VERY expensive in terms of
- * time. Hence, we take the time to write complicated Win32-specific
- * code, instead of simple Unix-style stuff.
+ * xemacs_stat(), & friends, because xemacs_stat() is VERY expensive in
+ * terms of time. Hence, we take the time to write complicated
+ * Win32-specific code, instead of simple Unix-style stuff.
*/
findex = 0;
fh = INVALID_HANDLE_VALUE;
memcpy (statbuf_tail, dp->d_name, len);
statbuf_tail[len] = 0;
- if (stat (statbuf, &st) == 0
+ if (xemacs_stat (statbuf, &st) == 0
&& (st.st_mode & S_IFMT) == S_IFDIR)
dir_p = 1;
in case it is a directory. */
value = lstat (fullname, st_addr);
if (S_ISLNK (st_addr->st_mode))
- stat (fullname, st_addr);
+ xemacs_stat (fullname, st_addr);
#else
- value = stat (fullname, st_addr);
+ value = xemacs_stat (fullname, st_addr);
#endif
return value;
}
\f
-/* The *pwent() functions do not exist on NT */
+/* The *pwent() functions do not exist on NT. #### The NT equivalent
+ is NetUserEnum(), and rewriting to use it is not hard.*/
#ifndef WIN32_NATIVE
static Lisp_Object user_name_completion (Lisp_Object user,
{
struct stat sdir;
- if (!NILP (directory) && stat ((char *) XSTRING_DATA (directory), &sdir) == 0)
+ if (!NILP (directory) && xemacs_stat ((char *) XSTRING_DATA (directory), &sdir) == 0)
values[9] = (sdir.st_gid != s.st_gid) ? Qt : Qnil;
else /* if we can't tell, assume worst */
values[9] = Qt;
return make_char (BUF_FETCH_CHAR (b, n));
}
+#if !defined(WINDOWSNT) && !defined(MSDOS)
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <errno.h>
+#include <limits.h>
+#endif
\f
DEFUN ("temp-directory", Ftemp_directory, 0, 0, 0, /*
Return the pathname to the directory to use for temporary files.
#else /* WIN32_NATIVE */
tmpdir = getenv ("TMPDIR");
if (!tmpdir)
+ {
+ struct stat st;
+ int myuid = getuid();
+ static char path[5 /* strlen ("/tmp/") */ + 1 + _POSIX_PATH_MAX];
+
+ strcpy (path, "/tmp/");
+ strncat (path, user_login_name (NULL), _POSIX_PATH_MAX);
+ if (lstat(path, &st) < 0 && errno == ENOENT)
+ {
+ mkdir(path, 0700); /* ignore retval -- checked next anyway. */
+ }
+ if (lstat(path, &st) == 0 && st.st_uid == myuid && S_ISDIR(st.st_mode))
+ {
+ tmpdir = path;
+ }
+ else
+ {
+ strcpy(path, getenv("HOME")); strncat(path, "/tmp/", _POSIX_PATH_MAX);
+ if (stat(path, &st) < 0 && errno == ENOENT)
+ {
+ int fd;
+ char warnpath[1+_POSIX_PATH_MAX];
+ mkdir(path, 0700); /* ignore retvals */
+ strcpy(warnpath, path);
+ strncat(warnpath, ".created_by_xemacs", _POSIX_PATH_MAX);
+ if ((fd = open(warnpath, O_WRONLY|O_CREAT, 0644)) > 0)
+ {
+ write(fd, "XEmacs created this directory because /tmp/<yourname> was unavailable -- \nPlease check !\n", 89);
+ close(fd);
+ }
+ }
+ if (stat(path, &st) == 0 && S_ISDIR(st.st_mode))
+ {
+ tmpdir = path;
+ }
+ else
+ {
tmpdir = "/tmp";
+ }
+ }
+ }
#endif
return build_ext_string (tmpdir, Qfile_name);
(specified_time))
{
time_t value;
- char buf[30];
- char *tem;
+ char *the_ctime;
+ size_t len;
if (! lisp_to_time (specified_time, &value))
value = -1;
- tem = (char *) ctime (&value);
+ the_ctime = ctime (&value);
- strncpy (buf, tem, 24);
- buf[24] = 0;
+ /* ctime is documented as always returning a "\n\0"-terminated
+ 26-byte American time string, but let's be careful anyways. */
+ for (len = 0; the_ctime[len] != '\n' && the_ctime[len] != '\0'; len++)
+ ;
- return build_ext_string (buf, Qbinary);
+ return make_ext_string ((Extbyte *) the_ctime, len, Qbinary);
}
#define TM_YEAR_ORIGIN 1900
See the variable `zmacs-regions'.
The same effect can be achieved using the `_' interactive specification.
+
+`zmacs-region-stays' is reset to nil before each command is executed.
*/ );
zmacs_region_stays = 0;
int ldap_sizelimit = 0;
int err;
- Lisp_Object list, keyword, value;
-
CHECK_STRING (host);
- EXTERNAL_PROPERTY_LIST_LOOP (list, keyword, value, plist)
- {
- /* TCP Port */
- if (EQ (keyword, Qport))
- {
- CHECK_INT (value);
- ldap_port = XINT (value);
- }
- /* Authentication method */
- if (EQ (keyword, Qauth))
- {
- if (EQ (value, Qsimple))
- ldap_auth = LDAP_AUTH_SIMPLE;
+ {
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (keyword, value, plist)
+ {
+ /* TCP Port */
+ if (EQ (keyword, Qport))
+ {
+ CHECK_INT (value);
+ ldap_port = XINT (value);
+ }
+ /* Authentication method */
+ if (EQ (keyword, Qauth))
+ {
+ if (EQ (value, Qsimple))
+ ldap_auth = LDAP_AUTH_SIMPLE;
#ifdef LDAP_AUTH_KRBV41
- else if (EQ (value, Qkrbv41))
- ldap_auth = LDAP_AUTH_KRBV41;
+ else if (EQ (value, Qkrbv41))
+ ldap_auth = LDAP_AUTH_KRBV41;
#endif
#ifdef LDAP_AUTH_KRBV42
- else if (EQ (value, Qkrbv42))
- ldap_auth = LDAP_AUTH_KRBV42;
+ else if (EQ (value, Qkrbv42))
+ ldap_auth = LDAP_AUTH_KRBV42;
#endif
- else
- signal_simple_error ("Invalid authentication method", value);
- }
- /* Bind DN */
- else if (EQ (keyword, Qbinddn))
- {
- CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value,
- C_STRING_ALLOCA, ldap_binddn,
- Qnative);
- }
- /* Password */
- else if (EQ (keyword, Qpasswd))
- {
- CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value,
- C_STRING_ALLOCA, ldap_passwd,
- Qnative);
- }
- /* Deref */
- else if (EQ (keyword, Qderef))
- {
- if (EQ (value, Qnever))
- ldap_deref = LDAP_DEREF_NEVER;
- else if (EQ (value, Qsearch))
- ldap_deref = LDAP_DEREF_SEARCHING;
- else if (EQ (value, Qfind))
- ldap_deref = LDAP_DEREF_FINDING;
- else if (EQ (value, Qalways))
- ldap_deref = LDAP_DEREF_ALWAYS;
- else
- signal_simple_error ("Invalid deref value", value);
- }
- /* Timelimit */
- else if (EQ (keyword, Qtimelimit))
- {
- CHECK_INT (value);
- ldap_timelimit = XINT (value);
- }
- /* Sizelimit */
- else if (EQ (keyword, Qsizelimit))
- {
- CHECK_INT (value);
- ldap_sizelimit = XINT (value);
- }
- }
+ else
+ signal_simple_error ("Invalid authentication method", value);
+ }
+ /* Bind DN */
+ else if (EQ (keyword, Qbinddn))
+ {
+ CHECK_STRING (value);
+ LISP_STRING_TO_EXTERNAL (value, ldap_binddn, Qnative);
+ }
+ /* Password */
+ else if (EQ (keyword, Qpasswd))
+ {
+ CHECK_STRING (value);
+ LISP_STRING_TO_EXTERNAL (value, ldap_passwd, Qnative);
+ }
+ /* Deref */
+ else if (EQ (keyword, Qderef))
+ {
+ if (EQ (value, Qnever))
+ ldap_deref = LDAP_DEREF_NEVER;
+ else if (EQ (value, Qsearch))
+ ldap_deref = LDAP_DEREF_SEARCHING;
+ else if (EQ (value, Qfind))
+ ldap_deref = LDAP_DEREF_FINDING;
+ else if (EQ (value, Qalways))
+ ldap_deref = LDAP_DEREF_ALWAYS;
+ else
+ signal_simple_error ("Invalid deref value", value);
+ }
+ /* Timelimit */
+ else if (EQ (keyword, Qtimelimit))
+ {
+ CHECK_INT (value);
+ ldap_timelimit = XINT (value);
+ }
+ /* Sizelimit */
+ else if (EQ (keyword, Qsizelimit))
+ {
+ CHECK_INT (value);
+ ldap_sizelimit = XINT (value);
+ }
+ }
+ }
if (ldap_port == 0)
{
/* Connect to the server and bind */
slow_down_interrupts ();
- ld = ldap_open ((char *)XSTRING_DATA (host), ldap_port);
+ ld = ldap_open ((char *) XSTRING_DATA (host), ldap_port);
speed_up_interrupts ();
if (ld == NULL )
{
Lisp_Object current = XCAR (attrs);
CHECK_STRING (current);
- TO_EXTERNAL_FORMAT (LISP_STRING, current,
- C_STRING_ALLOCA, ldap_attributes[i],
- Qnative);
+ LISP_STRING_TO_EXTERNAL (current, ldap_attributes[i], Qnative);
++i;
}
ldap_attributes[i] = NULL;
CHECK_CONS (current);
CHECK_STRING (XCAR (current));
ldap_mods_ptrs[i] = &(ldap_mods[i]);
- TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (current),
- C_STRING_ALLOCA, ldap_mods[i].mod_type,
- Qnative);
+ LISP_STRING_TO_EXTERNAL (XCAR (current), ldap_mods[i].mod_type, Qnative);
ldap_mods[i].mod_op = LDAP_MOD_ADD | LDAP_MOD_BVALUES;
values = XCDR (current);
if (CONSP (values))
signal_simple_error ("Invalid LDAP modification type", mod_op);
current = XCDR (current);
CHECK_STRING (XCAR (current));
- TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (current),
- C_STRING_ALLOCA, ldap_mods[i].mod_type,
- Qnative);
+ LISP_STRING_TO_EXTERNAL (XCAR (current), ldap_mods[i].mod_type, Qnative);
values = XCDR (current);
len = XINT (Flength (values));
bervals = alloca_array (struct berval, len);
Lisp_Object Qhash_tablep;
static Lisp_Object Qhashtable, Qhash_table;
-static Lisp_Object Qweakness, Qvalue, Qkey_value;
+static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value;
static Lisp_Object Vall_weak_hash_tables;
static Lisp_Object Qrehash_size, Qrehash_threshold;
static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
/* obsolete as of 19990901 in xemacs-21.2 */
-static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_value_weak;
+static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak;
static Lisp_Object Qnon_weak, Q_type;
typedef struct hentry
`size' (a natnum or nil)
`rehash-size' (a float)
`rehash-threshold' (a float)
- `weakness' (nil, t, key or value)
+ `weakness' (nil, key, value, key-and-value, or key-or-value)
`data' (a list)
If `print-readably' is nil, then a simpler syntax is used, for example
if (ht->weakness != HASH_TABLE_NON_WEAK)
{
sprintf (buf, " weakness %s",
- (ht->weakness == HASH_TABLE_WEAK ? "t" :
- ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
- ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
- ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-value" :
+ (ht->weakness == HASH_TABLE_WEAK ? "key-and-value" :
+ ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
+ ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
+ ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" :
"you-d-better-not-see-this"));
write_c_string (buf, printcharfun);
}
hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
Error_behavior errb)
{
- if (EQ (value, Qnil)) return 1;
- if (EQ (value, Qt)) return 1;
- if (EQ (value, Qkey)) return 1;
- if (EQ (value, Qkey_value)) return 1;
- if (EQ (value, Qvalue)) return 1;
+ if (EQ (value, Qnil)) return 1;
+ if (EQ (value, Qt)) return 1;
+ if (EQ (value, Qkey)) return 1;
+ if (EQ (value, Qkey_and_value)) return 1;
+ if (EQ (value, Qkey_or_value)) return 1;
+ if (EQ (value, Qvalue)) return 1;
/* Following values are obsolete as of 19990901 in xemacs-21.2 */
- if (EQ (value, Qnon_weak)) return 1;
- if (EQ (value, Qweak)) return 1;
- if (EQ (value, Qkey_weak)) return 1;
- if (EQ (value, Qkey_value_weak)) return 1;
- if (EQ (value, Qvalue_weak)) return 1;
+ if (EQ (value, Qnon_weak)) return 1;
+ if (EQ (value, Qweak)) return 1;
+ if (EQ (value, Qkey_weak)) return 1;
+ if (EQ (value, Qkey_or_value_weak)) return 1;
+ if (EQ (value, Qvalue_weak)) return 1;
maybe_signal_simple_error ("Invalid hash table weakness",
value, Qhash_table, errb);
static enum hash_table_weakness
decode_hash_table_weakness (Lisp_Object obj)
{
- if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
- if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
- if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
- if (EQ (obj, Qkey_value)) return HASH_TABLE_KEY_VALUE_WEAK;
- if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
+ if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
+ if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
+ if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK;
+ if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
+ if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK;
+ if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
/* Following values are obsolete as of 19990901 in xemacs-21.2 */
- if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
- if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
- if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
- if (EQ (obj, Qkey_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK;
- if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
+ if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
+ if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
+ if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
+ if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK;
+ if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
signal_simple_error ("Invalid hash table weakness", obj);
return HASH_TABLE_NON_WEAK; /* not reached */
Keyword :rehash-threshold must be a float between 0.0 and 1.0,
and specifies the load factor of the hash table which triggers enlarging.
-Non-standard keyword :weakness can be `nil' (default), `t', `key', `value'
-or `key-value'.
+Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value',
+`key', `value' or `key-or-value'. `t' is an alias for `key-and-value'.
-A weak hash table is one whose pointers do not count as GC referents:
-for any key-value pair in the hash table, if the only remaining pointer
-to either the key or the value is in a weak hash table, then the pair
-will be removed from the hash table, and the key and value collected.
-A non-weak hash table (or any other pointer) would prevent the object
-from being collected.
+A key-and-value-weak hash table, also known as a fully-weak or simply
+as a weak hash table, is one whose pointers do not count as GC
+referents: for any key-value pair in the hash table, if the only
+remaining pointer to either the key or the value is in a weak hash
+table, then the pair will be removed from the hash table, and the key
+and value collected. A non-weak hash table (or any other pointer)
+would prevent the object from being collected.
A key-weak hash table is similar to a fully-weak hash table except that
a key-value pair will be removed only if the key remains unmarked
hash table if the value is pointed to by something other than a weak
hash table, even if the key is not.
-A key-value-weak hash table is similar to a fully-weak hash table except
+A key-or-value-weak hash table is similar to a fully-weak hash table except
that a key-value pair will be removed only if the value and the key remain
unmarked outside of weak hash tables. The pair will remain in the
hash table if the value or key are pointed to by something other than a weak
DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
Return the weakness of HASH-TABLE.
-This can be one of `nil', `t', `key' or `value'.
+This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'.
*/
(hash_table))
{
switch (xhash_table (hash_table)->weakness)
{
- case HASH_TABLE_WEAK: return Qt;
- case HASH_TABLE_KEY_WEAK: return Qkey;
- case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_value;
- case HASH_TABLE_VALUE_WEAK: return Qvalue;
- default: return Qnil;
+ case HASH_TABLE_WEAK: return Qkey_and_value;
+ case HASH_TABLE_KEY_WEAK: return Qkey;
+ case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value;
+ case HASH_TABLE_VALUE_WEAK: return Qvalue;
+ default: return Qnil;
}
}
{
switch (xhash_table (hash_table)->weakness)
{
- case HASH_TABLE_WEAK: return Qweak;
- case HASH_TABLE_KEY_WEAK: return Qkey_weak;
- case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_value_weak;
- case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
- default: return Qnon_weak;
+ case HASH_TABLE_WEAK: return Qweak;
+ case HASH_TABLE_KEY_WEAK: return Qkey_weak;
+ case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak;
+ case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
+ default: return Qnon_weak;
}
}
defsymbol (&Qhashtable, "hashtable");
defsymbol (&Qweakness, "weakness");
defsymbol (&Qvalue, "value");
- defsymbol (&Qkey_value, "key-value");
+ defsymbol (&Qkey_or_value, "key-or-value");
+ defsymbol (&Qkey_and_value, "key-and-value");
defsymbol (&Qrehash_size, "rehash-size");
defsymbol (&Qrehash_threshold, "rehash-threshold");
defsymbol (&Qweak, "weak"); /* obsolete */
defsymbol (&Qkey_weak, "key-weak"); /* obsolete */
- defsymbol (&Qkey_value_weak, "key-value-weak"); /* obsolete */
+ defsymbol (&Qkey_or_value_weak, "key-or-value-weak"); /* obsolete */
defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
defsymbol (&Qnon_weak, "non-weak"); /* obsolete */
return value of the function `list-modules'.
It is possible, although unwise, to unload modules using `unload-module'.
-The prefered mechanism for unloading or reloading modules is to quit
+The preferred mechanism for unloading or reloading modules is to quit
XEmacs, and then reload those new or changed modules that are required.
Messages informing you of the progress of the load are displayed unless
As with load-module, this function requires at least the module FILE, and
optionally the module NAME and VERSION to unload. It may not be possible
for the module to be unloaded from memory, as there may be Lisp objects
-refering to variables inside the module code. However, once you have
+referring to variables inside the module code. However, once you have
requested a module to be unloaded, it will be unloaded from memory as
soon as the last reference to symbols within the module is destroyed.
*/
return fs; /* First free slot */
/*
- * We only get here if we havent found a free slot and the module was
+ * We only get here if we haven't found a free slot and the module was
* not previously loaded.
*/
if (modules == (emodules_list *)0)
* Do the actual grunt-work of loading in a module. We first try and
* dlopen() the module. If that fails, we have an error and we bail
* out immediately. If the dlopen() succeeds, we need to check for the
- * existance of certain special symbols.
+ * existence of certain special symbols.
*
* All modules will have complete access to the variables and functions
* defined within XEmacs itself. It is up to the module to declare any
*
* We need to be very careful with how we load modules. If we encounter an
* error along the way, we need to back out completely to the point at
- * which the user started. Since we can be called resursively, we need to
+ * which the user started. Since we can be called recursively, we need to
* take care with marking modules as loaded. When we first start loading
* modules, we set the counter to zero. As we enter the function each time,
- * we incremement the counter, and before we leave we decrement it. When
+ * we increment the counter, and before we leave we decrement it. When
* we get back down to 0, we know we are at the end of the chain and we
* can mark all the modules in the list as loaded.
*
* When we signal an error, we need to be sure to unwind all modules loaded
* thus far (but only for this module chain). It is assumed that if any
* modules in a chain fail, then they all do. This is logical, considering
- * that the only time we recurse is when we have dependant modules. So in
+ * that the only time we recurse is when we have dependent modules. So in
* the error handler we take great care to close off the module chain before
* we call "error" and let the Fmodule_load unwind_protect() function handle
* the cleaning up.
strcat (symname, mname);
modload = (void (*)(void))dll_function (dlhandle, symname);
/*
- * modload is optional. If the module doesnt require other modules it can
+ * modload is optional. If the module doesn't require other modules it can
* be left out.
*/
* Attempt to make a new slot for this module. If this really is the
* first time we are loading this module, the used member will be 0.
* If that is non-zero, we know that we have a previously loaded module
- * of the same name and version, and we dont need to go any further.
+ * of the same name and version, and we don't need to go any further.
*/
mpx = find_make_module (soname, mname, mver, 0);
mp = &modules[mpx];
This string is in the form XX.YY.ppp, where XX is the major version
number, YY is the minor version number, and ppp is the patch level.
-This variable can be used to distinquish between different versions of
+This variable can be used to distinguish between different versions of
the dynamic loading technology used in Emacs, if required. It is not
a given that this value will be the same as the Emacs version number.
*/ );
Each element is a string (directory name) or nil (try default directory).
Note that elements of this list *may not* begin with "~", so you must
-call `expland-file-name' on them before adding them to this list.
+call `expand-file-name' on them before adding them to this list.
Initialized based on EMACSMODULEPATH environment variable, if any, otherwise
to default specified the file `paths.h' when XEmacs was built. If there
directory in which the XEmacs executable resides.
Due to the nature of dynamic modules, the path names should almost always
-refer to architecture-dependant directories. It is unwise to attempt to
-store dynamic modules in a hetrogenous environment. Some environments
+refer to architecture-dependent directories. It is unwise to attempt to
+store dynamic modules in a heterogenous environment. Some environments
are similar enough to each other that XEmacs will be unable to determine
the correctness of a dynamic module, which can have unpredictable results
when a dynamic module is loaded.
* second is the name of the module, and the third is the module version.
* If the module name is NULL, we will always reload the .so. If it is not
* NULL, we check to make sure we haven't loaded it before. If the version
- * is specified, we check to make sure we didnt load the module of the
+ * is specified, we check to make sure we didn't load the module of the
* specified version before. We also use these as checks when we open the
* module to make sure we have the right module.
*/
/*
* Because subrs and symbols added by a dynamic module are not part of
* the make-docfile process, we need a clean way to get the variables
- * and functions documented. Since people dont like the idea of making
+ * and functions documented. Since people don't like the idea of making
* shared modules use different versions of DEFSUBR() and DEFVAR_LISP()
* and friends, we need these two functions to insert the documentation
* into the right place. These functions will be called by the module
/* Evaluator for XEmacs Lisp interpreter.
Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
Copyright (C) 1995 Sun Microsystems, Inc.
+ Copyright (C) 2000 Ben Wing.
This file is part of XEmacs.
specbind (Qdebug_on_signal, Qnil);
specbind (Qstack_trace_on_signal, Qnil);
- internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
- backtrace_259,
- Qnil,
- Qnil);
+ if (!noninteractive)
+ internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
+ backtrace_259,
+ Qnil,
+ Qnil);
+ else /* in batch mode, we want this going to stderr. */
+ backtrace_259 (Qnil);
unbind_to (speccount, Qnil);
*stack_trace_displayed = 1;
}
specbind (Qdebug_on_signal, Qnil);
specbind (Qstack_trace_on_signal, Qnil);
- internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
- backtrace_259,
- Qnil,
- Qnil);
+ if (!noninteractive)
+ internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
+ backtrace_259,
+ Qnil,
+ Qnil);
+ else /* in batch mode, we want this going to stderr. */
+ backtrace_259 (Qnil);
unbind_to (speccount, Qnil);
*stack_trace_displayed = 1;
}
(args))
{
/* This function can GC */
- REGISTER Lisp_Object arg, val;
+ REGISTER Lisp_Object val;
LIST_LOOP_2 (arg, args)
{
(args))
{
/* This function can GC */
- REGISTER Lisp_Object arg, val = Qt;
+ REGISTER Lisp_Object val = Qt;
LIST_LOOP_2 (arg, args)
{
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val, clause;
+ REGISTER Lisp_Object val;
LIST_LOOP_2 (clause, args)
{
{
/* This function can GC */
/* Caller must provide a true list in ARGS */
- REGISTER Lisp_Object form, val = Qnil;
+ REGISTER Lisp_Object val = Qnil;
struct gcpro gcpro1;
GCPRO1 (args);
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val, form;
+ REGISTER Lisp_Object val;
struct gcpro gcpro1;
val = Feval (XCAR (args));
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val, form, tail;
+ REGISTER Lisp_Object val;
struct gcpro gcpro1;
Feval (XCAR (args));
GCPRO1 (val);
- LIST_LOOP_3 (form, args, tail)
- Feval (form);
+ {
+ LIST_LOOP_2 (form, args)
+ Feval (form);
+ }
UNGCPRO;
return val;
(args))
{
/* This function can GC */
- Lisp_Object var, tail;
Lisp_Object varlist = XCAR (args);
Lisp_Object body = XCDR (args);
int speccount = specpdl_depth();
(args))
{
/* This function can GC */
- Lisp_Object var, tail;
Lisp_Object varlist = XCAR (args);
Lisp_Object body = XCDR (args);
int speccount = specpdl_depth();
gcpro1.nvars = 0;
idx = 0;
- LIST_LOOP_3 (var, varlist, tail)
- {
- Lisp_Object *value = &temps[idx++];
- if (SYMBOLP (var))
- *value = Qnil;
- else
- {
- Lisp_Object tem;
- CHECK_CONS (var);
- tem = XCDR (var);
- if (NILP (tem))
- *value = Qnil;
- else
- {
- CHECK_CONS (tem);
- *value = Feval (XCAR (tem));
- gcpro1.nvars = idx;
+ {
+ LIST_LOOP_2 (var, varlist)
+ {
+ Lisp_Object *value = &temps[idx++];
+ if (SYMBOLP (var))
+ *value = Qnil;
+ else
+ {
+ Lisp_Object tem;
+ CHECK_CONS (var);
+ tem = XCDR (var);
+ if (NILP (tem))
+ *value = Qnil;
+ else
+ {
+ CHECK_CONS (tem);
+ *value = Feval (XCAR (tem));
+ gcpro1.nvars = idx;
- if (!NILP (XCDR (tem)))
- signal_simple_error
- ("`let' bindings can have only one value-form", var);
- }
- }
- }
+ if (!NILP (XCDR (tem)))
+ signal_simple_error
+ ("`let' bindings can have only one value-form", var);
+ }
+ }
+ }
+ }
idx = 0;
- LIST_LOOP_3 (var, varlist, tail)
- {
- specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
- }
+ {
+ LIST_LOOP_2 (var, varlist)
+ {
+ specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
+ }
+ }
UNGCPRO;
Otherwise, the macro is expanded and the expansion is considered
in place of FORM. When a non-macro-call results, it is returned.
-The second optional arg ENVIRONMENT species an environment of macro
+The second optional arg ENVIRONMENT specifies an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation.
*/
- (form, env))
+ (form, environment))
{
/* This function can GC */
/* With cleanups from Hallvard Furuseth. */
{
QUIT;
sym = def;
- tem = Fassq (sym, env);
+ tem = Fassq (sym, environment);
if (NILP (tem))
{
def = XSYMBOL (sym)->function;
}
break;
}
- /* Right now TEM is the result from SYM in ENV,
+ /* Right now TEM is the result from SYM in ENVIRONMENT,
and if TEM is nil then DEF is SYM's function definition. */
if (NILP (tem))
{
- /* SYM is not mentioned in ENV.
+ /* SYM is not mentioned in ENVIRONMENT.
Look at its function definition. */
if (UNBOUNDP (def)
|| !CONSP (def))
condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
{
/* This function can GC */
- Lisp_Object handler;
-
EXTERNAL_LIST_LOOP_2 (handler, handlers)
{
if (NILP (handler))
;
else
{
- Lisp_Object condition;
EXTERNAL_LIST_LOOP_2 (condition, conditions)
if (!SYMBOLP (condition))
goto invalid_condition_handler;
/****************** Error functions class 2 ******************/
/* Class 2: Printf-like functions that signal an error.
+ These functions signal an error of a specified type, whose data
+ is a single string, created using the arguments. */
+
+/* dump an error message; called like printf */
+
+DOESNT_RETURN
+type_error (Lisp_Object type, const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ signal_error (type, list1 (obj));
+}
+
+void
+maybe_type_error (Lisp_Object type, Lisp_Object class, Error_behavior errb,
+ const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ maybe_signal_error (type, list1 (obj), class, errb);
+}
+
+Lisp_Object
+continuable_type_error (Lisp_Object type, const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ return Fsignal (type, list1 (obj));
+}
+
+Lisp_Object
+maybe_continuable_type_error (Lisp_Object type, Lisp_Object class,
+ Error_behavior errb, const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return Qnil;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ return maybe_signal_continuable_error (type, list1 (obj), class, errb);
+}
+
+\f
+/****************** Error functions class 3 ******************/
+
+/* Class 3: Signal an error with a string and an associated object.
+ These functions signal an error of a specified type, whose data
+ is two objects, a string and a related Lisp object (usually the object
+ where the error is occurring). */
+
+DOESNT_RETURN
+signal_type_error (Lisp_Object type, const char *reason, Lisp_Object frob)
+{
+ if (UNBOUNDP (frob))
+ signal_error (type, list1 (build_translated_string (reason)));
+ else
+ signal_error (type, list2 (build_translated_string (reason), frob));
+}
+
+void
+maybe_signal_type_error (Lisp_Object type, const char *reason,
+ Lisp_Object frob, Lisp_Object class,
+ Error_behavior errb)
+{
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return;
+ maybe_signal_error (type, list2 (build_translated_string (reason), frob),
+ class, errb);
+}
+
+Lisp_Object
+signal_type_continuable_error (Lisp_Object type, const char *reason,
+ Lisp_Object frob)
+{
+ return Fsignal (type, list2 (build_translated_string (reason), frob));
+}
+
+Lisp_Object
+maybe_signal_type_continuable_error (Lisp_Object type, const char *reason,
+ Lisp_Object frob, Lisp_Object class,
+ Error_behavior errb)
+{
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return Qnil;
+ return maybe_signal_continuable_error
+ (type, list2 (build_translated_string (reason),
+ frob), class, errb);
+}
+
+\f
+/****************** Error functions class 4 ******************/
+
+/* Class 4: Printf-like functions that signal an error.
+ These functions signal an error of a specified type, whose data
+ is a two objects, a string (created using the arguments) and a
+ Lisp object.
+*/
+
+DOESNT_RETURN
+type_error_with_frob (Lisp_Object type, Lisp_Object frob, const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ signal_error (type, list2 (obj, frob));
+}
+
+void
+maybe_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
+ Lisp_Object class, Error_behavior errb,
+ const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ maybe_signal_error (type, list2 (obj, frob), class, errb);
+}
+
+Lisp_Object
+continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
+ const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ return Fsignal (type, list2 (obj, frob));
+}
+
+Lisp_Object
+maybe_continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
+ Lisp_Object class, Error_behavior errb,
+ const char *fmt, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return Qnil;
+
+ va_start (args, fmt);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ return maybe_signal_continuable_error (type, list2 (obj, frob),
+ class, errb);
+}
+
+\f
+/****************** Error functions class 5 ******************/
+
+/* Class 5: Signal an error with a string and two associated objects.
+ These functions signal an error of a specified type, whose data
+ is three objects, a string and two related Lisp objects. */
+
+DOESNT_RETURN
+signal_type_error_2 (Lisp_Object type, const char *reason,
+ Lisp_Object frob0, Lisp_Object frob1)
+{
+ signal_error (type, list3 (build_translated_string (reason), frob0,
+ frob1));
+}
+
+void
+maybe_signal_type_error_2 (Lisp_Object type, const char *reason,
+ Lisp_Object frob0, Lisp_Object frob1,
+ Lisp_Object class, Error_behavior errb)
+{
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return;
+ maybe_signal_error (type, list3 (build_translated_string (reason), frob0,
+ frob1), class, errb);
+}
+
+
+Lisp_Object
+signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
+ Lisp_Object frob0, Lisp_Object frob1)
+{
+ return Fsignal (type, list3 (build_translated_string (reason), frob0,
+ frob1));
+}
+
+Lisp_Object
+maybe_signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
+ Lisp_Object frob0, Lisp_Object frob1,
+ Lisp_Object class, Error_behavior errb)
+{
+ /* Optimization: */
+ if (ERRB_EQ (errb, ERROR_ME_NOT))
+ return Qnil;
+ return maybe_signal_continuable_error
+ (type, list3 (build_translated_string (reason), frob0,
+ frob1),
+ class, errb);
+}
+
+\f
+/****************** Simple error functions class 2 ******************/
+
+/* Simple class 2: Printf-like functions that signal an error.
These functions signal an error of type Qerror, whose data
is a single string, created using the arguments. */
}
\f
-/****************** Error functions class 3 ******************/
+/****************** Simple error functions class 3 ******************/
-/* Class 3: Signal an error with a string and an associated object.
+/* Simple class 3: Signal an error with a string and an associated object.
These functions signal an error of type Qerror, whose data
is two objects, a string and a related Lisp object (usually the object
where the error is occurring). */
}
\f
-/****************** Error functions class 4 ******************/
+/****************** Simple error functions class 4 ******************/
-/* Class 4: Printf-like functions that signal an error.
+/* Simple class 4: Printf-like functions that signal an error.
These functions signal an error of type Qerror, whose data
is a two objects, a string (created using the arguments) and a
Lisp object.
}
\f
-/****************** Error functions class 5 ******************/
+/****************** Simple error functions class 5 ******************/
-/* Class 5: Signal an error with a string and two associated objects.
+/* Simple class 5: Signal an error with a string and two associated objects.
These functions signal an error of type Qerror, whose data
is three objects, a string and two related Lisp objects. */
{
signal_error (Qcircular_property_list, list1 (list));
}
+
+DOESNT_RETURN
+syntax_error (const char *reason, Lisp_Object frob)
+{
+ signal_type_error (Qsyntax_error, reason, frob);
+}
+
+DOESNT_RETURN
+syntax_error_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+ signal_type_error_2 (Qsyntax_error, reason, frob1, frob2);
+}
+
+DOESNT_RETURN
+invalid_argument (const char *reason, Lisp_Object frob)
+{
+ signal_type_error (Qinvalid_argument, reason, frob);
+}
+
+DOESNT_RETURN
+invalid_argument_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+ signal_type_error_2 (Qinvalid_argument, reason, frob1, frob2);
+}
+
+DOESNT_RETURN
+invalid_operation (const char *reason, Lisp_Object frob)
+{
+ signal_type_error (Qinvalid_operation, reason, frob);
+}
+
+DOESNT_RETURN
+invalid_operation_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+ signal_type_error_2 (Qinvalid_operation, reason, frob1, frob2);
+}
+
+DOESNT_RETURN
+invalid_change (const char *reason, Lisp_Object frob)
+{
+ signal_type_error (Qinvalid_change, reason, frob);
+}
+
+DOESNT_RETURN
+invalid_change_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+ signal_type_error_2 (Qinvalid_change, reason, frob1, frob2);
+}
+
\f
/************************************************************************/
/* User commands */
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
}
else if (EQ (funcar, Qautoload))
{
+ struct gcpro gcpro1;
+
+ GCPRO1 (function);
do_autoload (function, orig_function);
+ UNGCPRO;
+ function = orig_function;
goto retry;
}
else if (EQ (funcar, Qlambda))
else
{
invalid_function:
- return signal_invalid_function_error (function);
+ return signal_invalid_function_error (orig_function);
}
{
int argcount = 0;
- Lisp_Object arg;
EXTERNAL_LIST_LOOP_2 (arg, arglist)
{
funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
{
/* This function can GC */
- Lisp_Object symbol, arglist, body, tail;
+ Lisp_Object arglist, body, tail;
int speccount = specpdl_depth();
REGISTER int i = 0;
{
int optional = 0, rest = 0;
- EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
+ EXTERNAL_LIST_LOOP_2 (symbol, arglist)
{
if (!SYMBOLP (symbol))
goto invalid_function;
specpdl = xnew_array (struct specbinding, specpdl_size);
/* XEmacs change: increase these values. */
max_specpdl_size = 3000;
- max_lisp_eval_depth = 500;
+ max_lisp_eval_depth = 1000;
#ifdef DEFEND_AGAINST_THROW_RECURSION
throw_level = 0;
#endif
int x_allow_sendevents;
#ifdef DEBUG_XEMACS
-int x_debug_events;
+int debug_x_events;
#endif
static int process_events_occurred;
#ifdef HAVE_XIM
int len;
- char buffer[64];
+ /* Some implementations of XmbLookupString don't return
+ XBufferOverflow correctly, so increase the size of the xim input
+ buffer from 64 to the more reasonable size 513, as Emacs has done.
+ From Kenichi Handa. */
+ char buffer[513];
char *bufptr = buffer;
int bufsiz = sizeof (buffer);
Status status;
#endif /* HAVE_XIM */
#ifdef DEBUG_XEMACS
- if (x_debug_events > 0)
+ if (debug_x_events > 0)
{
stderr_out (" status=");
#define print_status_when(S) if (status == S) stderr_out (#S)
if (*state & xd->SuperMask) modifiers |= XEMACS_MOD_SUPER;
if (*state & xd->HyperMask) modifiers |= XEMACS_MOD_HYPER;
if (*state & xd->AltMask) modifiers |= XEMACS_MOD_ALT;
+ {
+ int numero_de_botao = -1;
+
+ if (!key_event_p)
+ numero_de_botao = x_event->xbutton.button;
+
+ /* the button gets noted either in the button or the modifiers
+ field, but not both. */
+ if (numero_de_botao != 1 && (*state & Button1Mask))
+ modifiers |= XEMACS_MOD_BUTTON1;
+ if (numero_de_botao != 2 && (*state & Button2Mask))
+ modifiers |= XEMACS_MOD_BUTTON2;
+ if (numero_de_botao != 3 && (*state & Button3Mask))
+ modifiers |= XEMACS_MOD_BUTTON3;
+ if (numero_de_botao != 4 && (*state & Button4Mask))
+ modifiers |= XEMACS_MOD_BUTTON4;
+ if (numero_de_botao != 5 && (*state & Button5Mask))
+ modifiers |= XEMACS_MOD_BUTTON5;
+ }
/* Ignore the Caps_Lock key if:
- any other modifiers are down, so that Caps_Lock doesn't
if (ev->state & xd->SuperMask) modifiers |= XEMACS_MOD_SUPER;
if (ev->state & xd->HyperMask) modifiers |= XEMACS_MOD_HYPER;
if (ev->state & xd->AltMask) modifiers |= XEMACS_MOD_ALT;
+ if (ev->state & Button1Mask) modifiers |= XEMACS_MOD_BUTTON1;
+ if (ev->state & Button2Mask) modifiers |= XEMACS_MOD_BUTTON2;
+ if (ev->state & Button3Mask) modifiers |= XEMACS_MOD_BUTTON3;
+ if (ev->state & Button4Mask) modifiers |= XEMACS_MOD_BUTTON4;
+ if (ev->state & Button5Mask) modifiers |= XEMACS_MOD_BUTTON5;
/* Currently ignores Shift_Lock but probably shouldn't
(but it definitely should ignore Caps_Lock). */
emacs_event->event.motion.modifiers = modifiers;
if (state & xd->SuperMask) modifiers |= XEMACS_MOD_SUPER;
if (state & xd->HyperMask) modifiers |= XEMACS_MOD_HYPER;
if (state & xd->AltMask) modifiers |= XEMACS_MOD_ALT;
+ if (state & Button1Mask) modifiers |= XEMACS_MOD_BUTTON1;
+ if (state & Button2Mask) modifiers |= XEMACS_MOD_BUTTON2;
+ if (state & Button3Mask) modifiers |= XEMACS_MOD_BUTTON3;
+ if (state & Button4Mask) modifiers |= XEMACS_MOD_BUTTON4;
+ if (state & Button5Mask) modifiers |= XEMACS_MOD_BUTTON5;
if (state & Button5Mask) button = Button5;
if (state & Button4Mask) button = Button4;
do this in their selection callback, but we don't want that since
a button having focus is legitimate. An edit field having focus
is mandatory. Weirdly you get a FocusOut event when you click in
- a widget-glyph but you don't get a correspondng FocusIn when you
+ a widget-glyph but you don't get a corresponding FocusIn when you
click in the frame. Why is this? */
if (in_p
#if XtSpecificationRelease > 5
break;
case Expose:
- if (x_debug_events > 1)
+ if (debug_x_events > 1)
{
XExposeEvent *ev = &event->xexpose;
describe_event_window (ev->window, ev->display);
break;
case GraphicsExpose:
- if (x_debug_events > 1)
+ if (debug_x_events > 1)
{
XGraphicsExposeEvent *ev = &event->xgraphicsexpose;
describe_event_window (ev->drawable, ev->display);
case EnterNotify:
case LeaveNotify:
- if (x_debug_events > 1)
+ if (debug_x_events > 1)
{
XCrossingEvent *ev = &event->xcrossing;
describe_event_window (ev->window, ev->display);
break;
case ConfigureNotify:
- if (x_debug_events > 1)
+ if (debug_x_events > 1)
{
XConfigureEvent *ev = &event->xconfigure;
describe_event_window (ev->window, ev->display);
break;
case VisibilityNotify:
- if (x_debug_events > 1)
+ if (debug_x_events > 1)
{
XVisibilityEvent *ev = &event->xvisibility;
describe_event_window (ev->window, ev->display);
Lisp_Object emacs_event = Fmake_event (Qnil, Qnil);
#ifdef DEBUG_XEMACS
- if (x_debug_events > 0)
+ if (debug_x_events > 0)
{
describe_event (event);
}
return 0;
}
+static int
+emacs_Xt_current_event_timestamp (struct console *c)
+{
+ /* semi-yuck. */
+ Lisp_Object devs = CONSOLE_DEVICE_LIST (c);
+
+ if (NILP (devs))
+ return 0;
+ else
+ {
+ struct device *d = XDEVICE (XCAR (devs));
+ return DEVICE_X_LAST_SERVER_TIMESTAMP (d);
+ }
+}
+
\f
/************************************************************************/
/* replacement for standard string-to-pixel converter */
if ((d = get_device_from_display_1(dpy))) {
visual = DEVICE_X_VISUAL(d);
if (colormap != DEVICE_X_COLORMAP(d)) {
- XtAppWarningMsg(the_app_con, "wierdColormap", "cvtStringToPixel",
+ XtAppWarningMsg(the_app_con, "weirdColormap", "cvtStringToPixel",
"XtToolkitWarning",
- "The colormap passed to cvtStringToPixel doesn't match the one registerd to the device.\n",
+ "The colormap passed to cvtStringToPixel doesn't match the one registered to the device.\n",
NULL, 0);
status = XAllocNamedColor(dpy, colormap, (char*)str, &screenColor, &exactColor);
} else {
Xt_event_stream->quit_p_cb = emacs_Xt_quit_p;
Xt_event_stream->create_stream_pair_cb = emacs_Xt_create_stream_pair;
Xt_event_stream->delete_stream_pair_cb = emacs_Xt_delete_stream_pair;
+ Xt_event_stream->current_event_timestamp_cb =
+ emacs_Xt_current_event_timestamp;
the_Xt_timeout_blocktype = Blocktype_new (struct Xt_timeout_blocktype);
x_allow_sendevents = 0;
#ifdef DEBUG_XEMACS
- DEFVAR_INT ("x-debug-events", &x_debug_events /*
+ DEFVAR_INT ("debug-x-events", &debug_x_events /*
If non-zero, display debug information about X events that XEmacs sees.
Information is displayed on stderr. Currently defined values are:
1 == non-verbose output
2 == verbose output
*/ );
- x_debug_events = 0;
+ debug_x_events = 0;
#endif
}
Xt_app_con = XtCreateApplicationContext ();
XtAppSetFallbackResources (Xt_app_con, (String *) x_fallback_resources);
- /* In xselect.c */
+ /* In select-x.c */
x_selection_timeout = (XtAppGetSelectionTimeout (Xt_app_con) / 1000);
XSetErrorHandler (x_error_handler);
XSetIOErrorHandler (x_IO_error_handler);
static Lisp_Object mswindows_find_console (HWND hwnd);
static Lisp_Object mswindows_key_to_emacs_keysym (int mswindows_key, int mods,
int extendedp);
-static int mswindows_modifier_state (BYTE* keymap, int has_AltGr);
+static int mswindows_modifier_state (BYTE* keymap, DWORD fwKeys,
+ int has_AltGr);
static void mswindows_set_chord_timer (HWND hwnd);
static int mswindows_button2_near_enough (POINTS p1, POINTS p2);
static int mswindows_current_layout_has_AltGr (void);
int mswindows_mouse_button_tolerance;
#ifdef DEBUG_XEMACS
-int mswindows_debug_events;
+int debug_mswindows_events;
#endif
/* This is the event signaled by the event pump.
/* Count of wound timers */
static int mswindows_pending_timers_count;
+
+static DWORD mswindows_last_mouse_button_state;
\f
/************************************************************************/
/* Pipe instream - reads process output */
SetEvent (s->hev_thread);
/* Give it a chance to run -- this dramatically improves performance
of things like crypt. */
- (void) SwitchToThread ();
+ if (xSwitchToThread) /* not in Win9x or NT 3.51 */
+ (void) xSwitchToThread ();
return size;
}
static void
mswindows_enqueue_mouse_button_event (HWND hwnd, UINT msg, POINTS where,
- DWORD when)
+ int mods, DWORD when)
{
int downp = (msg == WM_LBUTTONDOWN || msg == WM_MBUTTONDOWN ||
msg == WM_RBUTTONDOWN);
((msg==WM_RBUTTONDOWN || msg==WM_RBUTTONUP) ? 3 : 2);
event->event.button.x = where.x;
event->event.button.y = where.y;
- event->event.button.modifiers = mswindows_modifier_state (NULL, 0);
+ event->event.button.modifiers = mswindows_modifier_state (NULL, mods, 0);
if (downp)
{
while (PeekMessage (&msg, NULL, 0, 0, PM_REMOVE))
{
+ char class_name_buf [sizeof (XEMACS_CLASS) + 2] = "";
+
+ if (mswindows_is_dialog_msg (&msg))
+ {
+ mswindows_unmodalize_signal_maybe ();
+ continue;
+ }
+
/* We have to translate messages that are not sent to an XEmacs
frame. This is so that key presses work ok in things like
edit fields. However, we *musn't* translate message for XEmacs
/* GetClassName will truncate a longer class name. By adding one
extra character, we are forcing textual comparison to fail
if the name is longer than XEMACS_CLASS */
- char class_name_buf [sizeof (XEMACS_CLASS) + 2] = "";
+
GetClassName (msg.hwnd, class_name_buf, sizeof (class_name_buf) - 1);
if (stricmp (class_name_buf, XEMACS_CLASS) != 0)
{
else if (msg.message == WM_PAINT)
{
struct mswindows_frame* msframe;
-
+
/* hdc will be NULL unless this is a subwindow - in which case we
shouldn't have received a paint message for it here. */
assert (msg.wParam == 0);
{
mswindows_drain_windows_queue ();
}
- else
+ else
{
#ifdef HAVE_TTY
/* Look for a TTY event */
struct console *c = tty_find_console_from_fd (i);
Lisp_Object emacs_event = Fmake_event (Qnil, Qnil);
Lisp_Event* event = XEVENT (emacs_event);
-
+
assert (c);
if (read_event_from_tty_or_stream_desc (event, c, i))
{
{
Lisp_Process *p =
get_process_from_usid (FD_TO_USID(i));
-
+
mswindows_enqueue_process_event (p);
}
else
}
/*
- * Returns 1 if a key is a real modifier or special key, which
+ * Returns 1 if a key is a real modifier or special key, which
* is better handled by DefWindowProc
*/
static int
/* asyncstate[2] & 0x1 ? 1 : 0); */
}
-#endif /* DEBUG_XEMACS */
+#endif /* DEBUG_XEMACS */
/*
struct frame *frame;
struct mswindows_frame* msframe;
+ /* Not perfect but avoids crashes. There is potential for wierd
+ behavior here. */
+ if (gc_in_progress)
+ goto defproc;
+
assert (!GetWindowLong (hwnd, GWL_USERDATA));
switch (message_)
{
int should_set_keymap = 0;
#ifdef DEBUG_XEMACS
- if (mswindows_debug_events)
+ if (debug_mswindows_events)
{
stderr_out ("%s wparam=%d lparam=%d\n",
message_ == WM_KEYUP ? "WM_KEYUP" : "WM_SYSKEYUP",
wParam, (int)lParam);
output_alt_keyboard_state ();
- }
-#endif /* DEBUG_XEMACS */
+ }
+#endif /* DEBUG_XEMACS */
mswindows_handle_sticky_modifiers (wParam, lParam, 0, 1);
if (wParam == VK_CONTROL)
SetKeyboardState (keymap);
}
-
+
if (key_needs_default_processing_p (wParam))
goto defproc;
else
case WM_SYSKEYDOWN:
/* In some locales the right-hand Alt key is labelled AltGr. This key
- * should produce alternative charcaters when combined with another key.
+ * should produce alternative characters when combined with another key.
* eg on a German keyboard pressing AltGr+q should produce '@'.
* AltGr generates exactly the same keystrokes as LCtrl+RAlt. But if
* TranslateMessage() is called with *any* combination of Ctrl+Alt down,
int sticky_changed;
#ifdef DEBUG_XEMACS
- if (mswindows_debug_events)
+ if (debug_mswindows_events)
{
stderr_out ("%s wparam=%d lparam=%d\n",
message_ == WM_KEYDOWN ? "WM_KEYDOWN" : "WM_SYSKEYDOWN",
wParam, (int)lParam);
output_alt_keyboard_state ();
- }
-#endif /* DEBUG_XEMACS */
+ }
+#endif /* DEBUG_XEMACS */
GetKeyboardState (keymap_orig);
frame = XFRAME (mswindows_find_frame (hwnd));
else
memcpy (keymap_sticky, keymap_orig, 256);
- mods = mswindows_modifier_state (keymap_sticky, has_AltGr);
+ mods = mswindows_modifier_state (keymap_sticky, (DWORD) -1, has_AltGr);
/* Handle non-printables */
if (!NILP (keysym = mswindows_key_to_emacs_keysym (wParam, mods,
MSG msg, tranmsg;
int potential_accelerator = 0;
int got_accelerator = 0;
-
+
msg.hwnd = hwnd;
msg.message = message_;
msg.wParam = wParam;
/* This generates WM_SYSCHAR messages, which are interpreted
by DefWindowProc as the menu selections. */
if (got_accelerator)
- {
+ {
SetKeyboardState (keymap_sticky);
TranslateMessage (&msg);
SetKeyboardState (keymap_orig);
if one wants to exercise fingers playing chords on the mouse,
he is allowed to do that! */
mswindows_enqueue_mouse_button_event (hwnd, message_,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam &~ MK_MBUTTON,
+ GetMessageTime());
break;
case WM_LBUTTONUP:
msframe->button2_is_down = 0;
msframe->ignore_next_rbutton_up = 1;
mswindows_enqueue_mouse_button_event (hwnd, WM_MBUTTONUP,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam
+ &~ (MK_LBUTTON | MK_MBUTTON
+ | MK_RBUTTON),
+ GetMessageTime());
}
else
{
{
msframe->button2_need_rbutton = 0;
mswindows_enqueue_mouse_button_event (hwnd, WM_LBUTTONDOWN,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam &~ MK_LBUTTON,
+ GetMessageTime());
}
mswindows_enqueue_mouse_button_event (hwnd, WM_LBUTTONUP,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam &~ MK_LBUTTON,
+ GetMessageTime());
}
break;
msframe->button2_is_down = 0;
msframe->ignore_next_lbutton_up = 1;
mswindows_enqueue_mouse_button_event (hwnd, WM_MBUTTONUP,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam
+ &~ (MK_LBUTTON | MK_MBUTTON
+ | MK_RBUTTON),
+ GetMessageTime());
}
else
{
{
msframe->button2_need_lbutton = 0;
mswindows_enqueue_mouse_button_event (hwnd, WM_RBUTTONDOWN,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam &~ MK_RBUTTON,
+ GetMessageTime());
}
mswindows_enqueue_mouse_button_event (hwnd, WM_RBUTTONUP,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam &~ MK_RBUTTON,
+ GetMessageTime());
}
break;
KillTimer (hwnd, BUTTON_2_TIMER_ID);
msframe->button2_need_lbutton = 0;
msframe->button2_need_rbutton = 0;
- if (mswindows_button2_near_enough (msframe->last_click_point, MAKEPOINTS (lParam)))
+ if (mswindows_button2_near_enough (msframe->last_click_point,
+ MAKEPOINTS (lParam)))
{
mswindows_enqueue_mouse_button_event (hwnd, WM_MBUTTONDOWN,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam
+ &~ (MK_LBUTTON | MK_MBUTTON
+ | MK_RBUTTON),
+ GetMessageTime());
msframe->button2_is_down = 1;
}
else
{
mswindows_enqueue_mouse_button_event (hwnd, WM_RBUTTONDOWN,
- msframe->last_click_point, msframe->last_click_time);
+ msframe->last_click_point,
+ msframe->last_click_mods
+ &~ MK_RBUTTON,
+ msframe->last_click_time);
mswindows_enqueue_mouse_button_event (hwnd, WM_LBUTTONDOWN,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam &~ MK_LBUTTON,
+ GetMessageTime());
}
}
else
mswindows_set_chord_timer (hwnd);
msframe->button2_need_rbutton = 1;
msframe->last_click_point = MAKEPOINTS (lParam);
+ msframe->last_click_mods = wParam;
}
msframe->last_click_time = GetMessageTime();
break;
KillTimer (hwnd, BUTTON_2_TIMER_ID);
msframe->button2_need_lbutton = 0;
msframe->button2_need_rbutton = 0;
- if (mswindows_button2_near_enough (msframe->last_click_point, MAKEPOINTS (lParam)))
+ if (mswindows_button2_near_enough (msframe->last_click_point,
+ MAKEPOINTS (lParam)))
{
mswindows_enqueue_mouse_button_event (hwnd, WM_MBUTTONDOWN,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam
+ &~ (MK_LBUTTON | MK_MBUTTON
+ | MK_RBUTTON),
+ GetMessageTime());
msframe->button2_is_down = 1;
}
else
{
mswindows_enqueue_mouse_button_event (hwnd, WM_LBUTTONDOWN,
- msframe->last_click_point, msframe->last_click_time);
+ msframe->last_click_point,
+ msframe->last_click_mods
+ &~ MK_LBUTTON,
+ msframe->last_click_time);
mswindows_enqueue_mouse_button_event (hwnd, WM_RBUTTONDOWN,
- MAKEPOINTS (lParam), GetMessageTime());
+ MAKEPOINTS (lParam),
+ wParam &~ MK_RBUTTON,
+ GetMessageTime());
}
}
else
mswindows_set_chord_timer (hwnd);
msframe->button2_need_lbutton = 1;
msframe->last_click_point = MAKEPOINTS (lParam);
+ msframe->last_click_mods = wParam;
}
msframe->last_click_time = GetMessageTime();
break;
{
msframe->button2_need_lbutton = 0;
mswindows_enqueue_mouse_button_event (hwnd, WM_RBUTTONDOWN,
- msframe->last_click_point, msframe->last_click_time);
+ msframe->last_click_point,
+ msframe->last_click_mods
+ &~ MK_RBUTTON,
+ msframe->last_click_time);
}
else if (msframe->button2_need_rbutton)
{
msframe->button2_need_rbutton = 0;
mswindows_enqueue_mouse_button_event (hwnd, WM_LBUTTONDOWN,
- msframe->last_click_point, msframe->last_click_time);
+ msframe->last_click_point,
+ msframe->last_click_mods
+ &~ MK_LBUTTON,
+ msframe->last_click_time);
}
}
else
event->event_type = pointer_motion_event;
event->event.motion.x = MAKEPOINTS(lParam).x;
event->event.motion.y = MAKEPOINTS(lParam).y;
- event->event.motion.modifiers = mswindows_modifier_state (NULL, 0);
+ event->event.motion.modifiers =
+ mswindows_modifier_state (NULL, wParam, 0);
mswindows_enqueue_dispatch_event (emacs_event);
}
{
/* I think this is safe since the text will only go away
when the toolbar does...*/
- TO_EXTERNAL_FORMAT (LISP_STRING, btext,
- C_STRING_ALLOCA, tttext->lpszText,
- Qnative);
+ LISP_STRING_TO_EXTERNAL (btext, tttext->lpszText, Qnative);
}
#endif
}
shouldn't have received a paint message for it here. */
assert (wParam == 0);
- /* Can't queue a magic event because windows goes modal and sends paint
+ /* Can't queue a magic event because windows goes modal and sends paint
messages directly to the windows procedure when doing solid drags
and the message queue doesn't get processed. */
mswindows_handle_paint (XFRAME (mswindows_find_frame (hwnd)));
event->channel = mswindows_find_frame(hwnd);
event->timestamp = GetMessageTime();
event->event.misc.button = 1; /* #### Should try harder */
- event->event.misc.modifiers = mswindows_modifier_state (NULL, 0);
+ event->event.misc.modifiers = mswindows_modifier_state (NULL,
+ (DWORD) -1, 0);
event->event.misc.x = point.x;
event->event.misc.y = point.y;
event->event.misc.function = Qdragdrop_drop_dispatch;
if (CoCreateInstance (&CLSID_ShellLink, NULL,
CLSCTX_INPROC_SERVER, &IID_IShellLink, &psl) == S_OK)
- {
+ {
IPersistFile* ppf;
if (psl->lpVtbl->QueryInterface (psl, &IID_IPersistFile,
time when a key typed at autorepeat rate of 30 cps! */
static HKL last_hkl = 0;
static int last_hkl_has_AltGr;
+ HKL current_hkl = (HKL) -1;
- HKL current_hkl = GetKeyboardLayout (0);
+ if (xGetKeyboardLayout) /* not in NT 3.5 */
+ current_hkl = xGetKeyboardLayout (0);
if (current_hkl != last_hkl)
{
TCHAR c;
/* Returns the state of the modifier keys in the format expected by the
* Lisp_Event key_data, button_data and motion_data modifiers member */
static int
-mswindows_modifier_state (BYTE* keymap, int has_AltGr)
+mswindows_modifier_state (BYTE* keymap, DWORD fwKeys, int has_AltGr)
{
int mods = 0;
+ int keys_is_real = 0;
BYTE keymap2[256];
+ if (fwKeys == (DWORD) -1)
+ fwKeys = mswindows_last_mouse_button_state;
+ else
+ {
+ keys_is_real = 1;
+ mswindows_last_mouse_button_state = fwKeys;
+ }
+
if (keymap == NULL)
{
keymap = keymap2;
has_AltGr = mswindows_current_layout_has_AltGr ();
}
+ /* #### should look at fwKeys for MK_CONTROL. I don't understand how
+ AltGr works. */
if (has_AltGr && (keymap [VK_LCONTROL] & 0x80) && (keymap [VK_RMENU] & 0x80))
{
mods |= (keymap [VK_LMENU] & 0x80) ? XEMACS_MOD_META : 0;
mods |= (keymap [VK_CONTROL] & 0x80) ? XEMACS_MOD_CONTROL : 0;
}
- mods |= (keymap [VK_SHIFT] & 0x80) ? XEMACS_MOD_SHIFT : 0;
+ mods |= (keys_is_real ? fwKeys & MK_SHIFT : (keymap [VK_SHIFT] & 0x80))
+ ? XEMACS_MOD_SHIFT : 0;
+ mods |= fwKeys & MK_LBUTTON ? XEMACS_MOD_BUTTON1 : 0;
+ mods |= fwKeys & MK_MBUTTON ? XEMACS_MOD_BUTTON2 : 0;
+ mods |= fwKeys & MK_RBUTTON ? XEMACS_MOD_BUTTON3 : 0;
return mods;
}
* Translate a mswindows virtual key to a keysym.
* Only returns non-Qnil for keys that don't generate WM_CHAR messages
* or whose ASCII codes (like space) xemacs doesn't like.
- * Virtual key values are defined in winresrc.h
*/
Lisp_Object mswindows_key_to_emacs_keysym (int mswindows_key, int mods,
int extendedp)
{
switch (mswindows_key)
{
+ case VK_CANCEL: return KEYSYM ("pause");
case VK_RETURN: return KEYSYM ("kp-enter");
case VK_PRIOR: return KEYSYM ("prior");
case VK_NEXT: return KEYSYM ("next");
case VK_DOWN: return KEYSYM ("down");
case VK_INSERT: return KEYSYM ("insert");
case VK_DELETE: return QKdelete;
+#if 0 /* FSF Emacs allows these to return configurable syms/mods */
+ case VK_LWIN return KEYSYM ("");
+ case VK_RWIN return KEYSYM ("");
+#endif
+ case VK_APPS: return KEYSYM ("menu");
}
}
else
case '\n': return QKlinefeed;
case VK_CLEAR: return KEYSYM ("clear");
case VK_RETURN: return QKreturn;
+ case VK_PAUSE: return KEYSYM ("pause");
case VK_ESCAPE: return QKescape;
case VK_SPACE: return QKspace;
case VK_PRIOR: return KEYSYM ("kp-prior");
case VK_INSERT: return KEYSYM ("kp-insert");
case VK_DELETE: return KEYSYM ("kp-delete");
case VK_HELP: return KEYSYM ("help");
-#if 0 /* FSF Emacs allows these to return configurable syms/mods */
- case VK_LWIN return KEYSYM ("");
- case VK_RWIN return KEYSYM ("");
-#endif
- case VK_APPS: return KEYSYM ("menu");
case VK_NUMPAD0: return KEYSYM ("kp-0");
case VK_NUMPAD1: return KEYSYM ("kp-1");
case VK_NUMPAD2: return KEYSYM ("kp-2");
{
emacs_event = mswindows_cancel_dispatch_event (&match_against);
assert (!NILP (emacs_event));
-
+
if (XEVENT(emacs_event)->event.key.modifiers & XEMACS_MOD_SHIFT)
critical_p = 1;
: HANDLE_TO_USID (get_ntpipe_input_stream_waitable (XLSTREAM (instream))));
}
+static int
+emacs_mswindows_current_event_timestamp (struct console *c)
+{
+ return GetTickCount ();
+}
+
#ifndef HAVE_X_WINDOWS
/* This is called from GC when a process object is about to be freed.
If we've still got pointers to it in this file, we're gonna lose hard.
mswindows_event_stream->create_stream_pair_cb = emacs_mswindows_create_stream_pair;
mswindows_event_stream->delete_stream_pair_cb = emacs_mswindows_delete_stream_pair;
#endif
+ mswindows_event_stream->current_event_timestamp_cb =
+ emacs_mswindows_current_event_timestamp;
}
void
#ifdef DEBUG_XEMACS
- DEFVAR_INT ("mswindows-debug-events", &mswindows_debug_events /*
+ DEFVAR_INT ("debug-mswindows-events", &debug_mswindows_events /*
If non-zero, display debug information about Windows events that XEmacs sees.
Information is displayed in a console window. Currently defined values are:
#### Unfortunately, not yet implemented.
*/ );
- mswindows_debug_events = 0;
+ debug_mswindows_events = 0;
#endif
DEFVAR_BOOL ("mswindows-alt-by-itself-activates-menu",
event_stream->quit_p_cb ();
}
+static int
+event_stream_current_event_timestamp (struct console *c)
+{
+ if (event_stream && event_stream->current_event_timestamp_cb)
+ return event_stream->current_event_timestamp_cb (c);
+ else
+ return 0;
+}
\f
/**********************************************************************/
XEVENT (event)->event.key.keysym = traduit;
did_translate = 1;
}
+ else if (CHARP (traduit))
+ {
+ Lisp_Event ev2;
+
+ zero_event (&ev2);
+ character_to_event (XCHAR (traduit), &ev2,
+ XCONSOLE (EVENT_CHANNEL (XEVENT (event))), 1, 1);
+ XEVENT (event)->event.key.keysym = ev2.event.key.keysym;
+ XEVENT (event)->event.key.modifiers |= ev2.event.key.modifiers;
+ did_translate = 1;
+ }
}
#ifdef DEBUG_XEMACS
-- any events in `unread-command-events' or `unread-command-event'; else
-- the next event in the currently executing keyboard macro, if any; else
--- an event queued by `enqueue-eval-event', if any; else
+-- an event queued by `enqueue-eval-event', if any, or any similar event
+ queued internally, such as a misc-user event. (For example, when an item
+ is selected from a menu or from a `question'-type dialog box, the item's
+ callback is not immediately executed, but instead a misc-user event
+ is generated and placed onto this queue; when it is dispatched, the
+ callback is executed.) Else
-- the next available event from the window system or terminal driver.
In the last case, this function will block until an event is available.
widgets. Normally these are redisplayed through a native window-system
event encoded as magic event, rather than by the redisplay code. This
function does not call redisplay or do any of the other things that
-`next-event' does.
+`next-event' does.
*/
())
{
return result;
}
-/* This handy little function is used by xselect.c and energize.c to
- wait for replies from processes that aren't really processes (that is,
- the X server and the Energize server).
- */
+/* This handy little function is used by select-x.c to wait for replies
+ from processes that aren't really processes (e.g. the X server) */
void
wait_delaying_user_input (int (*predicate) (void *arg), void *predicate_arg)
{
}
\f
+
+DEFUN ("current-event-timestamp", Fcurrent_event_timestamp, 0, 1, 0, /*
+Return the current event timestamp of the window system associated with CONSOLE.
+CONSOLE defaults to the selected console if omitted.
+*/
+ (console))
+{
+ struct console *c = decode_console (console);
+ int tiempo = event_stream_current_event_timestamp (c);
+
+ /* This junk is so that timestamps don't get to be negative, but contain
+ as many bits as this particular emacs will allow.
+ */
+ return make_int (((1L << (VALBITS - 1)) - 1) & tiempo);
+}
+
+\f
/************************************************************************/
/* initialization */
/************************************************************************/
defsymbol (&Qdisabled, "disabled");
defsymbol (&Qcommand_event_p, "command-event-p");
- deferror (&Qundefined_keystroke_sequence, "undefined-keystroke-sequence",
- "Undefined keystroke sequence", Qerror);
+ DEFERROR_STANDARD (Qundefined_keystroke_sequence, Qinvalid_argument);
DEFSUBR (Frecent_keys);
DEFSUBR (Frecent_keys_ring_size);
DEFSUBR (Fthis_command_keys);
DEFSUBR (Freset_this_command_lengths);
DEFSUBR (Fopen_dribble_file);
+ DEFSUBR (Fcurrent_event_timestamp);
defsymbol (&Qpre_command_hook, "pre-command-hook");
defsymbol (&Qpost_command_hook, "post-command-hook");
This occurs whenever it is going to block, waiting for an event.
This generally happens as a result of a call to `next-event',
`next-command-event', `sit-for', `sleep-for', `accept-process-output',
-`x-get-selection', or various Energize-specific commands.
+or `x-get-selection'.
Errors running the hook are caught and ignored.
*/ );
Vpre_idle_hook = Qnil;
keysym changed and its modifiers left alone. This is useful for
dealing with non-standard X keyboards, such as the grievous damage
that Sun has inflicted upon the world.
+-- If an entry maps a symbol to a character, then a key-press event
+ whose keysym is the former symbol (with any modifiers at all) gets
+ changed into a key-press event matching the latter character, and the
+ resulting modifiers are the union of the original and new modifiers.
-- If an entry maps a character to a character, then a key-press event
matching the former character gets converted to a key-press event
matching the latter character. This is useful on ASCII terminals
-- If an entry maps a character to a symbol, then a key-press event
matching the character gets converted to a key-press event whose
keysym is the given symbol and which has no modifiers.
+
+Here's an example: This makes typing parens and braces easier by rerouting
+their positions to eliminate the need to use the Shift key.
+
+ (keyboard-translate ?[ ?()
+ (keyboard-translate ?] ?))
+ (keyboard-translate ?{ ?[)
+ (keyboard-translate ?} ?])
+ (keyboard-translate 'f11 ?{)
+ (keyboard-translate 'f12 ?})
*/ );
DEFVAR_LISP ("retry-undefined-key-binding-unshifted",
#define XEMACS_MOD_HYPER (1<<3)
#define XEMACS_MOD_ALT (1<<4)
#define XEMACS_MOD_SHIFT (1<<5) /* not used for dual-case characters */
+#define XEMACS_MOD_BUTTON1 (1<<6)
+#define XEMACS_MOD_BUTTON2 (1<<7)
+#define XEMACS_MOD_BUTTON3 (1<<8)
+#define XEMACS_MOD_BUTTON4 (1<<9)
+#define XEMACS_MOD_BUTTON5 (1<<10)
*/
(type, plist))
{
- Lisp_Object tail, keyword, value;
Lisp_Object event = Qnil;
Lisp_Event *e;
EMACS_INT coord_x = 0, coord_y = 0;
(e.g. CHANNEL), which we don't want in empty events. */
e->event_type = empty_event;
if (!NILP (plist))
- error ("Cannot set properties of empty event");
+ syntax_error ("Cannot set properties of empty event", plist);
UNGCPRO;
return event;
}
else
{
/* Not allowed: Qprocess, Qtimeout, Qmagic, Qeval, Qmagic_eval. */
- signal_simple_error ("Invalid event type", type);
+ invalid_argument ("Invalid event type", type);
}
EVENT_CHANNEL (e) = Qnil;
plist = Fcopy_sequence (plist);
Fcanonicalize_plist (plist, Qnil);
-#define WRONG_EVENT_TYPE_FOR_PROPERTY(type, prop) \
- error_with_frob (prop, "Invalid property for %s event", \
- string_data (symbol_name (XSYMBOL (type))))
+#define WRONG_EVENT_TYPE_FOR_PROPERTY(event_type, prop) \
+ syntax_error_2 ("Invalid property for event type", prop, event_type)
- EXTERNAL_PROPERTY_LIST_LOOP (tail, keyword, value, plist)
- {
- if (EQ (keyword, Qchannel))
- {
- if (e->event_type == key_press_event)
- {
- if (!CONSOLEP (value))
- value = wrong_type_argument (Qconsolep, value);
- }
- else
- {
- if (!FRAMEP (value))
- value = wrong_type_argument (Qframep, value);
- }
- EVENT_CHANNEL (e) = value;
- }
- else if (EQ (keyword, Qkey))
- {
- switch (e->event_type)
- {
- case key_press_event:
- if (!SYMBOLP (value) && !CHARP (value))
- signal_simple_error ("Invalid event key", value);
- e->event.key.keysym = value;
- break;
- default:
- WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
- break;
- }
- }
- else if (EQ (keyword, Qbutton))
- {
- CHECK_NATNUM (value);
- check_int_range (XINT (value), 0, 7);
-
- switch (e->event_type)
- {
- case button_press_event:
- case button_release_event:
- e->event.button.button = XINT (value);
- break;
- case misc_user_event:
- e->event.misc.button = XINT (value);
- break;
- default:
- WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
- break;
- }
- }
- else if (EQ (keyword, Qmodifiers))
- {
- int modifiers = 0;
- Lisp_Object sym;
-
- EXTERNAL_LIST_LOOP_2 (sym, value)
- {
- if (EQ (sym, Qcontrol)) modifiers |= XEMACS_MOD_CONTROL;
- else if (EQ (sym, Qmeta)) modifiers |= XEMACS_MOD_META;
- else if (EQ (sym, Qsuper)) modifiers |= XEMACS_MOD_SUPER;
- else if (EQ (sym, Qhyper)) modifiers |= XEMACS_MOD_HYPER;
- else if (EQ (sym, Qalt)) modifiers |= XEMACS_MOD_ALT;
- else if (EQ (sym, Qsymbol)) modifiers |= XEMACS_MOD_ALT;
- else if (EQ (sym, Qshift)) modifiers |= XEMACS_MOD_SHIFT;
- else
- signal_simple_error ("Invalid key modifier", sym);
- }
-
- switch (e->event_type)
- {
- case key_press_event:
- e->event.key.modifiers = modifiers;
- break;
- case button_press_event:
- case button_release_event:
- e->event.button.modifiers = modifiers;
- break;
- case pointer_motion_event:
- e->event.motion.modifiers = modifiers;
- break;
- case misc_user_event:
- e->event.misc.modifiers = modifiers;
- break;
- default:
- WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
- break;
- }
- }
- else if (EQ (keyword, Qx))
- {
- switch (e->event_type)
- {
- case pointer_motion_event:
- case button_press_event:
- case button_release_event:
- case misc_user_event:
- /* Allow negative values, so we can specify toolbar
- positions. */
- CHECK_INT (value);
- coord_x = XINT (value);
- break;
- default:
- WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
- break;
- }
- }
- else if (EQ (keyword, Qy))
- {
- switch (e->event_type)
- {
- case pointer_motion_event:
- case button_press_event:
- case button_release_event:
- case misc_user_event:
- /* Allow negative values; see above. */
- CHECK_INT (value);
- coord_y = XINT (value);
- break;
- default:
- WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
- break;
- }
- }
- else if (EQ (keyword, Qtimestamp))
- {
- CHECK_NATNUM (value);
- e->timestamp = XINT (value);
- }
- else if (EQ (keyword, Qfunction))
- {
- switch (e->event_type)
- {
- case misc_user_event:
- e->event.eval.function = value;
- break;
- default:
- WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
- break;
- }
- }
- else if (EQ (keyword, Qobject))
- {
- switch (e->event_type)
- {
- case misc_user_event:
- e->event.eval.object = value;
- break;
- default:
- WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
- break;
- }
- }
- else
- signal_simple_error_2 ("Invalid property", keyword, value);
- }
+ {
+ EXTERNAL_PROPERTY_LIST_LOOP_3 (keyword, value, plist)
+ {
+ if (EQ (keyword, Qchannel))
+ {
+ if (e->event_type == key_press_event)
+ {
+ if (!CONSOLEP (value))
+ value = wrong_type_argument (Qconsolep, value);
+ }
+ else
+ {
+ if (!FRAMEP (value))
+ value = wrong_type_argument (Qframep, value);
+ }
+ EVENT_CHANNEL (e) = value;
+ }
+ else if (EQ (keyword, Qkey))
+ {
+ switch (e->event_type)
+ {
+ case key_press_event:
+ if (!SYMBOLP (value) && !CHARP (value))
+ syntax_error ("Invalid event key", value);
+ e->event.key.keysym = value;
+ break;
+ default:
+ WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
+ break;
+ }
+ }
+ else if (EQ (keyword, Qbutton))
+ {
+ CHECK_NATNUM (value);
+ check_int_range (XINT (value), 0, 7);
+
+ switch (e->event_type)
+ {
+ case button_press_event:
+ case button_release_event:
+ e->event.button.button = XINT (value);
+ break;
+ case misc_user_event:
+ e->event.misc.button = XINT (value);
+ break;
+ default:
+ WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
+ break;
+ }
+ }
+ else if (EQ (keyword, Qmodifiers))
+ {
+ int modifiers = 0;
+
+ EXTERNAL_LIST_LOOP_2 (sym, value)
+ {
+ if (EQ (sym, Qcontrol)) modifiers |= XEMACS_MOD_CONTROL;
+ else if (EQ (sym, Qmeta)) modifiers |= XEMACS_MOD_META;
+ else if (EQ (sym, Qsuper)) modifiers |= XEMACS_MOD_SUPER;
+ else if (EQ (sym, Qhyper)) modifiers |= XEMACS_MOD_HYPER;
+ else if (EQ (sym, Qalt)) modifiers |= XEMACS_MOD_ALT;
+ else if (EQ (sym, Qsymbol)) modifiers |= XEMACS_MOD_ALT;
+ else if (EQ (sym, Qshift)) modifiers |= XEMACS_MOD_SHIFT;
+ else if (EQ (sym, Qbutton1)) modifiers |= XEMACS_MOD_BUTTON1;
+ else if (EQ (sym, Qbutton2)) modifiers |= XEMACS_MOD_BUTTON2;
+ else if (EQ (sym, Qbutton3)) modifiers |= XEMACS_MOD_BUTTON3;
+ else if (EQ (sym, Qbutton4)) modifiers |= XEMACS_MOD_BUTTON4;
+ else if (EQ (sym, Qbutton5)) modifiers |= XEMACS_MOD_BUTTON5;
+ else
+ syntax_error ("Invalid key modifier", sym);
+ }
+
+ switch (e->event_type)
+ {
+ case key_press_event:
+ e->event.key.modifiers = modifiers;
+ break;
+ case button_press_event:
+ case button_release_event:
+ e->event.button.modifiers = modifiers;
+ break;
+ case pointer_motion_event:
+ e->event.motion.modifiers = modifiers;
+ break;
+ case misc_user_event:
+ e->event.misc.modifiers = modifiers;
+ break;
+ default:
+ WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
+ break;
+ }
+ }
+ else if (EQ (keyword, Qx))
+ {
+ switch (e->event_type)
+ {
+ case pointer_motion_event:
+ case button_press_event:
+ case button_release_event:
+ case misc_user_event:
+ /* Allow negative values, so we can specify toolbar
+ positions. */
+ CHECK_INT (value);
+ coord_x = XINT (value);
+ break;
+ default:
+ WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
+ break;
+ }
+ }
+ else if (EQ (keyword, Qy))
+ {
+ switch (e->event_type)
+ {
+ case pointer_motion_event:
+ case button_press_event:
+ case button_release_event:
+ case misc_user_event:
+ /* Allow negative values; see above. */
+ CHECK_INT (value);
+ coord_y = XINT (value);
+ break;
+ default:
+ WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
+ break;
+ }
+ }
+ else if (EQ (keyword, Qtimestamp))
+ {
+ CHECK_NATNUM (value);
+ e->timestamp = XINT (value);
+ }
+ else if (EQ (keyword, Qfunction))
+ {
+ switch (e->event_type)
+ {
+ case misc_user_event:
+ e->event.eval.function = value;
+ break;
+ default:
+ WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
+ break;
+ }
+ }
+ else if (EQ (keyword, Qobject))
+ {
+ switch (e->event_type)
+ {
+ case misc_user_event:
+ e->event.eval.object = value;
+ break;
+ default:
+ WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
+ break;
+ }
+ }
+ else
+ syntax_error_2 ("Invalid property", keyword, value);
+ }
+ }
/* Insert the channel, if missing. */
if (NILP (EVENT_CHANNEL (e)))
{
case key_press_event:
if (UNBOUNDP (e->event.key.keysym))
- error ("A key must be specified to make a keypress event");
+ syntax_error ("A key must be specified to make a keypress event",
+ plist);
break;
case button_press_event:
if (!e->event.button.button)
- error ("A button must be specified to make a button-press event");
+ syntax_error
+ ("A button must be specified to make a button-press event",
+ plist);
break;
case button_release_event:
if (!e->event.button.button)
- error ("A button must be specified to make a button-release event");
+ syntax_error
+ ("A button must be specified to make a button-release event",
+ plist);
break;
case misc_user_event:
if (NILP (e->event.misc.function))
- error ("A function must be specified to make a misc-user event");
+ syntax_error ("A function must be specified to make a misc-user event",
+ plist);
break;
default:
break;
case dead_event: strcpy (buf, "DEAD-EVENT"); return;
default:
abort ();
+ return;
}
#define modprint1(x) do { strcpy (buf, (x)); buf += sizeof (x)-1; } while (0)
#define modprint(x,y) do { if (brief) modprint1 (y); else modprint1 (x); } while (0)
DEFUN ("event-timestamp", Fevent_timestamp, 1, 1, 0, /*
Return the timestamp of the event object EVENT.
+Timestamps are measured in milliseconds since the start of the window system.
+They are NOT related to any current time measurement.
+They should be compared with `event-timestamp<'.
+See also `current-event-timestamp'.
*/
(event))
{
XEVENT (event)->timestamp);
}
+#define TIMESTAMP_HALFSPACE (1L << (VALBITS - 2))
+
+DEFUN ("event-timestamp<", Fevent_timestamp_lessp, 2, 2, 0, /*
+Return true if timestamp TIME1 is earlier than timestamp TIME2.
+This correctly handles timestamp wrap.
+See also `event-timestamp' and `current-event-timestamp'.
+*/
+ (time1, time2))
+{
+ EMACS_INT t1, t2;
+
+ CHECK_NATNUM (time1);
+ CHECK_NATNUM (time2);
+ t1 = XINT (time1);
+ t2 = XINT (time2);
+
+ if (t1 < t2)
+ return t2 - t1 < TIMESTAMP_HALFSPACE ? Qt : Qnil;
+ else
+ return t1 - t2 < TIMESTAMP_HALFSPACE ? Qnil : Qt;
+}
+
#define CHECK_EVENT_TYPE(e,t1,sym) do { \
CHECK_LIVE_EVENT (e); \
if (XEVENT(e)->event_type != (t1)) \
}
DEFUN ("event-modifier-bits", Fevent_modifier_bits, 1, 1, 0, /*
-Return a number representing the modifier keys which were down
+Return a number representing the modifier keys and buttons which were down
when the given mouse or keyboard event was produced.
-See also the function event-modifiers.
+See also the function `event-modifiers'.
*/
(event))
{
}
DEFUN ("event-modifiers", Fevent_modifiers, 1, 1, 0, /*
-Return a list of symbols, the names of the modifier keys
+Return a list of symbols, the names of the modifier keys and buttons
which were down when the given mouse or keyboard event was produced.
-See also the function event-modifier-bits.
+See also the function `event-modifier-bits'.
+
+The possible symbols in the list are
+
+`shift': The Shift key. Will not appear, in general, on key events
+ where the keysym is an ASCII character, because using Shift
+ on such a character converts it into another character rather
+ than actually just adding a Shift modifier.
+
+`control': The Control key.
+
+`meta': The Meta key. On PC's and PC-style keyboards, this is generally
+ labelled \"Alt\"; Meta is a holdover from early Lisp Machines and
+ such, propagated through the X Window System. On Sun keyboards,
+ this key is labelled with a diamond.
+
+`alt': The \"Alt\" key. Alt is in quotes because this does not refer
+ to what it obviously should refer to, namely the Alt key on PC
+ keyboards. Instead, it refers to the key labelled Alt on Sun
+ keyboards, and to no key at all on PC keyboards.
+
+`super': The Super key. Most keyboards don't have any such key, but
+ under X Windows using `xmodmap' you can assign any key (such as
+ an underused right-shift, right-control, or right-alt key) to
+ this key modifier. No support currently exists under MS Windows
+ for generating these modifiers.
+
+`hyper': The Hyper key. Works just like the Super key.
+
+`button1': The mouse buttons. This means that the specified button was held
+`button2': down at the time the event occurred. NOTE: For button-press
+`button3': events, the button that was just pressed down does NOT appear in
+`button4': the modifiers.
+`button5':
+
+Button modifiers are currently ignored when defining and looking up key and
+mouse strokes in keymaps. This could be changed, which would allow a user to
+create button-chord actions, use a button as a key modifier and do other
+clever things.
*/
(event))
{
int mod = XINT (Fevent_modifier_bits (event));
Lisp_Object result = Qnil;
+ struct gcpro gcpro1;
+
+ GCPRO1 (result);
if (mod & XEMACS_MOD_SHIFT) result = Fcons (Qshift, result);
if (mod & XEMACS_MOD_ALT) result = Fcons (Qalt, result);
if (mod & XEMACS_MOD_HYPER) result = Fcons (Qhyper, result);
if (mod & XEMACS_MOD_SUPER) result = Fcons (Qsuper, result);
if (mod & XEMACS_MOD_META) result = Fcons (Qmeta, result);
if (mod & XEMACS_MOD_CONTROL) result = Fcons (Qcontrol, result);
- return result;
+ if (mod & XEMACS_MOD_BUTTON1) result = Fcons (Qbutton1, result);
+ if (mod & XEMACS_MOD_BUTTON2) result = Fcons (Qbutton2, result);
+ if (mod & XEMACS_MOD_BUTTON3) result = Fcons (Qbutton3, result);
+ if (mod & XEMACS_MOD_BUTTON4) result = Fcons (Qbutton4, result);
+ if (mod & XEMACS_MOD_BUTTON5) result = Fcons (Qbutton5, result);
+ RETURN_UNGCPRO (Fnreverse (result));
}
static int
w = find_window_by_pixel_pos (*x, *y, f->root_window);
if (!w)
- return 1; /* #### What should really happen here. */
+ return 1; /* #### What should really happen here? */
*x -= w->pixel_left;
*y -= w->pixel_top;
DEFSUBR (Fevent_properties);
DEFSUBR (Fevent_timestamp);
+ DEFSUBR (Fevent_timestamp_lessp);
DEFSUBR (Fevent_key);
DEFSUBR (Fevent_button);
DEFSUBR (Fevent_modifier_bits);
event_stream layer to translate to this format.
NOTE: #### All timestamps should be measured as milliseconds since XEmacs
- started. Currently many or most events have a 0 as their
- timestamp value, and for other timestamps, they are raw server
- timestamps. (The X protocol doesn't provide any easy way of
- translating between server time and real process time; yuck.)
+ started. Currently they are raw server timestamps. (The X protocol
+ doesn't provide any easy way of translating between server time and
+ real process time; yuck.)
Every event type has the following structures:
If this is an integer, it will be in the printing
ASCII range: >32 and <127.
modifiers Bucky-bits on that key: control, meta, etc.
+ Also includes buttons.
For many keys, Shift is not a bit; that is implicit
in the keyboard layout.
button_release_event
button What button went down or up.
modifiers Bucky-bits on that button: shift, control, meta, etc.
+ Also includes other buttons (not the one pressed).
x, y Where it was at the button-state-change (in pixels).
pointer_motion_event
x, y Where it was after it moved (in pixels).
modifiers Bucky-bits down when the motion was detected.
- (Possibly not all window systems will provide this?)
process_event
process the XEmacs "process" object in question
int /* flags */);
USID (*delete_stream_pair_cb) (Lisp_Object /* instream */,
Lisp_Object /* outstream */);
+ int (*current_event_timestamp_cb) (struct console *);
};
/* Flags for create_stream_pair_cb() FLAGS parameter */
/* Copyright (c) 1994, 1995 Free Software Foundation, Inc.
Copyright (c) 1995 Sun Microsystems, Inc.
- Copyright (c) 1995, 1996 Ben Wing.
+ Copyright (c) 1995, 1996, 2000 Ben Wing.
This file is part of XEmacs.
else if (STRINGP (object))
{
/* #### Changes to string extents can affect redisplay if they are
- in the modeline or in the gutters.
-
+ in the modeline or in the gutters.
+
If the extent is in some generated-modeline-string: when we
change an extent in generated-modeline-string, this changes its
parent, which is in `modeline-format', so we should force the
is not very efficient. Should we add all
`generated-modeline-string' strings to a hash table? Maybe
efficiency is not the greatest concern here and there's no big
- loss in looping over the buffers.
+ loss in looping over the buffers.
If the extent is in a gutter we mark the gutter as
changed. This means (a) we can update extents in the gutters
case ME_ALL_EXTENTS_OPEN: start_open = 1, end_open = 1; break;
case ME_ALL_EXTENTS_CLOSED_OPEN: start_open = 0, end_open = 1; break;
case ME_ALL_EXTENTS_OPEN_CLOSED: start_open = 1, end_open = 0; break;
- default: abort(); break;
+ default: abort(); return 0;
}
start = buffer_or_string_bytind_to_startind (obj, from,
retval = (start <= exs && exs <= end) || (start <= exe && exe <= end);
break;
default:
- abort(); break;
+ abort(); return 0;
}
return flags & ME_NEGATE_IN_REGION ? !retval : retval;
}
if ((NILP (obj) && (flags & DE_MUST_HAVE_BUFFER))
|| (extent_detached_p (extent) && (flags & DE_MUST_BE_ATTACHED)))
{
- signal_simple_error ("extent doesn't belong to a buffer or string",
- extent_obj);
+ invalid_argument ("extent doesn't belong to a buffer or string",
+ extent_obj);
}
return extent;
return Qnil;
for (rest = parent; !NILP (rest); rest = extent_parent (XEXTENT (rest)))
if (EQ (rest, extent))
- signal_simple_error ("Circular parent chain would result", extent);
+ signal_type_error (Qinvalid_change,
+ "Circular parent chain would result",
+ extent);
if (NILP (parent))
{
remove_extent_from_children_list (XEXTENT (cur_parent), extent);
EQ (sym, Qstart_and_end_in_region) ? ME_START_AND_END_IN_REGION :
EQ (sym, Qstart_or_end_in_region) ? ME_START_OR_END_IN_REGION :
EQ (sym, Qnegate_in_region) ? ME_NEGATE_IN_REGION :
- (signal_simple_error ("Invalid `map-extents' flag", sym), 0);
+ (invalid_argument ("Invalid `map-extents' flag", sym), 0);
flags = XCDR (flags);
}
struct extent_at_arg
{
- EXTENT best_match;
+ Lisp_Object best_match; /* or list of extents */
Memind best_start;
Memind best_end;
Lisp_Object prop;
EXTENT before;
+ int all_extents;
};
enum extent_at_flag
if (EQ (at_flag, Qbefore)) return EXTENT_AT_BEFORE;
if (EQ (at_flag, Qat)) return EXTENT_AT_AT;
- signal_simple_error ("Invalid AT-FLAG in `extent-at'", at_flag);
+ invalid_argument ("Invalid AT-FLAG in `extent-at'", at_flag);
return EXTENT_AT_AFTER; /* unreached */
}
return 0;
}
+ if (!closure->all_extents)
{
- EXTENT current = closure->best_match;
+ EXTENT current;
- if (!current)
+ if (NILP (closure->best_match))
goto accept;
+ current = XEXTENT (closure->best_match);
/* redundant but quick test */
- else if (extent_start (current) > extent_start (e))
+ if (extent_start (current) > extent_start (e))
return 0;
/* we return the "last" best fit, instead of the first --
else
return 0;
accept:
- closure->best_match = e;
+ XSETEXTENT (closure->best_match, e);
closure->best_start = extent_start (e);
closure->best_end = extent_end (e);
}
+ else
+ {
+ Lisp_Object extent;
+
+ XSETEXTENT (extent, e);
+ closure->best_match = Fcons (extent, closure->best_match);
+ }
return 0;
}
static Lisp_Object
extent_at_bytind (Bytind position, Lisp_Object object, Lisp_Object property,
- EXTENT before, enum extent_at_flag at_flag)
+ EXTENT before, enum extent_at_flag at_flag, int all_extents)
{
struct extent_at_arg closure;
- Lisp_Object extent_obj;
+ struct gcpro gcpro1;
/* it might be argued that invalid positions should cause
errors, but the principle of least surprise dictates that
: position > buffer_or_string_absolute_end_byte (object)))
return Qnil;
- closure.best_match = 0;
+ closure.best_match = Qnil;
closure.prop = property;
closure.before = before;
+ closure.all_extents = all_extents;
+ GCPRO1 (closure.best_match);
map_extents_bytind (at_flag == EXTENT_AT_BEFORE ? position - 1 : position,
at_flag == EXTENT_AT_AFTER ? position + 1 : position,
extent_at_mapper, (void *) &closure, object, 0,
ME_START_OPEN | ME_ALL_EXTENTS_CLOSED);
+ if (all_extents)
+ closure.best_match = Fnreverse (closure.best_match);
+ UNGCPRO;
- if (!closure.best_match)
- return Qnil;
-
- XSETEXTENT (extent_obj, closure.best_match);
- return extent_obj;
+ return closure.best_match;
}
DEFUN ("extent-at", Fextent_at, 1, 5, 0, /*
else
before_extent = decode_extent (before, DE_MUST_BE_ATTACHED);
if (before_extent && !EQ (object, extent_object (before_extent)))
- signal_simple_error ("extent not in specified buffer or string", object);
+ invalid_argument ("extent not in specified buffer or string", object);
+ fl = decode_extent_at_flag (at_flag);
+
+ return extent_at_bytind (position, object, property, before_extent, fl, 0);
+}
+
+DEFUN ("extents-at", Fextents_at, 1, 5, 0, /*
+Find all extents at POS in OBJECT having PROPERTY set.
+Normally, an extent is "at" POS if it overlaps the region (POS, POS+1);
+ i.e. if it covers the character after POS. (However, see the definition
+ of AT-FLAG.)
+This provides similar functionality to `extent-list', but does so in a way
+ that is compatible with `extent-at'. (For example, errors due to POS out of
+ range are ignored; this makes it safer to use this function in response to
+ a mouse event, because in many cases previous events have changed the buffer
+ contents.)
+OBJECT specifies a buffer or string and defaults to the current buffer.
+PROPERTY defaults to nil, meaning that any extent will do.
+Properties are attached to extents with `set-extent-property', which see.
+Returns nil if POS is invalid or there is no matching extent at POS.
+If the fourth argument BEFORE is not nil, it must be an extent; any returned
+ extent will precede that extent. This feature allows `extents-at' to be
+ used by a loop over extents.
+AT-FLAG controls how end cases are handled, and should be one of:
+
+nil or `after' An extent is at POS if it covers the character
+ after POS. This is consistent with the way
+ that text properties work.
+`before' An extent is at POS if it covers the character
+ before POS.
+`at' An extent is at POS if it overlaps or abuts POS.
+ This includes all zero-length extents at POS.
+
+Note that in all cases, the start-openness and end-openness of the extents
+considered is ignored. If you want to pay attention to those properties,
+you should use `map-extents', which gives you more control.
+*/
+ (pos, object, property, before, at_flag))
+{
+ Bytind position;
+ EXTENT before_extent;
+ enum extent_at_flag fl;
+
+ object = decode_buffer_or_string (object);
+ position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD);
+ if (NILP (before))
+ before_extent = 0;
+ else
+ before_extent = decode_extent (before, DE_MUST_BE_ATTACHED);
+ if (before_extent && !EQ (object, extent_object (before_extent)))
+ invalid_argument ("extent not in specified buffer or string", object);
fl = decode_extent_at_flag (at_flag);
- return extent_at_bytind (position, object, property, before_extent, fl);
+ return extent_at_bytind (position, object, property, before_extent, fl, 1);
}
/* ------------------------------- */
if (EQ (layout_obj, Qwhitespace)) return GL_WHITESPACE;
if (EQ (layout_obj, Qtext)) return GL_TEXT;
- signal_simple_error ("Unknown glyph layout type", layout_obj);
+ invalid_argument ("Unknown glyph layout type", layout_obj);
return GL_TEXT; /* unreached */
}
/* text_props_only specifies whether we only consider text-property
extents (those with the 'text-prop property set) or all extents. */
if (!text_props_only)
- extent = extent_at_bytind (position, object, prop, 0, fl);
+ extent = extent_at_bytind (position, object, prop, 0, fl, 0);
else
{
EXTENT prior = 0;
while (1)
{
extent = extent_at_bytind (position, object, Qtext_prop, prior,
- fl);
+ fl, 0);
if (NILP (extent))
return Qnil;
if (EQ (prop, Fextent_property (extent, Qtext_prop, Qnil)))
prop = Fextent_property (extent, Qtext_prop, Qnil);
if (NILP (prop))
- signal_simple_error ("Internal error: no text-prop", extent);
+ signal_type_error (Qinternal_error,
+ "Internal error: no text-prop", extent);
val = Fextent_property (extent, prop, Qnil);
#if 0
/* removed by bill perry, 2/9/97
** with a value of Qnil. This is bad bad bad.
*/
if (NILP (val))
- signal_simple_error_2 ("Internal error: no text-prop",
- extent, prop);
+ signal_type_error_2 (Qinternal_error,
+ "Internal error: no text-prop",
+ extent, prop);
#endif
Fput_text_property (from, to, prop, val, Qnil);
return Qnil; /* important! */
DEFSUBR (Fmap_extents);
DEFSUBR (Fmap_extent_children);
DEFSUBR (Fextent_at);
+ DEFSUBR (Fextents_at);
DEFSUBR (Fset_extent_initial_redisplay_function);
DEFSUBR (Fextent_face);
*/
(file))
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can GC. GC checked 2000-07-28 ben */
Bufbyte *beg;
Bufbyte *p;
Lisp_Object handler;
*/
(file))
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can GC. GC checked 2000-07-28 ben */
Bufbyte *beg, *p, *end;
Lisp_Object handler;
*/
(filename))
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can GC. GC checked 2000-07-28 ben */
Lisp_Object handler;
/* If the file name has special constructs in it,
static char *
file_name_as_directory (char *out, char *in)
{
+ /* This function cannot GC */
int size = strlen (in);
if (size == 0)
*/
(file))
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can GC. GC checked 2000-07-28 ben */
char *buf;
Lisp_Object handler;
static int
directory_file_name (const char *src, char *dst)
{
+ /* This function cannot GC */
long slen = strlen (src);
/* Process as Unix format: just remove any final slash.
But leave "/" unchanged; do not change it to "". */
*/
(directory))
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can GC. GC checked 2000-07-28 ben */
char *buf;
Lisp_Object handler;
QUIT;
- if (stat ((const char *) data, &ignored) < 0)
+ if (xemacs_stat ((const char *) data, &ignored) < 0)
{
/* We want to return only if errno is ENOENT. */
if (errno == ENOENT)
*/
(name, default_directory))
{
- /* This function can GC */
+ /* This function can GC. GC-checked 2000-07-11 ben */
Bufbyte *nm;
Bufbyte *newdir, *p, *o;
#ifdef CYGWIN
char *user;
#endif
+ struct gcpro gcpro1, gcpro2;
+
+ /* both of these get set below */
+ GCPRO2 (name, default_directory);
CHECK_STRING (name);
call the corresponding file handler. */
handler = Ffind_file_name_handler (name, Qexpand_file_name);
if (!NILP (handler))
- return call3_check_string (handler, Qexpand_file_name, name,
- default_directory);
+ {
+ UNGCPRO;
+ return call3_check_string (handler, Qexpand_file_name, name,
+ default_directory);
+ }
/* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
if (NILP (default_directory))
{
handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
if (!NILP (handler))
- return call3 (handler, Qexpand_file_name, name, default_directory);
+ {
+ UNGCPRO;
+ return call3 (handler, Qexpand_file_name, name, default_directory);
+ }
}
o = XSTRING_DATA (default_directory);
&& ! (IS_DIRECTORY_SEP (o[0]))
#endif /* not WIN32_NATIVE */
)
- {
- struct gcpro gcpro1;
- GCPRO1 (name);
- default_directory = Fexpand_file_name (default_directory, Qnil);
- UNGCPRO;
- }
+ default_directory = Fexpand_file_name (default_directory, Qnil);
#ifdef FILE_SYSTEM_CASE
name = FILE_SYSTEM_CASE (name);
XSTRING_DATA (name)[0] = DRIVE_LETTER (drive);
XSTRING_DATA (name)[1] = ':';
}
- return name;
+ RETURN_UNGCPRO (name);
#else /* not WIN32_NATIVE */
if (nm == XSTRING_DATA (name))
- return name;
- return build_string ((char *) nm);
+ RETURN_UNGCPRO (name);
+ RETURN_UNGCPRO (build_string ((char *) nm));
#endif /* not WIN32_NATIVE */
}
}
CORRECT_DIR_SEPS (target);
#endif /* WIN32_NATIVE */
- return make_string (target, o - target);
+ RETURN_UNGCPRO (make_string (target, o - target));
}
DEFUN ("file-truename", Ffile_truename, 1, 2, 0, /*
*/
(filename, default_))
{
- /* This function can GC. */
+ /* This function can GC. GC checked 2000-07-28 ben. */
Lisp_Object expanded_name;
struct gcpro gcpro1;
expanded_name = Fexpand_file_name (filename, default_);
- GCPRO1 (expanded_name);
-
if (!STRINGP (expanded_name))
return Qnil;
+ GCPRO1 (expanded_name);
+
{
Lisp_Object handler =
Ffind_file_name_handler (expanded_name, Qfile_truename);
*/
(string))
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can GC. GC checked 2000-07-28 ben. */
Bufbyte *nm;
Bufbyte *s, *p, *o, *x, *endp;
return make_string (xnm, x - xnm);
badsubst:
- error ("Bad format environment-variable substitution");
+ syntax_error ("Bad format environment-variable substitution", string);
missingclose:
- error ("Missing \"}\" in environment-variable substitution");
+ syntax_error ("Missing \"}\" in environment-variable substitution",
+ string);
badvar:
- error ("Substituting nonexistent environment variable \"%s\"",
- target);
+ syntax_error_2 ("Substituting nonexistent environment variable",
+ string, build_string (target));
/* NOTREACHED */
return Qnil; /* suppress compiler warning */
Lisp_Object
expand_and_dir_to_file (Lisp_Object filename, Lisp_Object defdir)
{
- /* This function can call lisp */
+ /* This function can call Lisp. GC checked 2000-07-28 ben */
Lisp_Object abspath;
struct gcpro gcpro1;
barf_or_query_if_file_exists (Lisp_Object absname, const char *querystring,
int interactive, struct stat *statptr)
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can call Lisp. GC checked 2000-07-28 ben */
struct stat statbuf;
/* stat is a good way to tell whether the file exists,
regardless of what access permissions it has. */
- if (stat ((char *) XSTRING_DATA (absname), &statbuf) >= 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (absname), &statbuf) >= 0)
{
Lisp_Object tem;
*/
(filename, newname, ok_if_already_exists, keep_time))
{
- /* This function can GC. GC checked 1997.04.06. */
+ /* This function can call Lisp. GC checked 2000-07-28 ben */
int ifd, ofd, n;
char buf[16 * 1024];
struct stat st, out_st;
args[1] = Qnil; args[2] = Qnil;
NGCPRO1 (*args);
ngcpro1.nvars = 3;
- if (XSTRING_BYTE (newname, XSTRING_LENGTH (newname) - 1) != '/')
- args[i++] = build_string ("/");
+ if (!IS_DIRECTORY_SEP (XSTRING_BYTE (newname,
+ XSTRING_LENGTH (newname) - 1)))
+
+ args[i++] = Fchar_to_string (Vdirectory_sep_char);
args[i++] = Ffile_name_nondirectory (filename);
newname = Fconcat (i, args);
NUNGCPRO;
|| INTP (ok_if_already_exists))
barf_or_query_if_file_exists (newname, "copy to it",
INTP (ok_if_already_exists), &out_st);
- else if (stat ((const char *) XSTRING_DATA (newname), &out_st) < 0)
+ else if (xemacs_stat ((const char *) XSTRING_DATA (newname), &out_st) < 0)
out_st.st_mode = 0;
ifd = interruptible_open ((char *) XSTRING_DATA (filename), O_RDONLY | OPEN_BINARY, 0);
report_file_error ("I/O error", list1 (newname));
if (input_file_statable_p)
- {
- if (!NILP (keep_time))
{
- EMACS_TIME atime, mtime;
- EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
- EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
- if (set_file_times ((char *) XSTRING_DATA (newname), atime,
- mtime))
- report_file_error ("I/O error", list1 (newname));
+ if (!NILP (keep_time))
+ {
+ EMACS_TIME atime, mtime;
+ EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
+ EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
+ if (set_file_times ((char *) XSTRING_DATA (newname), atime,
+ mtime))
+ report_file_error ("I/O error", list1 (newname));
+ }
+ chmod ((const char *) XSTRING_DATA (newname),
+ st.st_mode & 07777);
}
- chmod ((const char *) XSTRING_DATA (newname),
- st.st_mode & 07777);
- }
/* We'll close it by hand */
XCAR (ofd_locative) = Qnil;
/* netunam, being a strange-o system call only used once, is not
encapsulated. */
- TO_EXTERNAL_FORMAT (LISP_STRING, path, C_STRING_ALLOCA, path_ext, Qfile_name);
- TO_EXTERNAL_FORMAT (LISP_STRING, login, C_STRING_ALLOCA, login_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (path, path_ext, Qfile_name);
+ LISP_STRING_TO_EXTERNAL (login, login_ext, Qnative);
netresult = netunam (path_ext, login_ext);
{
#ifdef WIN32_NATIVE
struct stat st;
- if (stat (filename, &st) < 0)
+ if (xemacs_stat (filename, &st) < 0)
return 0;
return ((st.st_mode & S_IEXEC) != 0);
#else /* not WIN32_NATIVE */
#ifdef HAVE_EACCESS
- return eaccess (filename, 1) >= 0;
+ return eaccess (filename, X_OK) >= 0;
#else
/* Access isn't quite right because it uses the real uid
and we really want to test with the effective uid.
But Unix doesn't give us a right way to do it. */
- return access (filename, 1) >= 0;
+ return access (filename, X_OK) >= 0;
#endif /* HAVE_EACCESS */
#endif /* not WIN32_NATIVE */
}
check_writable (const char *filename)
{
#ifdef HAVE_EACCESS
- return (eaccess (filename, 2) >= 0);
+ return (eaccess (filename, W_OK) >= 0);
#else
/* Access isn't quite right because it uses the real uid
and we really want to test with the effective uid.
But Unix doesn't give us a right way to do it.
Opening with O_WRONLY could work for an ordinary file,
but would lose for directories. */
- return (access (filename, 2) >= 0);
+ return (access (filename, W_OK) >= 0);
#endif
}
*/
(filename))
{
- /* This function can call lisp */
+ /* This function can call lisp; GC checked 2000-07-11 ben */
Lisp_Object abspath;
Lisp_Object handler;
struct stat statbuf;
if (!NILP (handler))
return call2 (handler, Qfile_exists_p, abspath);
- return stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0 ? Qt : Qnil;
+ return xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0 ? Qt : Qnil;
}
DEFUN ("file-executable-p", Ffile_executable_p, 1, 1, 0, /*
(filename))
{
- /* This function can GC. GC checked 1997.04.10. */
+ /* This function can GC. GC checked 07-11-2000 ben. */
Lisp_Object abspath;
Lisp_Object handler;
struct gcpro gcpro1;
if (!NILP (handler))
return call2 (handler, Qfile_writable_p, abspath);
- if (stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0)
return (check_writable ((char *) XSTRING_DATA (abspath))
? Qt : Qnil);
if (!NILP (handler))
return call2 (handler, Qfile_directory_p, abspath);
- if (stat ((char *) XSTRING_DATA (abspath), &st) < 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
return Qnil;
return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
}
if (!NILP (handler))
return call2 (handler, Qfile_regular_p, abspath);
- if (stat ((char *) XSTRING_DATA (abspath), &st) < 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
return Qnil;
return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
}
if (!NILP (handler))
return call2 (handler, Qfile_modes, abspath);
- if (stat ((char *) XSTRING_DATA (abspath), &st) < 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
return Qnil;
/* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */
#if 0
return call3 (handler, Qfile_newer_than_file_p, abspath1,
abspath2);
- if (stat ((char *) XSTRING_DATA (abspath1), &st) < 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (abspath1), &st) < 0)
return Qnil;
mtime1 = st.st_mtime;
- if (stat ((char *) XSTRING_DATA (abspath2), &st) < 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (abspath2), &st) < 0)
return Qt;
return (mtime1 > st.st_mtime) ? Qt : Qnil;
fd = -1;
- if (stat ((char *) XSTRING_DATA (filename), &st) < 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) < 0)
{
if (fd >= 0) close (fd);
badopen:
*/
(start, end, filename, append, visit, lockname, codesys))
{
- /* This function can call lisp */
+ /* This function can call lisp. GC checked 2000-07-28 ben */
int desc;
int failure;
int save_errno = 0;
struct stat st;
- Lisp_Object fn;
+ Lisp_Object fn = Qnil;
int speccount = specpdl_depth ();
int visiting_other = STRINGP (visit);
int visiting = (EQ (visit, Qt) || visiting_other);
Lisp_Object annotations = Qnil;
struct buffer *given_buffer;
Bufpos start1, end1;
+ struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
+ struct gcpro ngcpro1, ngcpro2;
+ Lisp_Object curbuf;
- /* #### dmoore - if Fexpand_file_name or handlers kill the buffer,
+ XSETBUFFER (curbuf, current_buffer);
+
+ /* start, end, visit, and append are never modified in this fun
+ so we don't protect them. */
+ GCPRO5 (visit_file, filename, codesys, lockname, annotations);
+ NGCPRO2 (curbuf, fn);
+
+ /* [[ dmoore - if Fexpand_file_name or handlers kill the buffer,
we should signal an error rather than blissfully continuing
along. ARGH, this function is going to lose lose lose. We need
to protect the current_buffer from being destroyed, but the
- multiple return points make this a pain in the butt. */
+ multiple return points make this a pain in the butt. ]] we do
+ protect curbuf now. --ben */
#ifdef FILE_CODING
codesys = Fget_coding_system (codesys);
#endif /* FILE_CODING */
if (current_buffer->base_buffer && ! NILP (visit))
- error ("Cannot do file visiting in an indirect buffer");
+ invalid_operation ("Cannot do file visiting in an indirect buffer",
+ curbuf);
if (!NILP (start) && !STRINGP (start))
get_buffer_range_char (current_buffer, start, end, &start1, &end1, 0);
{
Lisp_Object handler;
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
-
- GCPRO5 (start, filename, visit, visit_file, lockname);
if (visiting_other)
visit_file = Fexpand_file_name (visit, Qnil);
visit_file = filename;
filename = Fexpand_file_name (filename, Qnil);
- UNGCPRO;
-
if (NILP (lockname))
lockname = visit_file;
+ /* We used to UNGCPRO here. BAD! visit_file is used below after
+ more Lisp calling. */
/* If the file name has special constructs in it,
call the corresponding file handler. */
handler = Ffind_file_name_handler (filename, Qwrite_region);
current_buffer->filename = visit_file;
MARK_MODELINE_CHANGED;
}
+ NUNGCPRO;
+ UNGCPRO;
return val;
}
}
#ifdef CLASH_DETECTION
if (!auto_saving)
- {
- Lisp_Object curbuf;
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
-
- XSETBUFFER (curbuf, current_buffer);
- GCPRO5 (start, filename, visit_file, lockname, curbuf);
- lock_file (lockname);
- UNGCPRO;
- }
+ lock_file (lockname);
#endif /* CLASH_DETECTION */
/* Special kludge to simplify auto-saving. */
{
Lisp_Object desc_locative = Fcons (make_int (desc), Qnil);
Lisp_Object instream = Qnil, outstream = Qnil;
- struct gcpro gcpro1, gcpro2;
+ struct gcpro nngcpro1, nngcpro2;
/* need to gcpro; QUIT could happen out of call to write() */
- GCPRO2 (instream, outstream);
+ NNGCPRO2 (instream, outstream);
record_unwind_protect (close_file_unwind, desc_locative);
save_errno = errno;
}
Lstream_close (XLSTREAM (instream));
- UNGCPRO;
#ifdef HAVE_FSYNC
/* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
systems where close() can change the modtime. This is known to
happen on various NFS file systems, on Windows, and on Linux.
Rather than handling this on a per-system basis, we
- unconditionally do the stat() after the close(). */
+ unconditionally do the xemacs_stat() after the close(). */
/* NFS can report a write failure now. */
if (close (desc) < 0)
as necessary). */
XCAR (desc_locative) = Qnil;
unbind_to (speccount, Qnil);
+
+ NNUNGCPRO;
}
- stat ((char *) XSTRING_DATA (fn), &st);
+ xemacs_stat ((char *) XSTRING_DATA (fn), &st);
#ifdef CLASH_DETECTION
if (!auto_saving)
current_buffer->modtime = st.st_mtime;
if (failure)
- error ("IO error writing %s: %s",
- XSTRING_DATA (fn),
- strerror (save_errno));
+ {
+ errno = save_errno;
+ report_file_error ("Writing file", list1 (fn));
+ }
if (visiting)
{
}
else if (quietly)
{
+ NUNGCPRO;
+ UNGCPRO;
return Qnil;
}
message ("Wrote %s", XSTRING_DATA (visit_file));
else
{
- struct gcpro gcpro1;
Lisp_Object fsp;
- GCPRO1 (fn);
+ struct gcpro nngcpro1;
+ NNGCPRO1 (fsp);
fsp = Ffile_symlink_p (fn);
if (NILP (fsp))
message ("Wrote %s", XSTRING_DATA (fn));
else
message ("Wrote %s (symlink to %s)",
XSTRING_DATA (fn), XSTRING_DATA (fsp));
- UNGCPRO;
+ NNUNGCPRO;
}
}
+ NUNGCPRO;
+ UNGCPRO;
return Qnil;
}
*/
(buf))
{
- /* This function can call lisp */
+ /* This function can call lisp; GC checked 2000-07-11 ben */
struct buffer *b;
struct stat st;
Lisp_Object handler;
if (!NILP (handler))
return call2 (handler, Qverify_visited_file_modtime, buf);
- if (stat ((char *) XSTRING_DATA (b->filename), &st) < 0)
+ if (xemacs_stat ((char *) XSTRING_DATA (b->filename), &st) < 0)
{
/* If the file doesn't exist now and didn't exist before,
we say that it isn't modified, provided the error is a tame one. */
if (!NILP (handler))
/* The handler can find the file name the same way we did. */
return call2 (handler, Qset_visited_file_modtime, Qnil);
- else if (stat ((char *) XSTRING_DATA (filename), &st) >= 0)
+ else if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) >= 0)
current_buffer->modtime = st.st_mtime;
}
/* Get visited file's mode to become the auto save file's mode. */
if (STRINGP (fn) &&
- stat ((char *) XSTRING_DATA (fn), &st) >= 0)
+ xemacs_stat ((char *) XSTRING_DATA (fn), &st) >= 0)
/* But make sure we can overwrite it later! */
auto_save_mode_bits = st.st_mode | 0600;
else
defsymbol (&Qformat_annotate_function, "format-annotate-function");
defsymbol (&Qcompute_buffer_file_truename, "compute-buffer-file-truename");
- deferror (&Qfile_error, "file-error", "File error", Qio_error);
- deferror (&Qfile_already_exists, "file-already-exists",
- "File already exists", Qfile_error);
+ DEFERROR_STANDARD (Qfile_error, Qio_error);
+ DEFERROR_STANDARD (Qfile_already_exists, Qfile_error);
DEFSUBR (Ffind_file_name_handler);
static int
lock_file_1 (char *lfname, int force)
{
+ /* Does not GC. */
int err;
char *lock_info_str;
char *host_name;
static int
current_lock_owner (lock_info_type *owner, char *lfname)
{
+ /* Does not GC. */
int len, ret;
int local_owner = 0;
char *at, *dot;
static int
lock_if_free (lock_info_type *clasher, char *lfname)
{
+ /* Does not GC. */
if (lock_file_1 (lfname, 0) == 0)
{
int locker;
void
lock_file (Lisp_Object fn)
{
- /* This function can GC. */
+ /* This function can GC. GC checked 7-11-00 ben */
/* dmoore - and can destroy current_buffer and all sorts of other
mean nasty things with pointy teeth. If you call this make sure
you protect things right. */
if (!NILP (subject_buf)
&& NILP (Fverify_visited_file_modtime (subject_buf))
&& !NILP (Ffile_exists_p (fn)))
- call1_in_buffer (XBUFFER(subject_buf),
+ call1_in_buffer (XBUFFER (subject_buf),
Qask_user_about_supersession_threat, fn);
}
void
unlock_file (Lisp_Object fn)
{
+ /* This can GC */
register char *lfname;
struct gcpro gcpro1;
/* Pick up relevant properties */
initially_unmapped = Fplist_get (props, Qinitially_unmapped, Qnil);
name = Fplist_get (props, Qname, Qnil);
-
+
popup = Fplist_get (props, Qpopup, Qnil);
if (EQ (popup, Qt))
popup = Fselected_frame (Qnil);
FRAME_MSWINDOWS_TARGET_RECT (f)->left = NILP (left) ? -1 : abs (XINT (left));
FRAME_MSWINDOWS_TARGET_RECT (f)->top = NILP (top) ? -1 : abs (XINT (top));
- FRAME_MSWINDOWS_TARGET_RECT (f)->width = NILP (width) ? -1 :
+ FRAME_MSWINDOWS_TARGET_RECT (f)->width = NILP (width) ? -1 :
abs (XINT (width));
- FRAME_MSWINDOWS_TARGET_RECT (f)->height = NILP (height) ? -1 :
+ FRAME_MSWINDOWS_TARGET_RECT (f)->height = NILP (height) ? -1 :
abs (XINT (height));
-
+
/* Misc frame stuff */
FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil;
#ifdef HAVE_TOOLBARS
- FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f) =
+ FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f) =
make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
#endif
/* hashtable of instantiated glyphs on the frame. */
- FRAME_MSWINDOWS_WIDGET_HASH_TABLE1 (f) =
+ FRAME_MSWINDOWS_WIDGET_HASH_TABLE1 (f) =
make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL);
- FRAME_MSWINDOWS_WIDGET_HASH_TABLE2 (f) =
+ FRAME_MSWINDOWS_WIDGET_HASH_TABLE2 (f) =
make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL);
- FRAME_MSWINDOWS_WIDGET_HASH_TABLE3 (f) =
+ FRAME_MSWINDOWS_WIDGET_HASH_TABLE3 (f) =
make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL);
/* Will initialize these in WM_SIZE handler. We cannot do it now,
because we do not know what is CW_USEDEFAULT height and width */
rect_default.top = rect.top + POPUP_OFFSET;
char_to_real_pixel_size (f, POPUP_WIDTH, POPUP_HEIGHT,
&rect_default.width, &rect_default.height);
+ FRAME_MSWINDOWS_POPUP (f) = 1;
}
AdjustWindowRectEx(&rect, style, ADJR_MENUFLAG, exstyle);
hwnd = CreateWindowEx (exstyle,
XEMACS_CLASS,
STRINGP(f->name) ? XSTRING_DATA(f->name) :
- (STRINGP(name) ?
- (const Extbyte*)XSTRING_DATA(name) :
+ (STRINGP(name) ?
+ (const Extbyte*)XSTRING_DATA(name) :
(const Extbyte*)XEMACS_CLASS),
style,
rect_default.left, rect_default.top,
Vmswindows_frame_being_created = Qnil;
if (hwnd == NULL)
- error ("System call to create frame failed");
-
+ invalid_operation ("System call to create frame failed",
+ STRINGP (f->name) ? f->name :
+ STRINGP (name) ? name :
+ Qunbound);
+
FRAME_MSWINDOWS_HANDLE(f) = hwnd;
SetWindowLong (hwnd, XWL_FRAMEOBJ, (LONG)LISP_TO_VOID(frame_obj));
FRAME_MSWINDOWS_DC(f) = GetDC (hwnd);
SetTextAlign (FRAME_MSWINDOWS_DC(f), TA_BASELINE | TA_LEFT | TA_NOUPDATECP);
+
+ if (FRAME_MSWINDOWS_POPUP (f))
+ mswindows_register_popup_frame (frame_obj);
}
static void
since we don't have X resources. This may change if we look
at the registry. Even so these values can get overridden
later.*/
- XEMACS_RECT_WH dest = { -1, -1, DEFAULT_FRAME_WIDTH,
+ XEMACS_RECT_WH dest = { -1, -1, DEFAULT_FRAME_WIDTH,
DEFAULT_FRAME_HEIGHT };
mswindows_size_frame_internal (f, &dest);
}
{
/* Don't do this earlier or we get a WM_PAINT before the frame is ready.
* The SW_x parameter in the first call that an app makes to ShowWindow is
- * ignored, and the parameter specified in the caller's STARTUPINFO is
+ * ignored, and the parameter specified in the caller's STARTUPINFO is
* substituted instead. That parameter is SW_HIDE if we were started by
* runemacs, so call this twice. #### runemacs is evil */
ShowWindow (FRAME_MSWINDOWS_HANDLE(f), SW_SHOWNORMAL);
int first_on_console)
{
/* Windows, unlike X, is very synchronous. After the initial
- frame is created, it will never be displayed, except for
+ frame is created, it will never be displayed, except for
hollow border, unless we start pumping messages. Load progress
messages show in the bottom of the hollow frame, which is ugly.
We redisplay the initial frame here, so modeline and root window
{
if (f->frame_data)
{
+ Lisp_Object frame;
+ XSETFRAME (frame, f);
+ mswindows_unregister_popup_frame (frame);
ReleaseDC(FRAME_MSWINDOWS_HANDLE(f), FRAME_MSWINDOWS_DC(f));
DestroyWindow(FRAME_MSWINDOWS_HANDLE(f));
xfree (f->frame_data);
if (IsIconic (FRAME_MSWINDOWS_HANDLE(f)) || IsZoomed (FRAME_MSWINDOWS_HANDLE(f)))
ShowWindow (FRAME_MSWINDOWS_HANDLE(f), SW_RESTORE);
- SetWindowPos (FRAME_MSWINDOWS_HANDLE(f), NULL,
+ SetWindowPos (FRAME_MSWINDOWS_HANDLE(f), NULL,
0, 0, rect.right-rect.left, rect.bottom-rect.top,
SWP_NOACTIVATE | SWP_NOZORDER | SWP_NOSENDCHANGING | SWP_NOMOVE);
}
static void
mswindows_set_frame_position (struct frame *f, int xoff, int yoff)
{
- SetWindowPos (FRAME_MSWINDOWS_HANDLE(f), NULL,
+ SetWindowPos (FRAME_MSWINDOWS_HANDLE(f), NULL,
xoff, yoff, 0, 0,
SWP_NOACTIVATE | SWP_NOZORDER | SWP_NOSENDCHANGING | SWP_NOSIZE);
}
static void
-mswindows_make_frame_visible (struct frame *f)
+mswindows_make_frame_visible (struct frame *f)
{
if (!FRAME_VISIBLE_P(f))
ShowWindow (FRAME_MSWINDOWS_HANDLE(f), SW_RESTORE);
}
static void
-mswindows_make_frame_invisible (struct frame *f)
+mswindows_make_frame_invisible (struct frame *f)
{
if (!FRAME_VISIBLE_P(f))
return;
UnionRect(&rc_temp, &rc_me, &rc_other);
if (!EqualRect (&rc_temp, &rc_other))
return 0;
-
+
/* Then see if any window above us obscures us */
while ((hwnd = GetWindow (hwnd, GW_HWNDPREV)) != NULL)
if (IsWindowVisible (hwnd))
{
if (!XIMAGE_INSTANCE_MSWINDOWS_ICON (f->icon))
{
- mswindows_initialize_image_instance_icon (XIMAGE_INSTANCE (f->icon),
+ mswindows_initialize_image_instance_icon (XIMAGE_INSTANCE (f->icon),
FALSE);
}
-
- SetClassLong (FRAME_MSWINDOWS_HANDLE (f), GCL_HICON,
+
+ SetClassLong (FRAME_MSWINDOWS_HANDLE (f), GCL_HICON,
(LONG) XIMAGE_INSTANCE_MSWINDOWS_ICON (f->icon));
}
}
}
static void
-mswindows_set_title_from_bufbyte (struct frame *f, Bufbyte *title)
+mswindows_enable_frame (struct frame *f)
+{
+ EnableWindow (FRAME_MSWINDOWS_HANDLE (f), TRUE);
+}
+
+static void
+mswindows_disable_frame (struct frame *f)
+{
+ EnableWindow (FRAME_MSWINDOWS_HANDLE (f), FALSE);
+}
+
+static void
+mswindows_set_title_from_bufbyte (struct frame *f, Bufbyte *title)
{
unsigned int new_checksum = hash_string (title, strlen (title));
if (new_checksum != FRAME_MSWINDOWS_TITLE_CHECKSUM(f))
if (STRINGP (val))
{
Lisp_Object frm, font_spec;
-
+
XSETFRAME (frm, f);
font_spec = Fget (Fget_face (Qdefault), Qfont, Qnil);
/* Now we've extracted the properties, apply them.
Do not apply geometric properties during frame creation. This
- is excessive anyways, and this loses becuase WM_SIZE has not
+ is excessive anyways, and this loses because WM_SIZE has not
been sent yet, so frame width and height fields are not initialized.
-
+
unfortunately WM_SIZE loses as well since the resize is only
applied once and the first time WM_SIZE is applied not everything
is initialised in the frame (toolbars for instance). enabling
int size_p = (dest->width >=0 || dest->height >=0);
int move_p = (dest->top >=0 || dest->left >=0);
char_to_real_pixel_size (f, dest->width, dest->height, &pixel_width, &pixel_height);
-
+
if (dest->width < 0)
pixel_width = FRAME_PIXWIDTH (f);
if (dest->height < 0)
dest->left = rect.left;
if (dest->top < 0)
dest->top = rect.top;
-
+
rect.left = rect.top = 0;
rect.right = pixel_width;
rect.bottom = pixel_height;
move_p=1;
}
- if (IsIconic (FRAME_MSWINDOWS_HANDLE(f))
+ if (IsIconic (FRAME_MSWINDOWS_HANDLE(f))
|| IsZoomed (FRAME_MSWINDOWS_HANDLE(f)))
ShowWindow (FRAME_MSWINDOWS_HANDLE(f), SW_RESTORE);
- SetWindowPos (FRAME_MSWINDOWS_HANDLE(f), NULL,
+ SetWindowPos (FRAME_MSWINDOWS_HANDLE(f), NULL,
dest->left, dest->top, pixel_width, pixel_height,
SWP_NOACTIVATE | SWP_NOZORDER | SWP_NOSENDCHANGING
| (size_p ? 0 : SWP_NOSIZE)
/*---------------------------------------------------------------------*/
/*
- * With some drvier/os combination (I discovered this with HP drviers
+ * With some driver/os combination (I discovered this with HP drivers
* under W2K), DC geometry is reset upon StartDoc and EndPage
* calls. This is called every time one of these calls is made.
*/
{
Lisp_Object frame;
XSETFRAME (frame, f);
- signal_simple_error ("Cannot resize frame (margins)"
- " after print job has started.", frame);
+ invalid_change ("Cannot resize frame (margins) after print job has started.",
+ frame);
}
static void
/* Make sure this is the only frame on device. Windows printer can
handle only one job at a time. */
if (!NILP (DEVICE_FRAME_LIST (XDEVICE (FRAME_DEVICE (f)))))
- error ("Only one frame (print job) at a time is allowed on "
- "this printer device.");
+ invalid_operation ("Only one frame (print job) at a time is allowed on "
+ "this printer device", FRAME_DEVICE (f));
f->frame_data = xnew_and_zero (struct msprinter_frame);
frame_left = (MulDiv (GetDeviceCaps (hdc, LOGPIXELSX),
FRAME_MSPRINTER_LEFT_MARGIN(f), 1440)
- GetDeviceCaps (hdc, PHYSICALOFFSETX));
-
+
if (FRAME_MSPRINTER_CHARWIDTH(f) > 0)
{
char_to_real_pixel_size (f, FRAME_MSPRINTER_CHARWIDTH(f), 0,
&frame_width, NULL);
- FRAME_MSPRINTER_RIGHT_MARGIN(f) =
+ FRAME_MSPRINTER_RIGHT_MARGIN(f) =
MulDiv (GetDeviceCaps (hdc, PHYSICALWIDTH)
- (frame_left + frame_width), 1440,
GetDeviceCaps (hdc, LOGPIXELSX));
- }
+ }
else
frame_width = (GetDeviceCaps (hdc, PHYSICALWIDTH)
- frame_left
char_to_real_pixel_size (f, 0, FRAME_MSPRINTER_CHARHEIGHT(f),
NULL, &frame_height);
- FRAME_MSPRINTER_BOTTOM_MARGIN(f) =
+ FRAME_MSPRINTER_BOTTOM_MARGIN(f) =
MulDiv (GetDeviceCaps (hdc, PHYSICALHEIGHT)
- (frame_top + frame_height), 1440,
GetDeviceCaps (hdc, LOGPIXELSY));
- }
+ }
else
frame_height = (GetDeviceCaps (hdc, PHYSICALHEIGHT)
- frame_top
/* Geometry sanity checks */
if (!frame_pixsize_valid_p (f, frame_width, frame_height))
- error ("Area inside print margins has shrunk to naught.");
+ invalid_operation ("Area inside print margins has shrunk to naught",
+ STRINGP (f->name) ? f->name : Qunbound);
if (frame_left < 0
|| frame_top < 0
|| frame_left + frame_width > GetDeviceCaps (hdc, HORZRES)
|| frame_top + frame_height > GetDeviceCaps (hdc, VERTRES))
- error ("Print area is ouside of the printer's hardware printable area.");
+ invalid_operation ("Print area is ouside of the printer's "
+ "hardware printable area",
+ STRINGP (f->name) ? f->name : Qunbound);
/* Apply XEmacs frame geometry and layout windows */
{
di.fwType = 0;
if (StartDoc (hdc, &di) <= 0)
- error ("Cannot start print job");
+ invalid_operation ("Cannot start print job",
+ STRINGP (f->name) ? f->name : Qunbound);
apply_dc_geometry (f);
{
/* Display frames */
CONSOLE_HAS_METHOD (mswindows, init_frame_1);
- CONSOLE_HAS_METHOD (mswindows, init_frame_2);
+ CONSOLE_HAS_METHOD (mswindows, init_frame_2);
CONSOLE_HAS_METHOD (mswindows, init_frame_3);
CONSOLE_HAS_METHOD (mswindows, after_init_frame);
CONSOLE_HAS_METHOD (mswindows, mark_frame);
CONSOLE_HAS_METHOD (mswindows, set_mouse_position);
CONSOLE_HAS_METHOD (mswindows, raise_frame);
CONSOLE_HAS_METHOD (mswindows, lower_frame);
+ CONSOLE_HAS_METHOD (mswindows, enable_frame);
+ CONSOLE_HAS_METHOD (mswindows, disable_frame);
CONSOLE_HAS_METHOD (mswindows, make_frame_visible);
CONSOLE_HAS_METHOD (mswindows, make_frame_invisible);
CONSOLE_HAS_METHOD (mswindows, iconify_frame);
CONSOLE_HAS_METHOD (mswindows, frame_visible_p);
CONSOLE_HAS_METHOD (mswindows, frame_totally_visible_p);
CONSOLE_HAS_METHOD (mswindows, frame_iconified_p);
- CONSOLE_HAS_METHOD (mswindows, set_frame_pointer);
- CONSOLE_HAS_METHOD (mswindows, set_frame_icon);
+ CONSOLE_HAS_METHOD (mswindows, set_frame_pointer);
+ CONSOLE_HAS_METHOD (mswindows, set_frame_icon);
CONSOLE_HAS_METHOD (mswindows, get_frame_parent);
CONSOLE_HAS_METHOD (mswindows, update_frame_external_traits);
CONSOLE_HAS_METHOD (mswindows, frame_size_fixed_p);
DEFVAR_LISP ("mswindows-use-system-frame-size-defaults", &Vmswindows_use_system_frame_size_defaults /*
Controls whether to use system or XEmacs defaults for frame size.
-If nil then reasonable defaults are used for intial frame sizes. If t
+If nil then reasonable defaults are used for initial frame sizes. If t
then the system will choose default sizes for the frame.
*/ );
Vmswindows_use_system_frame_size_defaults = Qnil;
-
+
DEFVAR_LISP ("default-mswindows-frame-plist", &Vdefault_mswindows_frame_plist /*
Plist of default frame-creation properties for mswindows frames.
These override what is specified in `default-frame-plist', but are
top-margin typographical unit of measurement,
right-margin equal to 1/1440 of an inch, or 1/20 of a
bottom-margin point, and roughly equal to 7/400 of a
- millimeter. If not specifified, each margin
+ millimeter. If not specified, each margin
defaults to one inch (25.4 mm).
MARGINS NOTE. right-margin and bottom-margin are overridden by
static void
tty_raise_frame_no_select (struct frame *f)
{
- Lisp_Object frame;
LIST_LOOP_2 (frame, DEVICE_FRAME_LIST (XDEVICE (FRAME_DEVICE (f))))
{
struct frame *o = XFRAME (frame);
/* Substantially rewritten for XEmacs. */
+/* 7-8-00 !!#### This file needs definite Mule review. */
+
#include <config.h>
#include "lisp.h"
/* We used to map over all frames here and then map over all widgets
belonging to that frame. However it turns out that this was very fragile
- as it requires our display stuctures to be in sync _and_ that the
+ as it requires our display structures to be in sync _and_ that the
loop is told about every new widget somebody adds. Therefore we
now let Xt find it for us (which does a bottom-up search which
could even be faster) */
{
const char * tmp;
encoding = DEVICE_XATOM_COMPOUND_TEXT (XDEVICE (FRAME_DEVICE (f)));
- TO_EXTERNAL_FORMAT (C_STRING, value,
- C_STRING_ALLOCA, tmp,
- Qctext);
+ C_STRING_TO_EXTERNAL (value, tmp, Qctext);
new_XtValue = (String) tmp;
break;
}
if (XSTRING_LENGTH (prop) == 0)
continue;
- TO_EXTERNAL_FORMAT (LISP_STRING, prop,
- C_STRING_ALLOCA, extprop,
- Qctext);
+ LISP_STRING_TO_EXTERNAL (prop, extprop, Qctext);
if (STRINGP (val))
{
const Extbyte *extval;
#endif
if (STRINGP (f->name))
- TO_EXTERNAL_FORMAT (LISP_STRING, f->name,
- C_STRING_ALLOCA, name,
- Qctext);
+ LISP_STRING_TO_EXTERNAL (f->name, name, Qctext);
else
name = "emacs";
}
}
+static void
+x_enable_frame (struct frame *f)
+{
+ XtSetSensitive (FRAME_X_SHELL_WIDGET (f), True);
+}
+
+static void
+x_disable_frame (struct frame *f)
+{
+ XtSetSensitive (FRAME_X_SHELL_WIDGET (f), False);
+}
+
/* Change from withdrawn state to mapped state. */
static void
x_make_frame_visible (struct frame *f)
CONSOLE_HAS_METHOD (x, set_mouse_position);
CONSOLE_HAS_METHOD (x, raise_frame);
CONSOLE_HAS_METHOD (x, lower_frame);
+ CONSOLE_HAS_METHOD (x, enable_frame);
+ CONSOLE_HAS_METHOD (x, disable_frame);
CONSOLE_HAS_METHOD (x, make_frame_visible);
CONSOLE_HAS_METHOD (x, make_frame_invisible);
CONSOLE_HAS_METHOD (x, iconify_frame);
/* one-bit flags: */
+ /* Is focusing onto this frame disabled? (Modal dialog boxes) */
+ unsigned int disabled :1;
+
/* Are we finished initializing? */
unsigned int init_finished :1;
DECLARE_LRECORD (frame, struct frame);
#define XFRAME(x) XRECORD (x, frame, struct frame)
#define XSETFRAME(x, p) XSETRECORD (x, p, frame)
+#define wrap_frame(p) wrap_object (p)
#define FRAMEP(x) RECORDP (x, frame)
#define CHECK_FRAME(x) CHECK_RECORD (x, frame)
#define CONCHECK_FRAME(x) CONCHECK_RECORD (x, frame)
void update_frame_title (struct frame *f);
Lisp_Object next_frame (Lisp_Object f, Lisp_Object frametype,
Lisp_Object console);
-Lisp_Object prev_frame (Lisp_Object f, Lisp_Object frametype,
- Lisp_Object console);
+Lisp_Object previous_frame (Lisp_Object f, Lisp_Object frametype,
+ Lisp_Object console);
void pixel_to_char_size (struct frame *f, int pixel_width, int pixel_height,
int *char_width, int *char_height);
void char_to_pixel_size (struct frame *f, int char_width, int char_height,
void io_error_delete_frame (Lisp_Object frame);
Lisp_Object find_some_frame (int (*predicate) (Lisp_Object, void *),
void *closure);
-int device_matches_console_spec (Lisp_Object frame, Lisp_Object device,
- Lisp_Object console);
+int device_matches_console_spec (Lisp_Object device, Lisp_Object console);
Lisp_Object frame_first_window (struct frame *f);
int show_gc_cursor (struct frame *f, Lisp_Object cursor);
void set_frame_selected_window (struct frame *f, Lisp_Object window);
/* Commonly-used symbols
Copyright (C) 1995 Sun Microsystems.
- Copyright (C) 1995, 1996 Ben Wing.
+ Copyright (C) 1995, 1996, 2000 Ben Wing.
This file is part of XEmacs.
/* Synched up with: Not in FSF. */
-/* The purpose of this file is as a central place to stick symbols
- that don't have any obvious connection to any particular module
- and might be used in many different contexts.
-
- #### More should be put here.
- */
+/* See general-slots.h.
+*/
#include <config.h>
#include "lisp.h"
-Lisp_Object Qabort;
-Lisp_Object Qactually_requested;
-Lisp_Object Qafter;
-Lisp_Object Qall;
-Lisp_Object Qand;
-Lisp_Object Qappend;
-Lisp_Object Qassoc;
-Lisp_Object Qat;
-Lisp_Object Qautodetect;
-Lisp_Object Qbad_variable;
-Lisp_Object Qbefore;
-Lisp_Object Qbinary;
-Lisp_Object Qbitmap;
-Lisp_Object Qboolean;
-Lisp_Object Qbottom;
-Lisp_Object Qbottom_margin;
-Lisp_Object Qbuffer;
-Lisp_Object Qbutton;
-Lisp_Object Qcancel;
-Lisp_Object Qcategory;
-Lisp_Object Qcenter;
-Lisp_Object Qchannel;
-Lisp_Object Qchar;
-Lisp_Object Qcharacter;
-Lisp_Object Qchars;
-Lisp_Object Qcolor;
-Lisp_Object Qcolumns;
-Lisp_Object Qcommand;
-Lisp_Object Qconsole;
-Lisp_Object Qcopies;
-Lisp_Object Qcritical;
-Lisp_Object Qctext;
-Lisp_Object Qcursor;
-Lisp_Object Qdata;
-Lisp_Object Qdead;
-Lisp_Object Qdefault;
-Lisp_Object Qdelete;
-Lisp_Object Qdelq;
-Lisp_Object Qdevice;
-Lisp_Object Qdialog;
-Lisp_Object Qdimension;
-Lisp_Object Qdisplay;
-Lisp_Object Qdoc_string;
-Lisp_Object Qduplex;
-Lisp_Object Qdynarr_overhead;
-Lisp_Object Qempty;
-Lisp_Object Qeq;
-Lisp_Object Qeql;
-Lisp_Object Qequal;
-Lisp_Object Qeval;
-Lisp_Object Qextents;
-Lisp_Object Qface;
-Lisp_Object Qfile_name;
-Lisp_Object Qfont;
-Lisp_Object Qframe;
-Lisp_Object Qfrom_page;
-Lisp_Object Qfull_assoc;
-Lisp_Object Qfuncall;
-Lisp_Object Qfunction;
-Lisp_Object Qgap_overhead;
-Lisp_Object Qgeneric;
-Lisp_Object Qgeometry;
-Lisp_Object Qglobal;
-Lisp_Object Qgutter;
-Lisp_Object Qheight;
-Lisp_Object Qhelp;
-Lisp_Object Qhighlight;
-Lisp_Object Qhorizontal;
-Lisp_Object Qicon;
-Lisp_Object Qid;
-Lisp_Object Qignore;
-Lisp_Object Qimage;
-Lisp_Object Qinfo;
-Lisp_Object Qinherit;
-Lisp_Object Qinteger;
-Lisp_Object Qinternal;
-Lisp_Object Qkey;
-Lisp_Object Qkey_assoc;
-Lisp_Object Qkeyboard;
-Lisp_Object Qkeymap;
-Lisp_Object Qlandscape;
-Lisp_Object Qlast_command;
-Lisp_Object Qleft;
-Lisp_Object Qleft_margin;
-Lisp_Object Qlet;
-Lisp_Object Qlist;
-Lisp_Object Qmagic;
-Lisp_Object Qmalloc_overhead;
-Lisp_Object Qmarkers;
-Lisp_Object Qmax;
-Lisp_Object Qmemory;
-Lisp_Object Qmenubar;
-Lisp_Object Qmessage;
-Lisp_Object Qminus;
-Lisp_Object Qmodifiers;
-Lisp_Object Qmotion;
-Lisp_Object Qmsprinter;
-Lisp_Object Qmswindows;
-Lisp_Object Qname;
-Lisp_Object Qno;
-Lisp_Object Qnone;
-Lisp_Object Qnot;
-Lisp_Object Qnothing;
-Lisp_Object Qnotice;
-Lisp_Object Qobject;
-Lisp_Object Qok;
-Lisp_Object Qold_assoc;
-Lisp_Object Qold_delete;
-Lisp_Object Qold_delq;
-Lisp_Object Qold_rassoc;
-Lisp_Object Qold_rassq;
-Lisp_Object Qonly;
-Lisp_Object Qor;
-Lisp_Object Qorientation;
-Lisp_Object Qother;
-Lisp_Object Qpointer;
-Lisp_Object Qpopup;
-Lisp_Object Qportrait;
-Lisp_Object Qprint;
-Lisp_Object Qprinter;
-Lisp_Object Qprocess;
-Lisp_Object Qprovide;
-Lisp_Object Qrassoc;
-Lisp_Object Qrassq;
-Lisp_Object Qrequire;
-Lisp_Object Qresource;
-Lisp_Object Qretry;
-Lisp_Object Qreturn;
-Lisp_Object Qreverse;
-Lisp_Object Qright;
-Lisp_Object Qright_margin;
-Lisp_Object Qsearch;
-Lisp_Object Qselected;
-Lisp_Object Qsignal;
-Lisp_Object Qsimple;
-Lisp_Object Qsize;
-Lisp_Object Qspace;
-Lisp_Object Qspecifier;
-Lisp_Object Qstream;
-Lisp_Object Qstring;
-Lisp_Object Qsymbol;
-Lisp_Object Qsyntax;
-Lisp_Object Qterminal;
-Lisp_Object Qtest;
-Lisp_Object Qtext;
-Lisp_Object Qthis_command;
-Lisp_Object Qtimeout;
-Lisp_Object Qtimestamp;
-Lisp_Object Qtoolbar;
-Lisp_Object Qtop;
-Lisp_Object Qtop_margin;
-Lisp_Object Qto_page;
-Lisp_Object Qtty;
-Lisp_Object Qtype;
-Lisp_Object Qundecided;
-Lisp_Object Qundefined;
-Lisp_Object Qunimplemented;
-Lisp_Object Qvalue_assoc;
-Lisp_Object Qvertical;
-Lisp_Object Qwarning;
-Lisp_Object Qwidget;
-Lisp_Object Qwidth;
-Lisp_Object Qwindow;
-Lisp_Object Qwindow_system;
-Lisp_Object Qx;
-Lisp_Object Qy;
-Lisp_Object Qyes;
+#define SYMBOL(fou) Lisp_Object fou
+#define SYMBOL_KEYWORD(la_cle_est_fou) Lisp_Object la_cle_est_fou
+#define SYMBOL_GENERAL(tout_le_monde, est_fou) Lisp_Object tout_le_monde
+
+#include "general-slots.h"
+
+#undef SYMBOL
+#undef SYMBOL_KEYWORD
+#undef SYMBOL_GENERAL
void
syms_of_general (void)
{
- defsymbol (&Qabort, "abort");
- defsymbol (&Qactually_requested, "actually-requested");
- defsymbol (&Qafter, "after");
- defsymbol (&Qall, "all");
- defsymbol (&Qand, "and");
- defsymbol (&Qappend, "append");
- defsymbol (&Qassoc, "assoc");
- defsymbol (&Qat, "at");
- defsymbol (&Qautodetect, "autodetect");
- defsymbol (&Qbad_variable, "bad-variable");
- defsymbol (&Qbefore, "before");
- defsymbol (&Qbinary, "binary");
- defsymbol (&Qbitmap, "bitmap");
- defsymbol (&Qboolean, "boolean");
- defsymbol (&Qbottom, "bottom");
- defsymbol (&Qbottom_margin, "bottom-margin");
- defsymbol (&Qbuffer, "buffer");
- defsymbol (&Qbutton, "button");
- defsymbol (&Qcancel, "cancel");
- defsymbol (&Qcategory, "category");
- defsymbol (&Qcenter, "center");
- defsymbol (&Qchannel, "channel");
- defsymbol (&Qchar, "char");
- defsymbol (&Qcharacter, "character");
- defsymbol (&Qchars, "chars");
- defsymbol (&Qcolor, "color");
- defsymbol (&Qcolumns, "columns");
- defsymbol (&Qcommand, "command");
- defsymbol (&Qconsole, "console");
- defsymbol (&Qcopies, "copies");
- defsymbol (&Qcritical, "critical");
- defsymbol (&Qctext, "ctext");
- defsymbol (&Qcursor, "cursor");
- defsymbol (&Qdata, "data");
- defsymbol (&Qdead, "dead");
- defsymbol (&Qdefault, "default");
- defsymbol (&Qdelete, "delete");
- defsymbol (&Qdelq, "delq");
- defsymbol (&Qdevice, "device");
- defsymbol (&Qdialog, "dialog");
- defsymbol (&Qdimension, "dimension");
- defsymbol (&Qdisplay, "display");
- defsymbol (&Qdoc_string, "doc-string");
- defsymbol (&Qduplex, "duplex");
- defsymbol (&Qdynarr_overhead, "dynarr-overhead");
- defsymbol (&Qempty, "empty");
- defsymbol (&Qeq, "eq");
- defsymbol (&Qeql, "eql");
- defsymbol (&Qequal, "equal");
- defsymbol (&Qeval, "eval");
- defsymbol (&Qextents, "extents");
- defsymbol (&Qface, "face");
- defsymbol (&Qfile_name, "file-name");
- defsymbol (&Qfont, "font");
- defsymbol (&Qframe, "frame");
- defsymbol (&Qfrom_page, "from-page");
- defsymbol (&Qfunction, "function");
- defsymbol (&Qfull_assoc, "full-assoc");
- defsymbol (&Qfuncall, "funcall");
- defsymbol (&Qfunction, "function");
- defsymbol (&Qgap_overhead, "gap-overhead");
- defsymbol (&Qgeneric, "generic");
- defsymbol (&Qgeometry, "geometry");
- defsymbol (&Qglobal, "global");
- defsymbol (&Qgutter, "gutter");
- defsymbol (&Qheight, "height");
- defsymbol (&Qhelp, "help");
- defsymbol (&Qhighlight, "highlight");
- defsymbol (&Qhorizontal, "horizontal");
- defsymbol (&Qicon, "icon");
- defsymbol (&Qid, "id");
- defsymbol (&Qignore, "ignore");
- defsymbol (&Qimage, "image");
- defsymbol (&Qinfo, "info");
- defsymbol (&Qinherit, "inherit");
- defsymbol (&Qinteger, "integer");
- defsymbol (&Qinternal, "internal");
- defsymbol (&Qkey, "key");
- defsymbol (&Qkey_assoc, "key-assoc");
- defsymbol (&Qkeyboard, "keyboard");
- defsymbol (&Qkeymap, "keymap");
- defsymbol (&Qlandscape, "landscape");
- defsymbol (&Qlast_command, "last-command");
- defsymbol (&Qleft, "left");
- defsymbol (&Qleft_margin, "left-margin");
- defsymbol (&Qlet, "let");
- defsymbol (&Qlist, "list");
- defsymbol (&Qmagic, "magic");
- defsymbol (&Qmalloc_overhead, "malloc-overhead");
- defsymbol (&Qmarkers, "markers");
- defsymbol (&Qmax, "max");
- defsymbol (&Qmemory, "memory");
- defsymbol (&Qmenubar, "menubar");
- defsymbol (&Qmessage, "message");
- defsymbol (&Qminus, "-");
- defsymbol (&Qmodifiers, "modifiers");
- defsymbol (&Qmotion, "motion");
- defsymbol (&Qmsprinter, "msprinter");
- defsymbol (&Qmswindows, "mswindows");
- defsymbol (&Qname, "name");
- defsymbol (&Qno, "no");
- defsymbol (&Qnone, "none");
- defsymbol (&Qnot, "not");
- defsymbol (&Qnothing, "nothing");
- defsymbol (&Qnotice, "notice");
- defsymbol (&Qobject, "object");
- defsymbol (&Qok, "ok");
- defsymbol (&Qold_assoc, "old-assoc");
- defsymbol (&Qold_delete, "old-delete");
- defsymbol (&Qold_delq, "old-delq");
- defsymbol (&Qold_rassoc, "old-rassoc");
- defsymbol (&Qold_rassq, "old-rassq");
- defsymbol (&Qonly, "only");
- defsymbol (&Qor, "or");
- defsymbol (&Qorientation, "orientation");
- defsymbol (&Qother, "other");
- defsymbol (&Qpointer, "pointer");
- defsymbol (&Qpopup, "popup");
- defsymbol (&Qportrait, "portrait");
- defsymbol (&Qprint, "print");
- defsymbol (&Qprinter, "printer");
- defsymbol (&Qprocess, "process");
- defsymbol (&Qprovide, "provide");
- defsymbol (&Qrassoc, "rassoc");
- defsymbol (&Qrassq, "rassq");
- defsymbol (&Qrequire, "require");
- defsymbol (&Qresource, "resource");
- defsymbol (&Qretry, "retry");
- defsymbol (&Qreturn, "return");
- defsymbol (&Qreverse, "reverse");
- defsymbol (&Qright, "right");
- defsymbol (&Qright_margin, "right-margin");
- defsymbol (&Qsearch, "search");
- defsymbol (&Qselected, "selected");
- defsymbol (&Qsignal, "signal");
- defsymbol (&Qsimple, "simple");
- defsymbol (&Qsize, "size");
- defsymbol (&Qspace, "space");
- defsymbol (&Qspecifier, "specifier");
- defsymbol (&Qstream, "stream");
- defsymbol (&Qstring, "string");
- defsymbol (&Qsymbol, "symbol");
- defsymbol (&Qsyntax, "syntax");
- defsymbol (&Qterminal, "terminal");
- defsymbol (&Qtest, "test");
- defsymbol (&Qtext, "text");
- defsymbol (&Qthis_command, "this-command");
- defsymbol (&Qtimeout, "timeout");
- defsymbol (&Qtimestamp, "timestamp");
- defsymbol (&Qtoolbar, "toolbar");
- defsymbol (&Qtop, "top");
- defsymbol (&Qtop_margin, "top-margin");
- defsymbol (&Qto_page, "to-page");
- defsymbol (&Qtty, "tty");
- defsymbol (&Qtype, "type");
- defsymbol (&Qundecided, "undecided");
- defsymbol (&Qundefined, "undefined");
- defsymbol (&Qunimplemented, "unimplemented");
- defsymbol (&Qvalue_assoc, "value-assoc");
- defsymbol (&Qvertical, "vertical");
- defsymbol (&Qwarning, "warning");
- defsymbol (&Qwidget, "widget");
- defsymbol (&Qwidth, "width");
- defsymbol (&Qwindow, "window");
- defsymbol (&Qwindow_system, "window-system");
- defsymbol (&Qx, "x");
- defsymbol (&Qy, "y");
- defsymbol (&Qyes, "yes");
+#define SYMBOL(loco) DEFSYMBOL (loco)
+#define SYMBOL_KEYWORD(meshugeneh) DEFKEYWORD (meshugeneh)
+#define SYMBOL_GENERAL(vachement, fou) defsymbol (&vachement, fou)
+
+#include "general-slots.h"
+
+#undef SYMBOL
+#undef SYMBOL_KEYWORD
+#undef SYMBOL_GENERAL
}
sony_news NEWS-OS (works at least for 4.1C)
UMAX
UMAX4_3
- WIN32_NATIVE No-op for Windows95/NT.
+ WIN32_NATIVE No-op for Windows9x/NT.
+ CYGWIN No-op for Cygwin.
__linux__ Linux: assumes /proc filesystem mounted.
Support from Michael K. Johnson.
__NetBSD__ NetBSD: assumes /kern filesystem mounted.
#include "lisp.h"
#include "sysfile.h" /* for encapsulated open, close, read, write */
-#ifndef WIN32_NATIVE
-#ifndef CYGWIN
-
-#include <sys/types.h>
-
-/* Both the Emacs and non-Emacs sections want this. Some
- configuration files' definitions for the LOAD_AVE_CVT macro (like
- sparc.h's) use macros like FSCALE, defined here. */
-#ifdef unix
-#include <sys/param.h>
-#endif
-
-
-/* Exclude all the code except the test program at the end
- if the system has its own `getloadavg' function.
-
- The declaration of `errno' is needed by the test program
- as well as the function itself, so it comes first. */
-
-#include <errno.h>
-
#ifndef HAVE_GETLOADAVG
/* The existing Emacs configuration files define a macro called
#include <sys/pstat.h>
#endif /* HAVE_SYS_PSTAT_H (on HPUX) */
-#if defined(HAVE_FCNTL_H) || defined(_POSIX_VERSION)
-#include <fcntl.h>
-#else
-#include <sys/file.h>
-#endif
\f
/* Avoid static vars inside a function since in HPUX they dump as pure. */
Return the number written (never more than 3, but may be less than NELEM),
or -1 if an error occurred. */
+int getloadavg (double loadavg[], int nelem);
+
int
getloadavg (double loadavg[], int nelem)
{
: (load_ave.tl_avenrun.l[0] / (double) load_ave.tl_lscale));
#endif /* OSF_MIPS */
-#if !defined (LDAV_DONE) && defined (WIN32_NATIVE)
+#if !defined (LDAV_DONE) && (defined (WIN32_NATIVE) || defined (CYGWIN))
#define LDAV_DONE
/* A faithful emulation is going to have to be saved for a rainy day. */
{
loadavg[elem] = 0.0;
}
-#endif /* WIN32_NATIVE */
+#endif /* WIN32_NATIVE or CYGWIN */
#if !defined (LDAV_DONE) && defined (OSF_ALPHA)
#define LDAV_DONE
exit (0);
}
#endif /* TEST */
-
-#else
-
-/* Emulate getloadavg. */
-int
-getloadavg (double loadavg[], int nelem)
-{
- int i;
-
- /* A faithful emulation is going to have to be saved for a rainy day. */
- for (i = 0; i < nelem; i++)
- {
- loadavg[i] = 0.0;
- }
- return i;
-}
-
-#endif /*__GNUWIN32__*/
-#endif /* WIN32_NATIVE */
static void init_image_instance_geometry (Lisp_Image_Instance *ii)
{
struct device *d = DOMAIN_XDEVICE (ii->domain);
-
+
if (/* #### Scaleable && */ DEVICE_MSPRINTER_P (d))
{
HDC printer_dc = DEVICE_MSPRINTER_HCDC (d);
IMAGE_INSTANCE_MSWINDOWS_BITMAP_REAL_WIDTH (ii);
IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) =
IMAGE_INSTANCE_MSWINDOWS_BITMAP_REAL_HEIGHT (ii);
- }
+ }
}
#define BPLINE(width) ((int)(~3UL & (unsigned long)((width) +3)))
}
#if 0 /* Currently unused */
-/* #### Warining: This function is not correct anymore with
+/* #### Warning: This function is not correct anymore with
resizable printer bitmaps. If you uncomment it, clean it. --kkm */
int
mswindows_resize_dibitmap_instance (Lisp_Image_Instance* ii,
}
static Lisp_Object
-bmp_normalize (Lisp_Object inst, Lisp_Object console_type)
+bmp_normalize (Lisp_Object inst, Lisp_Object console_type,
+ Lisp_Object dest_mask)
{
return simple_image_type_normalize (inst, console_type, Qbmp);
}
}
static Lisp_Object
-mswindows_resource_normalize (Lisp_Object inst, Lisp_Object console_type)
+mswindows_resource_normalize (Lisp_Object inst, Lisp_Object console_type,
+ Lisp_Object dest_mask)
{
/* This function can call lisp */
Lisp_Object file = Qnil;
signal_simple_error ("Invalid resource identifier", resource_id);
/* load the image */
- if (!(himage = LoadImage (hinst, resid, type, 0, 0,
- LR_CREATEDIBSECTION | LR_DEFAULTSIZE |
- LR_SHARED |
- (!NILP (file) ? LR_LOADFROMFILE : 0))))
+ if (xLoadImageA) /* not in NT 3.5 */
+ {
+ if (!(himage = xLoadImageA (hinst, resid, type, 0, 0,
+ LR_CREATEDIBSECTION | LR_DEFAULTSIZE |
+ LR_SHARED |
+ (!NILP (file) ? LR_LOADFROMFILE : 0))))
+ signal_simple_error ("Cannot load image", instantiator);
+ }
+ else
{
- signal_simple_error ("Cannot load image", instantiator);
+ /* Is this correct? I don't really care. */
+ switch (type)
+ {
+ case IMAGE_BITMAP:
+ himage = LoadBitmap (hinst, resid);
+ break;
+ case IMAGE_CURSOR:
+ himage = LoadCursor (hinst, resid);
+ break;
+ case IMAGE_ICON:
+ himage = LoadIcon (hinst, resid);
+ break;
+ }
+
+ if (!himage)
+ signal_simple_error ("Cannot load image", instantiator);
}
if (hinst)
static HDWP
begin_defer_window_pos (struct frame *f)
{
+#ifdef DEFER_WINDOW_POS
if (FRAME_MSWINDOWS_DATA (f)->hdwp == 0)
FRAME_MSWINDOWS_DATA (f)->hdwp = BeginDeferWindowPos (10);
+#endif
return FRAME_MSWINDOWS_DATA (f)->hdwp;
}
-
+
/* unmap the image if it is a widget. This is used by redisplay via
redisplay_unmap_subwindows */
static void
{
if (IMAGE_INSTANCE_SUBWINDOW_ID (p))
{
+#ifdef DEFER_WINDOW_POS
struct frame *f = XFRAME (IMAGE_INSTANCE_FRAME (p));
HDWP hdwp = begin_defer_window_pos (f);
HDWP new_hdwp;
else
hdwp = new_hdwp;
FRAME_MSWINDOWS_DATA (f)->hdwp = hdwp;
+#else
+ SetWindowPos (IMAGE_INSTANCE_MSWINDOWS_CLIPWINDOW (p),
+ NULL,
+ 0, 0, 0, 0,
+ SWP_HIDEWINDOW | SWP_NOACTIVATE |
+ SWP_NOMOVE | SWP_NOSIZE | SWP_NOZORDER );
+#endif
if (GetFocus() == WIDGET_INSTANCE_MSWINDOWS_HANDLE (p))
SetFocus (GetParent (IMAGE_INSTANCE_MSWINDOWS_CLIPWINDOW (p)));
}
mswindows_map_subwindow (Lisp_Image_Instance *p, int x, int y,
struct display_glyph_area* dga)
{
+#ifdef DEFER_WINDOW_POS
struct frame *f = XFRAME (IMAGE_INSTANCE_FRAME (p));
HDWP hdwp = begin_defer_window_pos (f);
HDWP new_hdwp;
+#endif
/* move the window before mapping it ... */
SetWindowPos (IMAGE_INSTANCE_MSWINDOWS_CLIPWINDOW (p),
NULL,
SWP_NOZORDER | SWP_NOSIZE
| SWP_NOCOPYBITS | SWP_NOSENDCHANGING);
/* ... now map it - we are not allowed to move it at the same time. */
- new_hdwp = DeferWindowPos (hdwp, IMAGE_INSTANCE_MSWINDOWS_CLIPWINDOW (p),
- NULL,
- 0, 0, 0, 0,
- SWP_NOZORDER | SWP_NOSIZE | SWP_NOMOVE
- | SWP_SHOWWINDOW
- /* | SWP_NOCOPYBITS */
- /* Setting this flag causes the call to
- DeferWindowPos to fail with
- "Invalid parameter". I don't understand
- why we bother to try and set this
- anyway. -- ben */
- /* | SWP_NOSENDCHANGING */
- | SWP_NOACTIVATE);
- if (!new_hdwp)
- mswindows_output_last_error ("mapping");
- else
- hdwp = new_hdwp;
- FRAME_MSWINDOWS_DATA (f)->hdwp = hdwp;
+ if (!IMAGE_INSTANCE_SUBWINDOW_DISPLAYEDP (p))
+ {
+#ifdef DEFER_WINDOW_POS
+ new_hdwp = DeferWindowPos
+ (hdwp,
+ IMAGE_INSTANCE_MSWINDOWS_CLIPWINDOW (p),
+ NULL, 0, 0, 0, 0,
+ SWP_NOZORDER | SWP_NOSIZE | SWP_NOMOVE
+ | SWP_SHOWWINDOW
+ /* | SWP_NOCOPYBITS */
+ /* Setting this flag causes the call to
+ DeferWindowPos to fail with
+ "Invalid parameter". I don't understand
+ why we bother to try and set this
+ anyway. -- ben */
+ /* | SWP_NOSENDCHANGING */
+ | SWP_NOACTIVATE);
+ if (!new_hdwp)
+ mswindows_output_last_error ("mapping");
+ else
+ hdwp = new_hdwp;
+ FRAME_MSWINDOWS_DATA (f)->hdwp = hdwp;
+#else
+ SetWindowPos (IMAGE_INSTANCE_MSWINDOWS_CLIPWINDOW (p),
+ NULL,
+ 0, 0, 0, 0,
+ SWP_NOZORDER | SWP_NOSIZE | SWP_NOMOVE
+ | SWP_SHOWWINDOW | SWP_NOCOPYBITS | SWP_NOACTIVATE);
+#endif
+ }
}
/* resize the subwindow instance */
/* Simply resize the window here. */
static void
-mswindows_update_subwindow (Lisp_Image_Instance *p)
+mswindows_redisplay_subwindow (Lisp_Image_Instance *p)
{
mswindows_resize_subwindow (p,
IMAGE_INSTANCE_WIDTH (p),
/* when you click on a widget you may activate another widget this
needs to be checked and all appropriate widgets updated */
static void
-mswindows_update_widget (Lisp_Image_Instance *p)
+mswindows_redisplay_widget (Lisp_Image_Instance *p)
{
/* Possibly update the face font and colors. */
if (!NILP (IMAGE_INSTANCE_WIDGET_TEXT (p))
/* Possibly update the dimensions. */
if (IMAGE_INSTANCE_SIZE_CHANGED (p))
{
- mswindows_resize_subwindow (p,
+ mswindows_resize_subwindow (p,
IMAGE_INSTANCE_WIDTH (p),
IMAGE_INSTANCE_HEIGHT (p));
}
}
}
-/* register widgets into our hastable so that we can cope with the
+/* register widgets into our hashtable so that we can cope with the
callbacks. The hashtable is weak so deregistration is handled
automatically */
static int
SendMessage (wnd, WM_SETFONT,
(WPARAM) mswindows_widget_hfont (ii, domain),
MAKELPARAM (TRUE, 0));
+#if 0
+ /* #### doesn't work. need to investigate more closely. */
+ if (IMAGE_INSTANCE_WANTS_INITIAL_FOCUS (ii))
+ SetFocus (wnd);
+#endif
}
/* Instantiate a native layout widget. */
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
mswindows_widget_instantiate (image_instance, instantiator, pointer_fg,
- pointer_bg, dest_mask, domain, "STATIC",
+ pointer_bg, dest_mask, domain, "STATIC",
/* Approximation to styles available with
an XEmacs layout. */
- EQ (IMAGE_INSTANCE_LAYOUT_BORDER (ii),
- Qetched_in) ||
- EQ (IMAGE_INSTANCE_LAYOUT_BORDER (ii),
- Qetched_out) ||
- GLYPHP (IMAGE_INSTANCE_LAYOUT_BORDER (ii))
- ? SS_ETCHEDFRAME : SS_SUNKEN,
+ (EQ (IMAGE_INSTANCE_LAYOUT_BORDER (ii),
+ Qetched_in) ||
+ EQ (IMAGE_INSTANCE_LAYOUT_BORDER (ii),
+ Qetched_out) ||
+ GLYPHP (IMAGE_INSTANCE_LAYOUT_BORDER (ii))
+ ? SS_ETCHEDFRAME : SS_SUNKEN) | DS_CONTROL,
0);
}
/* Update the state of a button. */
static void
-mswindows_button_update (Lisp_Object image_instance)
+mswindows_button_redisplay (Lisp_Object image_instance)
{
/* This function can GC if IN_REDISPLAY is false. */
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
{
HWND wnd;
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
+ Lisp_Object val;
mswindows_widget_instantiate (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain, PROGRESS_CLASS,
WS_BORDER | PBS_SMOOTH, WS_EX_CLIENTEDGE);
(XIMAGE_INSTANCE_WIDGET_FACE (ii),
XIMAGE_INSTANCE_FRAME (ii))))));
#endif
+ val = XGUI_ITEM (IMAGE_INSTANCE_WIDGET_ITEMS (ii))->value;
+ CHECK_INT (val);
+ SendMessage (WIDGET_INSTANCE_MSWINDOWS_HANDLE (ii),
+ PBM_SETPOS, (WPARAM)XINT (val), 0);
}
/* instantiate a tree view widget */
}
}
+/* Set the properties of a tree view. */
+static void
+mswindows_tree_view_redisplay (Lisp_Object image_instance)
+{
+ /* This function can GC if IN_REDISPLAY is false. */
+ Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
+
+ if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii))
+ {
+ HWND wnd = WIDGET_INSTANCE_MSWINDOWS_HANDLE (ii);
+ Lisp_Object rest;
+ HTREEITEM parent;
+ /* Delete previous items. */
+ SendMessage (wnd, TVM_DELETEITEM, 0, (LPARAM)TVI_ROOT);
+ /* define a root */
+ parent = add_tree_item (image_instance, wnd, NULL,
+ XCAR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)),
+ TRUE, IMAGE_INSTANCE_DOMAIN (ii));
+
+ /* recursively add items to the tree view */
+ /* add items to the tab */
+ LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)))
+ {
+ if (LISTP (XCAR (rest)))
+ add_tree_item_list (image_instance, wnd, parent, XCAR (rest),
+ IMAGE_INSTANCE_DOMAIN (ii));
+ else
+ add_tree_item (image_instance, wnd, parent, XCAR (rest), FALSE,
+ IMAGE_INSTANCE_DOMAIN (ii));
+ }
+ }
+}
+
/* instantiate a tab control */
-static TC_ITEM* add_tab_item (Lisp_Object image_instance,
- HWND wnd, Lisp_Object item,
- Lisp_Object domain, int i)
+static int
+add_tab_item (Lisp_Object image_instance,
+ HWND wnd, Lisp_Object item,
+ Lisp_Object domain, int i)
{
- TC_ITEM tvitem, *ret;
+ TC_ITEM tvitem;
+ int ret = 0;
tvitem.mask = TCIF_TEXT;
tvitem.cchTextMax = strlen (tvitem.pszText);
- if ((ret = (TC_ITEM*)SendMessage (wnd, TCM_INSERTITEM,
- i, (LPARAM)&tvitem)) < 0)
+ if ((ret = SendMessage (wnd, TCM_INSERTITEM,
+ i, (LPARAM)&tvitem)) < 0)
signal_simple_error ("error adding tab entry", item);
return ret;
/* add items to the tab */
LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)))
{
- add_tab_item (image_instance, wnd, XCAR (rest), domain, i);
+ int idx = add_tab_item (image_instance, wnd, XCAR (rest), domain, i);
+ assert (idx == i);
if (gui_item_selected_p (XCAR (rest)))
selected = i;
i++;
SendMessage (wnd, TCM_SETCURSEL, selected, 0);
}
-/* set the properties of a tab control */
+/* Set the properties of a tab control. */
static void
-mswindows_tab_control_update (Lisp_Object image_instance)
+mswindows_tab_control_redisplay (Lisp_Object image_instance)
{
/* This function can GC if IN_REDISPLAY is false. */
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
-
- if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii))
+#ifdef DEBUG_WIDGET_OUTPUT
+ stderr_out ("tab control %p redisplayed\n", IMAGE_INSTANCE_SUBWINDOW_ID (ii));
+#endif
+ if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii)
+ ||
+ IMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (ii))
{
HWND wnd = WIDGET_INSTANCE_MSWINDOWS_HANDLE (ii);
int i = 0, selected = 0;
Lisp_Object rest;
- /* delete the pre-existing items */
- SendMessage (wnd, TCM_DELETEALLITEMS, 0, 0);
+ assert (!NILP (IMAGE_INSTANCE_WIDGET_ITEMS (ii)));
- /* add items to the tab */
- LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)))
+ /* If only the order has changed then simply select the first
+ one. This stops horrendous rebuilding of the tabs each time
+ you click on one. */
+ if (tab_control_order_only_changed (image_instance))
{
- add_tab_item (image_instance, wnd, XCAR (rest),
- IMAGE_INSTANCE_FRAME (ii), i);
- if (gui_item_selected_p (XCAR (rest)))
- selected = i;
- i++;
+ Lisp_Object selected =
+ gui_item_list_find_selected
+ (NILP (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)) ?
+ XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)) :
+ XCDR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)));
+
+ LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)))
+ {
+ if (gui_item_equal_sans_selected (XCAR (rest), selected, 0))
+ {
+ Lisp_Object old_selected = gui_item_list_find_selected
+ (XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)));
+
+ /* Pick up the new selected item. */
+ XGUI_ITEM (old_selected)->selected =
+ XGUI_ITEM (XCAR (rest))->selected;
+ XGUI_ITEM (XCAR (rest))->selected =
+ XGUI_ITEM (selected)->selected;
+ /* We're not actually changing the items. */
+ IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii) = 0;
+ IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii) = Qnil;
+
+ SendMessage (wnd, TCM_SETCURSEL, i, 0);
+#ifdef DEBUG_WIDGET_OUTPUT
+ stderr_out ("tab control %p selected item %d\n",
+ IMAGE_INSTANCE_SUBWINDOW_ID (ii), i);
+#endif
+ break;
+ }
+ i++;
+ }
+ }
+ else
+ {
+ /* delete the pre-existing items */
+ SendMessage (wnd, TCM_DELETEALLITEMS, 0, 0);
+
+ /* add items to the tab */
+ LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)))
+ {
+ add_tab_item (image_instance, wnd, XCAR (rest),
+ IMAGE_INSTANCE_FRAME (ii), i);
+ if (gui_item_selected_p (XCAR (rest)))
+ selected = i;
+ i++;
+ }
+ SendMessage (wnd, TCM_SETCURSEL, selected, 0);
}
- SendMessage (wnd, TCM_SETCURSEL, selected, 0);
}
}
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
HWND wnd;
Lisp_Object rest;
- Lisp_Object data = Fplist_get (find_keyword_in_vector (instantiator, Q_properties),
- Q_items, Qnil);
+ Lisp_Object items = find_keyword_in_vector (instantiator, Q_items);
int len, height;
/* Maybe ought to generalise this more but it may be very windows
/* We now have everything right apart from the height. */
default_face_font_info (domain, 0, 0, &height, 0, 0);
- GET_LIST_LENGTH (data, len);
+ GET_LIST_LENGTH (items, len);
height = (height + WIDGET_BORDER_HEIGHT * 2 ) * len;
IMAGE_INSTANCE_HEIGHT (ii) = height;
image_instance_layout (image_instance,
IMAGE_UNSPECIFIED_GEOMETRY,
IMAGE_UNSPECIFIED_GEOMETRY,
+ IMAGE_UNCHANGED_GEOMETRY,
+ IMAGE_UNCHANGED_GEOMETRY,
domain);
wnd = WIDGET_INSTANCE_MSWINDOWS_HANDLE (ii);
/* add items to the combo box */
SendMessage (wnd, CB_RESETCONTENT, 0, 0);
- LIST_LOOP (rest, Fplist_get (IMAGE_INSTANCE_WIDGET_PROPS (ii), Q_items, Qnil))
+ LIST_LOOP (rest, items)
{
Extbyte* lparam;
TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (rest),
return Qunbound;
}
-/* set the properties of a progres guage */
+/* set the properties of a progress gauge */
static void
-mswindows_progress_gauge_update (Lisp_Object image_instance)
+mswindows_progress_gauge_redisplay (Lisp_Object image_instance)
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
-
+
if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii))
{
Lisp_Object val;
assert (GUI_ITEMP (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)));
#endif
val = XGUI_ITEM (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii))->value;
-#ifdef DEBUG_WIDGET_OUTPUT
- printf ("progress gauge displayed value on %p updated to %ld\n",
- WIDGET_INSTANCE_MSWINDOWS_HANDLE (ii),
- XINT(val));
+#ifdef DEBUG_WIDGET_OUTPUT
+ stderr_out ("progress gauge displayed value on %p updated to %ld\n",
+ WIDGET_INSTANCE_MSWINDOWS_HANDLE (ii),
+ XINT(val));
#endif
CHECK_INT (val);
SendMessage (WIDGET_INSTANCE_MSWINDOWS_HANDLE (ii),
CONSOLE_HAS_METHOD (mswindows, finalize_image_instance);
CONSOLE_HAS_METHOD (mswindows, unmap_subwindow);
CONSOLE_HAS_METHOD (mswindows, map_subwindow);
- CONSOLE_HAS_METHOD (mswindows, update_subwindow);
+ CONSOLE_HAS_METHOD (mswindows, redisplay_subwindow);
CONSOLE_HAS_METHOD (mswindows, resize_subwindow);
- CONSOLE_HAS_METHOD (mswindows, update_widget);
+ CONSOLE_HAS_METHOD (mswindows, redisplay_widget);
CONSOLE_HAS_METHOD (mswindows, image_instance_equal);
CONSOLE_HAS_METHOD (mswindows, image_instance_hash);
CONSOLE_HAS_METHOD (mswindows, init_image_instance_from_eimage);
INITIALIZE_DEVICE_IIFORMAT (mswindows, button);
IIFORMAT_HAS_DEVMETHOD (mswindows, button, property);
IIFORMAT_HAS_DEVMETHOD (mswindows, button, instantiate);
- IIFORMAT_HAS_DEVMETHOD (mswindows, button, update);
+ IIFORMAT_HAS_DEVMETHOD (mswindows, button, redisplay);
/* edit-field widget */
INITIALIZE_DEVICE_IIFORMAT (mswindows, edit_field);
IIFORMAT_HAS_DEVMETHOD (mswindows, edit_field, instantiate);
IIFORMAT_HAS_DEVMETHOD (mswindows, scrollbar, instantiate);
/* progress gauge */
INITIALIZE_DEVICE_IIFORMAT (mswindows, progress_gauge);
- IIFORMAT_HAS_DEVMETHOD (mswindows, progress_gauge, update);
+ IIFORMAT_HAS_DEVMETHOD (mswindows, progress_gauge, redisplay);
IIFORMAT_HAS_DEVMETHOD (mswindows, progress_gauge, instantiate);
/* tree view widget */
INITIALIZE_DEVICE_IIFORMAT (mswindows, tree_view);
- /* IIFORMAT_HAS_DEVMETHOD (mswindows, progress, set_property);*/
IIFORMAT_HAS_DEVMETHOD (mswindows, tree_view, instantiate);
+ IIFORMAT_HAS_DEVMETHOD (mswindows, tree_view, redisplay);
/* tab control widget */
INITIALIZE_DEVICE_IIFORMAT (mswindows, tab_control);
IIFORMAT_HAS_DEVMETHOD (mswindows, tab_control, instantiate);
- IIFORMAT_HAS_DEVMETHOD (mswindows, tab_control, update);
+ IIFORMAT_HAS_DEVMETHOD (mswindows, tab_control, redisplay);
#endif
/* windows bitmap format */
INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (bmp, "bmp");
DEFINE_IMAGE_INSTANTIATOR_FORMAT (native_layout);
Lisp_Object Qnative_layout;
-Lisp_Object Q_descriptor, Q_height, Q_width, Q_properties, Q_items;
-Lisp_Object Q_image, Q_text, Q_orientation, Q_justify, Q_border;
-Lisp_Object Q_margin_width;
Lisp_Object Qetched_in, Qetched_out, Qbevel_in, Qbevel_out;
+Lisp_Object Qmake_glyph;
#ifdef DEBUG_WIDGETS
int debug_widget_instances;
}
static void
-check_valid_glyph_or_instantiator (Lisp_Object data)
+check_valid_instantiator (Lisp_Object data)
{
Lisp_Object glyph = data;
if (SYMBOLP (data))
glyph = XSYMBOL (data)->value;
- if (IMAGE_INSTANCEP (glyph))
- CHECK_IMAGE_INSTANCE (glyph);
- else if (!CONSP (glyph) && !VECTORP (glyph))
- CHECK_BUFFER_GLYPH (glyph);
+ if (!CONSP (glyph) && !VECTORP (glyph))
+ invalid_argument ("instantiator item must be a vector", data);
}
static void
if (!EQ (data, Qhorizontal)
&&
!EQ (data, Qvertical))
- signal_simple_error ("unknown orientation for layout", data);
+ invalid_argument ("unknown orientation for layout", data);
}
static void
!EQ (data, Qleft)
&&
!EQ (data, Qright))
- signal_simple_error ("unknown orientation for tab control", data);
+ invalid_argument ("unknown orientation for tab control", data);
}
static void
check_valid_justification (Lisp_Object data)
{
if (!EQ (data, Qleft) && !EQ (data, Qright) && !EQ (data, Qcenter))
- signal_simple_error ("unknown justification for layout", data);
+ invalid_argument ("unknown justification for layout", data);
}
static void
if (!EQ (data, Qt) && !EQ (data, Qetched_in) && !EQ (data, Qetched_out)
&& !EQ (data, Qbevel_in) && !EQ (data, Qbevel_out)
&& !GLYPHP (data) && !VECTORP (data))
- signal_simple_error ("unknown border style for layout", data);
+ invalid_argument ("unknown border style for layout", data);
}
static void
&& !COMPILED_FUNCTIONP (data)
&& !CONSP (data))
{
- signal_simple_error (":callback must be a function or expression", data);
+ invalid_argument (":callback must be a function or expression", data);
}
}
check_valid_int_or_function (Lisp_Object data)
{
if (!INTP (data) && !CONSP (data))
- signal_simple_error ("must be an integer or expresssion", data);
+ invalid_argument ("must be an integer or expresssion", data);
}
static void
check_valid_string_or_vector (Lisp_Object data)
{
if (!STRINGP (data) && !VECTORP (data))
- signal_simple_error (":descriptor must be a string or a vector", data);
+ invalid_argument (":descriptor must be a string or a vector", data);
}
void
-check_valid_item_list_1 (Lisp_Object items)
+check_valid_item_list (Lisp_Object items)
{
Lisp_Object rest;
else if (VECTORP (XCAR (rest)))
gui_parse_item_keywords (XCAR (rest));
else if (LISTP (XCAR (rest)))
- check_valid_item_list_1 (XCAR (rest));
+ check_valid_item_list (XCAR (rest));
else
- signal_simple_error ("Items must be vectors, lists or strings", items);
+ invalid_argument ("Items must be vectors, lists or strings", items);
}
}
static void
-check_valid_item_list (Lisp_Object data)
-{
- Lisp_Object items;
-
- Fcheck_valid_plist (data);
- items = Fplist_get (data, Q_items, Qnil);
-
- check_valid_item_list_1 (items);
-}
-
-static void
-check_valid_glyph_or_instantiator_list (Lisp_Object data)
+check_valid_instantiator_list (Lisp_Object data)
{
Lisp_Object rest;
CHECK_LIST (data);
EXTERNAL_LIST_LOOP (rest, data)
{
- check_valid_glyph_or_instantiator (XCAR (rest));
+ check_valid_instantiator (XCAR (rest));
}
}
/* This function calls lisp. */
Lisp_Object glyph = sym;
struct gcpro gcpro1;
-
+
GCPRO1 (glyph);
/* if we have a symbol get at the actual data */
if (SYMBOLP (glyph))
glyph = XSYMBOL (glyph)->value;
-
+
if (CONSP (glyph))
glyph = Feval (glyph);
/* Be really helpful to the user. */
if (VECTORP (glyph))
{
- glyph = call1 (intern ("make-glyph"), glyph);
+ glyph = call1 (Qmake_glyph, glyph);
}
/* substitute the new glyph */
RETURN_UNGCPRO (glyph);
}
-static void
+static void
substitute_keyword_value (Lisp_Object inst, Lisp_Object key, Lisp_Object val)
{
int i;
type (Qedit_field for example). It is debatable whether we should
wire things in this generalised way rather than treating widgets
specially in image_instance_property. */
-static Lisp_Object
+static Lisp_Object
widget_property (Lisp_Object image_instance, Lisp_Object prop)
{
Lisp_Image_Instance* ii = XIMAGE_INSTANCE (image_instance);
struct image_instantiator_methods* meths;
-
+#if 0 /* The usefulness of this is dubious. */
/* first see if its a general property ... */
if (!NILP (Fplist_member (IMAGE_INSTANCE_WIDGET_PROPS (ii), prop)))
return Fplist_get (IMAGE_INSTANCE_WIDGET_PROPS (ii), prop, Qnil);
-
+#endif
/* .. then try device specific methods ... */
meths = decode_device_ii_format (image_instance_device (image_instance),
- IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
if (meths && HAS_IIFORMAT_METH_P (meths, property))
return IIFORMAT_METH (meths, property, (image_instance, prop));
/* ... then format specific methods ... */
- meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
if (meths && HAS_IIFORMAT_METH_P (meths, property))
return IIFORMAT_METH (meths, property, (image_instance, prop));
return Qunbound;
}
-static Lisp_Object
-widget_set_property (Lisp_Object image_instance, Lisp_Object prop, Lisp_Object val)
+/* Update the displayed properties of a widget.
+
+ #### This has been adapted from the original set_property functions
+ and thus reuses the state management of that. A better solution is
+ to simply re-parse the instantiator when items need updating. This
+ make comparing differences much simpler and obviates the need for a
+ lot of the state variables.
+
+ #### property is still a valid function since we have to be able to
+ extract information from the actual widget.
+
+ #### update_widget should probably be re-written to use the
+ instantiator. We probably want to keep a record of the differences
+ also to make this easy. We would also need a pending_instantiator
+ so that changes could be delayed. */
+static void
+widget_update (Lisp_Object image_instance, Lisp_Object instantiator)
{
Lisp_Image_Instance* ii = XIMAGE_INSTANCE (image_instance);
struct image_instantiator_methods* meths;
- Lisp_Object ret;
- /* PIck up any generic properties that we might need to keep hold
+ Lisp_Object text = find_keyword_in_vector (instantiator, Q_text);
+ /* Pick up any generic properties that we might need to keep hold
of. */
- if (EQ (prop, Q_text))
+ if (!NILP (text))
{
- IMAGE_INSTANCE_WIDGET_TEXT (ii) = val;
+ IMAGE_INSTANCE_WIDGET_TEXT (ii) = text;
IMAGE_INSTANCE_TEXT_CHANGED (ii) = 1;
}
/* Now try device specific methods first ... */
- meths = decode_device_ii_format (image_instance_device (image_instance),
- IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ meths = decode_device_ii_format (image_instance_device (image_instance),
+ IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
- if (meths && HAS_IIFORMAT_METH_P (meths, set_property)
- &&
- !UNBOUNDP (ret =
- IIFORMAT_METH (meths, set_property, (image_instance, prop, val))))
- {
- return ret;
- }
+ MAYBE_IIFORMAT_METH (meths, update, (image_instance, instantiator));
/* ... then format specific methods ... */
- meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
- if (meths && HAS_IIFORMAT_METH_P (meths, set_property)
- &&
- !UNBOUNDP (ret =
- IIFORMAT_METH (meths, set_property, (image_instance, prop, val))))
- {
- return ret;
- }
- /* we didn't do any device specific properties, so shove the property in our plist */
+ MAYBE_IIFORMAT_METH (meths, update, (image_instance, instantiator));
+#if 0 /* The usefulness of this is dubious. */
+ /* we didn't do any device specific properties, so shove the property in our plist. */
IMAGE_INSTANCE_WIDGET_PROPS (ii)
= Fplist_put (IMAGE_INSTANCE_WIDGET_PROPS (ii), prop, val);
- return val;
+#endif
}
/* Like the rest of redisplay, we want widget updates to occur
asynchronously. Thus toolkit specific methods for setting
- properties must be called by redisplay instead of by
- *_set_property. Thus *_set_property records the change and this
- function actually implements it. We want to be slightly clever
- about this however by supplying format specific functions for the
- updates instead of lumping them all into this function. Note that
- there is no need for format generic functions. */
+ properties must be called by redisplay instead of by *_update. Thus
+ *_update records the change and this function actually implements
+ it. We want to be slightly clever about this however by supplying
+ format specific functions for the updates instead of lumping them
+ all into this function. Note that there is no need for format
+ generic functions. This is not the same as widget_update! */
void
-update_widget (Lisp_Object widget)
+redisplay_widget (Lisp_Object widget)
{
Lisp_Image_Instance* ii = XIMAGE_INSTANCE (widget);
struct image_instantiator_methods* meths;
|| EQ (IMAGE_INSTANCE_WIDGET_TYPE (ii), Qnative_layout))
return;
- /* Device generic methods. We must update the widget's size as it
- may have been changed by the the layout routines. We also do this
- here so that explicit resizing from lisp does not result in
- synchronous updates. */
- MAYBE_DEVMETH (DOMAIN_XDEVICE (ii->domain), update_widget, (ii));
-
- /* Device-format specific methods */
+ /* Device-format specific methods - e.g. x_tab_control_redisplay () */
meths = decode_device_ii_format (image_instance_device (widget),
IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
- MAYBE_IIFORMAT_METH (meths, update, (widget));
+ MAYBE_IIFORMAT_METH (meths, redisplay, (widget));
+
+ /* Device generic methods - e.g. x_redisplay_widget (). We must
+ update the widget's size as it may have been changed by the the
+ layout routines. We also do this here so that explicit resizing
+ from lisp does not result in synchronous updates. Do this last so
+ that format-specific methods have an opportunity to prevent
+ wholesale changes - e.g. rebuilding tabs. */
+ MAYBE_DEVMETH (DOMAIN_XDEVICE (ii->domain), redisplay_widget, (ii));
/* Pick up the items we recorded earlier. */
if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii))
/* Query for a widgets desired geometry. If no type specific method is
provided then use the widget text to calculate sizes. */
-static void
-widget_query_geometry (Lisp_Object image_instance,
+static void
+widget_query_geometry (Lisp_Object image_instance,
int* width, int* height,
enum image_instance_geometry disp, Lisp_Object domain)
{
/* First just set up what we already have. */
if (width) *width = IMAGE_INSTANCE_WIDTH (ii);
if (height) *height = IMAGE_INSTANCE_HEIGHT (ii);
-
+
if (IMAGE_INSTANCE_SUBWINDOW_V_RESIZEP (ii)
||
IMAGE_INSTANCE_SUBWINDOW_H_RESIZEP (ii))
{
/* .. then try device specific methods ... */
meths = decode_device_ii_format (image_instance_device (image_instance),
- IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
if (meths && HAS_IIFORMAT_METH_P (meths, query_geometry))
- IIFORMAT_METH (meths, query_geometry, (image_instance,
+ IIFORMAT_METH (meths, query_geometry, (image_instance,
width, height, disp,
domain));
else
{
/* ... then format specific methods ... */
- meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
if (meths && HAS_IIFORMAT_METH_P (meths, query_geometry))
- IIFORMAT_METH (meths, query_geometry, (image_instance,
+ IIFORMAT_METH (meths, query_geometry, (image_instance,
width, height, disp,
domain));
- else
+ else
{
int w, h;
-
+
/* Then if we are allowed to resize the widget, make the
size the same as the text dimensions. */
query_string_geometry (IMAGE_INSTANCE_WIDGET_TEXT (ii),
}
}
-static int
-widget_layout (Lisp_Object image_instance,
- int width, int height, Lisp_Object domain)
+static int
+widget_layout (Lisp_Object image_instance,
+ int width, int height, int xoffset, int yoffset,
+ Lisp_Object domain)
{
Lisp_Image_Instance* ii = XIMAGE_INSTANCE (image_instance);
struct image_instantiator_methods* meths;
/* .. then try device specific methods ... */
meths = decode_device_ii_format (image_instance_device (image_instance),
- IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
if (meths && HAS_IIFORMAT_METH_P (meths, layout))
- return IIFORMAT_METH (meths, layout, (image_instance,
- width, height, domain));
+ return IIFORMAT_METH (meths, layout, (image_instance,
+ width, height, xoffset, yoffset,
+ domain));
else
{
/* ... then format specific methods ... */
- meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
+ meths = decode_device_ii_format (Qnil, IMAGE_INSTANCE_WIDGET_TYPE (ii),
ERROR_ME_NOT);
if (meths && HAS_IIFORMAT_METH_P (meths, layout))
- return IIFORMAT_METH (meths, layout, (image_instance,
- width, height, domain));
+ return IIFORMAT_METH (meths, layout, (image_instance,
+ width, height, xoffset, yoffset,
+ domain));
}
return 1;
}
Lisp_Object desc = find_keyword_in_vector (instantiator, Q_descriptor);
if (NILP (desc))
- signal_simple_error ("Must supply :descriptor", instantiator);
+ syntax_error ("Must supply :descriptor", instantiator);
if (VECTORP (desc))
gui_parse_item_keywords (desc);
if (!NILP (find_keyword_in_vector (instantiator, Q_width))
&& !NILP (find_keyword_in_vector (instantiator, Q_pixel_width)))
- signal_simple_error ("Must supply only one of :width and :pixel-width", instantiator);
+ syntax_error ("Must supply only one of :width and :pixel-width", instantiator);
if (!NILP (find_keyword_in_vector (instantiator, Q_height))
&& !NILP (find_keyword_in_vector (instantiator, Q_pixel_height)))
- signal_simple_error ("Must supply only one of :height and :pixel-height", instantiator);
+ syntax_error ("Must supply only one of :height and :pixel-height", instantiator);
}
static void
combo_box_validate (Lisp_Object instantiator)
{
widget_validate (instantiator);
- if (NILP (find_keyword_in_vector (instantiator, Q_properties)))
- signal_simple_error ("Must supply item list", instantiator);
+ if (NILP (find_keyword_in_vector (instantiator, Q_items)))
+ syntax_error ("Must supply item list", instantiator);
}
/* we need to convert things like glyphs to images, eval expressions
etc.*/
static Lisp_Object
-widget_normalize (Lisp_Object inst, Lisp_Object console_type)
+widget_normalize (Lisp_Object inst, Lisp_Object console_type,
+ Lisp_Object dest_mask)
{
/* This function can call lisp */
Lisp_Object glyph = find_keyword_in_vector (inst, Q_image);
/* we need to eval glyph if its an expression, we do this for the
- same reasons we normalize file to data. */
+ same reasons we normalize file to data.
+
+ #### should just normalize the data. */
if (!NILP (glyph))
{
substitute_keyword_value (inst, Q_image, glyph_instantiator_to_glyph (glyph));
Lisp_Object pointer_fg, Lisp_Object pointer_bg,
int dest_mask, Lisp_Object domain)
{
+ /* #### practically all of this should be moved to widget_update()
+ so that users can dynamically change all possible widget
+ properties. */
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object face = find_keyword_in_vector (instantiator, Q_face);
Lisp_Object height = find_keyword_in_vector (instantiator, Q_height);
Lisp_Object pixheight = find_keyword_in_vector (instantiator, Q_pixel_height);
Lisp_Object desc = find_keyword_in_vector (instantiator, Q_descriptor);
Lisp_Object glyph = find_keyword_in_vector (instantiator, Q_image);
- Lisp_Object props = find_keyword_in_vector (instantiator, Q_properties);
Lisp_Object items = find_keyword_in_vector (instantiator, Q_items);
Lisp_Object orient = find_keyword_in_vector (instantiator, Q_orientation);
Lisp_Object mwidth = find_keyword_in_vector (instantiator, Q_margin_width);
+ Lisp_Object ifocus = find_keyword_in_vector (instantiator, Q_initial_focus);
int pw=0, ph=0, tw=0, th=0;
-
+
/* this just does pixel type sizing */
subwindow_instantiate (image_instance, instantiator, pointer_fg, pointer_bg,
dest_mask, domain);
-
+
if (!(dest_mask & IMAGE_WIDGET_MASK))
incompatible_image_types (instantiator, dest_mask, IMAGE_WIDGET_MASK);
initialize_widget_image_instance (ii, XVECTOR_DATA (instantiator)[0]);
IMAGE_INSTANCE_TYPE (ii) = IMAGE_WIDGET;
- IMAGE_INSTANCE_WIDGET_PROPS (ii) = props;
/* retrieve the fg and bg colors */
if (!NILP (face))
SET_IMAGE_INSTANCE_WIDGET_FACE (ii, Fget_face (face));
-
+
/* retrieve the gui item information. This is easy if we have been
provided with a vector, more difficult if we have just been given
keywords */
if (STRINGP (desc) || NILP (desc))
{
/* big cheat - we rely on the fact that a gui item looks like an instantiator */
- IMAGE_INSTANCE_WIDGET_ITEMS (ii) =
+ IMAGE_INSTANCE_WIDGET_ITEMS (ii) =
gui_parse_item_keywords_no_errors (instantiator);
IMAGE_INSTANCE_WIDGET_TEXT (ii) = desc;
}
else
IMAGE_INSTANCE_WIDGET_ITEMS (ii) =
gui_parse_item_keywords_no_errors (desc);
-
+
/* Pick up the orientation before we do our first layout. */
if (EQ (orient, Qleft) || EQ (orient, Qright) || EQ (orient, Qvertical))
IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii) = LAYOUT_VERTICAL;
/* parse more gui items out of the properties */
- if (!NILP (props)
- &&
- !EQ (IMAGE_INSTANCE_WIDGET_TYPE (ii), Qlayout)
+ if (!NILP (items) && !EQ (IMAGE_INSTANCE_WIDGET_TYPE (ii), Qlayout)
&& !EQ (IMAGE_INSTANCE_WIDGET_TYPE (ii), Qnative_layout))
{
- if (NILP (items))
- {
- items = Fplist_get (props, Q_items, Qnil);
- }
- if (!NILP (items))
- {
- IMAGE_INSTANCE_WIDGET_ITEMS (ii) =
- Fcons (IMAGE_INSTANCE_WIDGET_ITEMS (ii),
- parse_gui_item_tree_children (items));
- }
+ IMAGE_INSTANCE_WIDGET_ITEMS (ii) =
+ Fcons (IMAGE_INSTANCE_WIDGET_ITEMS (ii),
+ parse_gui_item_tree_children (items));
}
/* Normalize size information. We now only assign sizes if the user
if (!NILP (glyph))
{
if (!pw)
- pw = glyph_width (glyph, domain) + 2 * WIDGET_BORDER_WIDTH;
+ pw = glyph_width (glyph, image_instance) + 2 * WIDGET_BORDER_WIDTH;
if (!ph)
- ph = glyph_height (glyph, domain) + 2 * WIDGET_BORDER_HEIGHT;
+ ph = glyph_height (glyph, image_instance) + 2 * WIDGET_BORDER_HEIGHT;
IMAGE_INSTANCE_SUBWINDOW_V_RESIZEP (ii) = 0;
IMAGE_INSTANCE_SUBWINDOW_H_RESIZEP (ii) = 0;
}
if (!NILP (mwidth))
IMAGE_INSTANCE_MARGIN_WIDTH (ii) = XINT (mwidth);
+ IMAGE_INSTANCE_WANTS_INITIAL_FOCUS (ii) = !NILP (ifocus);
+
/* Layout for the layout widget is premature at this point since the
children will not have been instantiated. We can't instantiate
them until the device instantiation method for the layout has
/* Get the geometry of a button control. We need to adjust the size
depending on the type of button. */
static void
-button_query_geometry (Lisp_Object image_instance,
+button_query_geometry (Lisp_Object image_instance,
int* width, int* height,
enum image_instance_geometry disp, Lisp_Object domain)
{
/* tree-view geometry - get the height right */
static void
-tree_view_query_geometry (Lisp_Object image_instance,
+tree_view_query_geometry (Lisp_Object image_instance,
int* width, int* height,
enum image_instance_geometry disp, Lisp_Object domain)
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object items = IMAGE_INSTANCE_WIDGET_ITEMS (ii);
-
+
if (*width)
{
/* #### what should this be. reconsider when X has tree views. */
/* Get the geometry of a tab control. This is based on the number of
items and text therin in the tab control. */
static void
-tab_control_query_geometry (Lisp_Object image_instance,
+tab_control_query_geometry (Lisp_Object image_instance,
int* width, int* height,
enum image_instance_geometry disp, Lisp_Object domain)
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object items = XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii));
Lisp_Object rest;
- unsigned int tw = 0, th = 0;
+ int tw = 0, th = 0;
LIST_LOOP (rest, items)
{
}
}
-/* Get the geometry of a tab control. This is based on the number of
- items and text therin in the tab control. */
-static Lisp_Object
-tab_control_set_property (Lisp_Object image_instance,
- Lisp_Object prop,
- Lisp_Object val)
+/* Update the contents of a tab control. */
+static void
+tab_control_update (Lisp_Object image_instance,
+ Lisp_Object instantiator)
{
- /* Record new items for update. *_tab_control_update will do the
+ Lisp_Object items = find_keyword_in_vector (instantiator, Q_items);
+ /* Record new items for update. *_tab_control_redisplay will do the
rest. */
- if (EQ (prop, Q_items))
+ if (!NILP (items))
{
Lisp_Image_Instance* ii = XIMAGE_INSTANCE (image_instance);
-
- check_valid_item_list_1 (val);
-
+ check_valid_item_list (items);
+#ifdef DEBUG_WIDGET_OUTPUT
+ stderr_out ("tab control %p updated\n", IMAGE_INSTANCE_SUBWINDOW_ID (ii));
+#endif
/* Don't set the actual items since we might decide not to use
the new ones (because nothing has really changed). If we did
set them and didn't use them then we would get into whole
heaps of trouble when the old items get GC'd. */
IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii) =
- Fcons (XCAR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)),
- parse_gui_item_tree_children (val));
+ Fcons (XCAR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)),
+ parse_gui_item_tree_children (items));
IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii) = 1;
+ }
+}
+
+/* Determine whether only the order has changed for a tab. */
+int tab_control_order_only_changed (Lisp_Object image_instance)
+{
+ Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
+ int found = 0, len, pending_len;
+ Lisp_Object rest;
+
+ /* Degenerate case. */
+ if (NILP (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)))
+ return 1;
- return Qt;
+ /* See whether we just need a change in order. */
+ GET_LIST_LENGTH (IMAGE_INSTANCE_WIDGET_ITEMS (ii), len);
+ GET_LIST_LENGTH (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii),
+ pending_len);
+ if (len == pending_len)
+ {
+ LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)))
+ {
+ Lisp_Object pending_rest;
+ found = 0;
+ LIST_LOOP (pending_rest,
+ XCDR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)))
+ {
+ if (gui_item_equal_sans_selected (XCAR (rest),
+ XCAR (pending_rest), 0))
+ {
+ found = 1;
+ break;
+ }
+ }
+ if (!found)
+ break;
+ }
}
- return Qunbound;
+ return found;
}
-/* set the properties of a progres guage */
-static Lisp_Object
-progress_gauge_set_property (Lisp_Object image_instance,
- Lisp_Object prop,
- Lisp_Object val)
+/* Set the properties of a progress gauge */
+static void
+progress_gauge_update (Lisp_Object image_instance,
+ Lisp_Object instantiator)
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
+ Lisp_Object value = find_keyword_in_vector (instantiator, Q_value);
- if (EQ (prop, Q_value))
+ if (!NILP (value))
{
- CHECK_INT (val);
+ CHECK_INT (value);
#ifdef DEBUG_WIDGET_OUTPUT
- printf ("progress gauge value set to %ld\n", XINT (val));
+ stderr_out ("progress gauge value set to %ld\n", XINT (value));
#endif
IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii) =
copy_gui_item_tree (IMAGE_INSTANCE_WIDGET_ITEMS (ii));
assert (GUI_ITEMP (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)));
#endif
if (GUI_ITEMP (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)))
- XGUI_ITEM (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii))->value = val;
+ XGUI_ITEM (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii))->value = value;
IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii) = 1;
-
- return Qt;
}
- return Qunbound;
}
\f
/*****************************************************************************
* widget layout *
*****************************************************************************/
-/* we need to convert things like glyphs to images, eval expressions
- etc.*/
+/* We need to cascade normalization.*/
static Lisp_Object
-layout_normalize (Lisp_Object inst, Lisp_Object console_type)
+layout_normalize (Lisp_Object inst, Lisp_Object console_type,
+ Lisp_Object dest_mask)
{
/* This function can call lisp */
- Lisp_Object items = find_keyword_in_vector (inst, Q_items);
- Lisp_Object border = find_keyword_in_vector (inst, Q_border);
- /* we need to eval glyph if its an expression, we do this for the
- same reasons we normalize file to data. */
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object alist = Qnil, new_items = Qnil, border;
+ /* This function can call lisp */
+ Lisp_Object items;
+
+ GCPRO2 (alist, new_items);
+ alist = tagged_vector_to_alist (inst);
+ items = assq_no_quit (Q_items, alist);
+
+ /* We need to normalize sub-objects. */
if (!NILP (items))
{
Lisp_Object rest;
- LIST_LOOP (rest, items)
+ LIST_LOOP (rest, XCDR (items))
{
- /* substitute the new glyph */
- Fsetcar (rest, glyph_instantiator_to_glyph (XCAR (rest)));
+ /* Substitute the new instantiator */
+ new_items = Fcons (normalize_image_instantiator (XCAR (rest),
+ console_type, dest_mask),
+ new_items);
}
+ new_items = Fnreverse (new_items);
+ Fsetcdr (items, new_items);
}
- /* normalize the border spec. */
- if (VECTORP (border) || CONSP (border))
+ /* Normalize the border spec. */
+ border = assq_no_quit (Q_border, alist);
+ if (!NILP (border) && VECTORP (XCDR (border)))
{
- substitute_keyword_value (inst, Q_border, glyph_instantiator_to_glyph (border));
+ Fsetcdr (border, normalize_image_instantiator (XCDR (border),
+ console_type, dest_mask));
}
- return inst;
+
+ {
+ Lisp_Object result = alist_to_tagged_vector (XVECTOR_DATA (inst)[0],
+ alist);
+ free_alist (alist);
+ RETURN_UNGCPRO (result);
+ }
+}
+
+/* Update the instances in the layout. */
+static void
+layout_update (Lisp_Object image_instance, Lisp_Object instantiator)
+{
+ Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
+ Lisp_Object items = find_keyword_in_vector (instantiator, Q_items);
+ Lisp_Object border_inst = find_keyword_in_vector (instantiator, Q_border);
+ Lisp_Object border = Qnil;
+ Lisp_Object children = IMAGE_INSTANCE_LAYOUT_CHILDREN (ii);
+ int structure_changed = 0;
+ struct gcpro gcpro1;
+
+ /* We want to avoid consing if we can. This is quite awkward because
+ we have to deal with the border as well as the items. */
+
+ GCPRO1 (border);
+
+ if (INTP (IMAGE_INSTANCE_LAYOUT_BORDER (ii)))
+ {
+ border = XCAR (children);
+ children = XCDR (children);
+ }
+
+#ifdef DEBUG_WIDGET_OUTPUT
+ stderr_out ("layout updated\n");
+#endif
+ /* Update the border. */
+ if (!NILP (border_inst))
+ {
+ if (VECTORP (border_inst))
+ {
+ /* We are going to be sneaky here and add the border text as
+ just another child, the layout and output routines don't know
+ this and will just display at the offsets we prescribe. */
+ if (!NILP (border))
+ call3 (Qset_glyph_image, border, border_inst,
+ IMAGE_INSTANCE_DOMAIN (ii));
+ else
+ {
+ border = Fcons (call1 (Qmake_glyph, border_inst), Qnil);
+ structure_changed = 1;
+ }
+ IMAGE_INSTANCE_LAYOUT_BORDER (ii) = make_int (0);
+ }
+ else
+ {
+ if (!NILP (border))
+ {
+ border = Qnil;
+ structure_changed = 1;
+ }
+ if (EQ (border_inst, Qt))
+ IMAGE_INSTANCE_LAYOUT_BORDER (ii) = Qetched_in;
+ else
+ IMAGE_INSTANCE_LAYOUT_BORDER (ii) = border_inst;
+ }
+ }
+
+ /* Pick up the sub-widgets. */
+ if (!NILP (items))
+ {
+ int len1, len2;
+ GET_LIST_LENGTH (items, len1);
+ GET_LIST_LENGTH (children, len2);
+ /* The structure hasn't changed so just update the images. */
+ if (!structure_changed && len1 == len2)
+ {
+ /* Pick up the sub-widgets. */
+ for (; !NILP (children); children = XCDR (children), items = XCDR (items))
+ {
+ call3 (Qset_glyph_image, XCAR (children), XCAR (items),
+ IMAGE_INSTANCE_DOMAIN (ii));
+ }
+ }
+ /* The structure has changed so start over. */
+ else
+ {
+ /* Instantiate any new glyphs. */
+ for (; !NILP (items); items = XCDR (items))
+ {
+ border = Fcons (call1 (Qmake_glyph, XCAR (items)), border);
+ }
+ IMAGE_INSTANCE_LAYOUT_CHILDREN (ii) = Fnreverse (border);
+ }
+ }
+ UNGCPRO;
}
static void
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object orient = find_keyword_in_vector (instantiator, Q_orientation);
- Lisp_Object border = find_keyword_in_vector (instantiator, Q_border);
+#ifdef DEBUG_WIDGET_OUTPUT
+ stderr_out ("layout instantiated\n");
+#endif
/* Do widget type instantiation first. */
widget_instantiate (image_instance, instantiator, pointer_fg, pointer_bg,
dest_mask, domain);
{
IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii) = LAYOUT_VERTICAL;
}
-
- if (EQ (border, Qt))
- {
- IMAGE_INSTANCE_LAYOUT_BORDER (ii) = Qetched_in;
- }
- else
- {
- IMAGE_INSTANCE_LAYOUT_BORDER (ii) = border;
- }
- /* We don't do the children yet as we might not have a containing
+
+ /* Get child glyphs and finish instantiation. We can't do image
+ instance children yet as we might not have a containing
window. */
+ layout_update (image_instance, instantiator);
}
static void
layout_post_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
Lisp_Object domain)
{
- Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
- Lisp_Object items = find_keyword_in_vector (instantiator, Q_items);
- Lisp_Object rest, children = Qnil;
-
- if (GLYPHP (IMAGE_INSTANCE_LAYOUT_BORDER (ii)))
- {
- /* We are going to be sneaky here and add the border text as
- just another child, the layout and output routines don't know
- this and will just display at the offsets we prescribe. */
- Lisp_Object gii = glyph_image_instance
- (IMAGE_INSTANCE_LAYOUT_BORDER (ii),
- image_instance, ERROR_ME, 1);
-
- if (!IMAGE_INSTANCEP (gii))
- return;
- /* make sure we are designated as the parent. */
- XIMAGE_INSTANCE_PARENT (gii) = image_instance;
- children = Fcons (gii, children);
- IMAGE_INSTANCE_LAYOUT_BORDER (ii) = make_int (0);
- }
-
- /* Pick up the sub-widgets. */
- LIST_LOOP (rest, items)
- {
- /* make sure the image is instantiated */
- Lisp_Object gii = glyph_image_instance (XCAR (rest),
- image_instance, ERROR_ME, 1);
- if (!IMAGE_INSTANCEP (gii))
- return;
- /* make sure we are designated as the parent. */
- XIMAGE_INSTANCE_PARENT (gii) = image_instance;
- children = Fcons (gii, children);
- }
- /* Make sure elements in the layout are in the order the
- user expected. */
- children = Fnreverse (children);
- IMAGE_INSTANCE_LAYOUT_CHILDREN (ii) = children;
}
/* Layout widget. Sizing commentary: we have a number of problems that
course these attributes can change dynamically and so the size
should changed dynamically also. Only in a few limited cases should
the size be fixed and remain fixed. Of course this actually means
- that we don't really want to specifiy the size *at all* for most
+ that we don't really want to specify the size *at all* for most
widgets - we want it to be discovered dynamically. Thus we can
envisage the following scenarios:
-
+
1. A button is sized to accommodate its text, the text changes and the
- button should change size also.
+ button should change size also.
2. A button is given an explicit size. Its size should never change.
3. Layout is put inside an area. The size of the area changes, the
- layout should change with it.
+ layout should change with it.
4. A button grows to accommodate additional text. The whitespace
around it should be modified to cope with the new layout
- requirements.
+ requirements.
5. A button grows. The area surrounding it should grow also if
- possible.
+ possible.
What metrics are important?
1. Actual width and height.
-
+
2. Whether the width and height are what the widget actually wants, or
- whether it can grow or shrink.
+ whether it can grow or shrink.
Text glyphs are particularly troublesome since their metrics depend
on the context in which they are being viewed. For instance they
/* First just set up what we already have. */
if (width) *width = IMAGE_INSTANCE_WIDTH (ii);
if (height) *height = IMAGE_INSTANCE_HEIGHT (ii);
-
+
/* If we are not allowed to dynamically size then return. */
if (!IMAGE_INSTANCE_SUBWINDOW_V_RESIZEP (ii)
&&
/* Pick up the border text if we have one. */
if (INTP (IMAGE_INSTANCE_LAYOUT_BORDER (ii)))
{
- image_instance_query_geometry (XCAR (items), &gwidth, &gheight, disp, domain);
+ glyph_query_geometry (XCAR (items), &gwidth, &gheight, disp,
+ image_instance);
ph_adjust = gheight / 2;
items = XCDR (items);
}
-
+
/* Flip through the items to work out how much stuff we have to display */
LIST_LOOP (rest, items)
{
Lisp_Object glyph = XCAR (rest);
- image_instance_query_geometry (glyph, &gwidth, &gheight, disp, domain);
+ glyph_query_geometry (glyph, &gwidth, &gheight, disp, image_instance);
nitems ++;
- if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
+ if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
== LAYOUT_HORIZONTAL)
{
maxph = max (maxph, gheight);
have been fixed by the user. */
if (!NILP (IMAGE_INSTANCE_WIDGET_WIDTH_SUBR (ii)))
{
- Lisp_Object dynamic_width =
+ Lisp_Object dynamic_width =
Feval (IMAGE_INSTANCE_WIDGET_WIDTH_SUBR (ii));
if (INTP (dynamic_width))
*width = XINT (dynamic_width);
== LAYOUT_HORIZONTAL)
*width = maxpw + ((nitems + 1) * WIDGET_BORDER_WIDTH +
IMAGE_INSTANCE_MARGIN_WIDTH (ii)) * 2;
- else
- *width = maxpw + 2 * (WIDGET_BORDER_WIDTH * 2 +
+ else
+ *width = maxpw + 2 * (WIDGET_BORDER_WIDTH * 2 +
IMAGE_INSTANCE_MARGIN_WIDTH (ii));
/* Work out vertical spacings. */
if (!NILP (IMAGE_INSTANCE_WIDGET_HEIGHT_SUBR (ii)))
{
- Lisp_Object dynamic_height =
+ Lisp_Object dynamic_height =
Feval (IMAGE_INSTANCE_WIDGET_HEIGHT_SUBR (ii));
if (INTP (dynamic_height))
*height = XINT (dynamic_height);
}
int
-layout_layout (Lisp_Object image_instance,
- int width, int height, Lisp_Object domain)
+layout_layout (Lisp_Object image_instance,
+ int width, int height, int xoffset, int yoffset,
+ Lisp_Object domain)
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object rest;
{
Lisp_Object border = XCAR (items);
items = XCDR (items);
- image_instance_query_geometry (border, &gwidth, &gheight,
- IMAGE_DESIRED_GEOMETRY, domain);
- /* #### Really, what should this be? */
- XIMAGE_INSTANCE_XOFFSET (border) = 10;
- XIMAGE_INSTANCE_YOFFSET (border) = 0;
+ glyph_query_geometry (border, &gwidth, &gheight,
+ IMAGE_DESIRED_GEOMETRY, image_instance);
ph_adjust = gheight / 2;
IMAGE_INSTANCE_LAYOUT_BORDER (ii) = make_int (ph_adjust);
- image_instance_layout (border, gwidth, gheight, domain);
+ /* #### Really, what should this be? */
+ glyph_do_layout (border, gwidth, gheight, 10, 0,
+ image_instance);
}
/* Flip through the items to work out how much stuff we have to display. */
LIST_LOOP (rest, items)
{
Lisp_Object glyph = XCAR (rest);
-
- image_instance_query_geometry (glyph, &gwidth, &gheight,
- IMAGE_DESIRED_GEOMETRY, domain);
+
+ glyph_query_geometry (glyph, &gwidth, &gheight,
+ IMAGE_DESIRED_GEOMETRY, image_instance);
nitems ++;
- if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
+ if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
== LAYOUT_HORIZONTAL)
{
maxph = max (maxph, gheight);
just provide default spacing and will let the output routines
clip.. */
horiz_spacing = WIDGET_BORDER_WIDTH * 2;
- else if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
+ else if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
== LAYOUT_HORIZONTAL)
/* We have a larger area to display in so distribute the space
evenly. */
- horiz_spacing = (width - (maxpw +
- IMAGE_INSTANCE_MARGIN_WIDTH (ii) * 2))
+ horiz_spacing = (width - (maxpw +
+ IMAGE_INSTANCE_MARGIN_WIDTH (ii) * 2))
/ (nitems + 1);
else
horiz_spacing = (width - maxpw) / 2
if (height < maxph)
vert_spacing = WIDGET_BORDER_HEIGHT * 2;
- else if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
+ else if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
== LAYOUT_VERTICAL)
- vert_spacing = (height - (maxph + ph_adjust +
- IMAGE_INSTANCE_MARGIN_WIDTH (ii) * 2))
+ vert_spacing = (height - (maxph + ph_adjust +
+ IMAGE_INSTANCE_MARGIN_WIDTH (ii) * 2))
/ (nitems + 1);
else
- vert_spacing = (height - (maxph + ph_adjust)) / 2
+ vert_spacing = (height - (maxph + ph_adjust)) / 2
- IMAGE_INSTANCE_MARGIN_WIDTH (ii);
y = vert_spacing + ph_adjust + IMAGE_INSTANCE_MARGIN_WIDTH (ii);
{
Lisp_Object glyph = XCAR (rest);
- image_instance_query_geometry (glyph, &gwidth, &gheight,
- IMAGE_DESIRED_GEOMETRY, domain);
+ glyph_query_geometry (glyph, &gwidth, &gheight,
+ IMAGE_DESIRED_GEOMETRY, image_instance);
- if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
+ if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
== LAYOUT_HORIZONTAL)
{
- if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
+ if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
== LAYOUT_JUSTIFY_RIGHT)
y = height - (gheight + vert_spacing);
- if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
+ if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
== LAYOUT_JUSTIFY_CENTER)
y = (height - gheight) / 2;
}
- else
+ else
{
- if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
+ if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
== LAYOUT_JUSTIFY_RIGHT)
x = width - (gwidth + horiz_spacing);
- if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
+ if (IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (ii)
== LAYOUT_JUSTIFY_CENTER)
x = (width - gwidth) / 2;
}
-
- XIMAGE_INSTANCE_XOFFSET (glyph) = x;
- XIMAGE_INSTANCE_YOFFSET (glyph) = y;
-
- if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
+
+ /* Now layout subwidgets if they require it. */
+ glyph_do_layout (glyph, gwidth, gheight, x, y, image_instance);
+
+ if (IMAGE_INSTANCE_SUBWINDOW_ORIENT (ii)
== LAYOUT_HORIZONTAL)
{
x += (gwidth + horiz_spacing);
{
y += (gheight + vert_spacing);
}
-
- /* Now layout subwidgets if they require it. */
- image_instance_layout (glyph, gwidth, gheight, domain);
+
}
return 1;
}
+/* Get the glyphs that comprise a layout. These are created internally
+ and so are otherwise inaccessible to lisp. We need some way of getting
+ properties from the widgets that comprise a layout and this is the
+ simplest way of doing it.
+
+ #### Eventually we should allow some more intelligent access to
+ sub-widgets. */
+static Lisp_Object
+layout_property (Lisp_Object image_instance, Lisp_Object prop)
+{
+ /* This function can GC. */
+ Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
+ if (EQ (prop, Q_items))
+ {
+ if (INTP (IMAGE_INSTANCE_LAYOUT_BORDER (ii)) &&
+ CONSP (IMAGE_INSTANCE_LAYOUT_CHILDREN (ii)))
+ return Fcopy_sequence (XCDR
+ (IMAGE_INSTANCE_LAYOUT_CHILDREN (ii)));
+ else
+ return Fcopy_sequence (IMAGE_INSTANCE_LAYOUT_CHILDREN (ii));
+ }
+ return Qunbound;
+}
+
/* Layout subwindows if they are real subwindows. */
static int
native_layout_layout (Lisp_Object image_instance,
- int width, int height,
+ int width, int height, int xoffset, int yoffset,
Lisp_Object domain)
{
Lisp_Image_Instance* ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object rest;
-
+
/* The first time this gets called, the layout will be only
partially instantiated. The children get done in
post_instantiate. */
if (!IMAGE_INSTANCE_INITIALIZED (ii))
return 0;
- /* Defining this overrides the default layout_layout so we first have to call that to get
+ /* Defining this overrides the default layout_layout so we first have to call that to get
suitable instances and values set up. */
- layout_layout (image_instance, width, height, domain);
+ layout_layout (image_instance, width, height, xoffset, yoffset, domain);
LIST_LOOP (rest, IMAGE_INSTANCE_LAYOUT_CHILDREN (ii))
{
dga.width = IMAGE_INSTANCE_WIDTH (ii);
dga.height = IMAGE_INSTANCE_HEIGHT (ii);
- map_subwindow (XCAR (rest),
+ map_subwindow (XCAR (rest),
IMAGE_INSTANCE_XOFFSET (ii),
IMAGE_INSTANCE_YOFFSET (ii), &dga);
}
void
syms_of_glyphs_widget (void)
{
- defkeyword (&Q_descriptor, ":descriptor");
- defkeyword (&Q_height, ":height");
- defkeyword (&Q_width, ":width");
- defkeyword (&Q_properties, ":properties");
- defkeyword (&Q_items, ":items");
- defkeyword (&Q_image, ":image");
- defkeyword (&Q_text, ":text");
- defkeyword (&Q_orientation, ":orientation");
- defkeyword (&Q_justify, ":justify");
- defkeyword (&Q_border, ":border");
- defkeyword (&Q_margin_width, ":margin-width");
-
- defsymbol (&Qetched_in, "etched-in");
- defsymbol (&Qetched_out, "etched-out");
- defsymbol (&Qbevel_in, "bevel-in");
- defsymbol (&Qbevel_out, "bevel-out");
+ DEFSYMBOL (Qetched_in);
+ DEFSYMBOL (Qetched_out);
+ DEFSYMBOL (Qbevel_in);
+ DEFSYMBOL (Qbevel_out);
+ DEFSYMBOL (Qmake_glyph);
}
-#define VALID_GUI_KEYWORDS(type) do { \
- IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_active, check_valid_anything); \
- IIFORMAT_VALID_KEYWORD (type, Q_suffix, check_valid_anything); \
- IIFORMAT_VALID_KEYWORD (type, Q_keys, check_valid_string); \
- IIFORMAT_VALID_KEYWORD (type, Q_style, check_valid_symbol); \
- IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_selected, check_valid_anything); \
- IIFORMAT_VALID_KEYWORD (type, Q_filter, check_valid_anything); \
- IIFORMAT_VALID_KEYWORD (type, Q_config, check_valid_symbol); \
- IIFORMAT_VALID_KEYWORD (type, Q_included, check_valid_anything); \
- IIFORMAT_VALID_KEYWORD (type, Q_key_sequence, check_valid_string); \
- IIFORMAT_VALID_KEYWORD (type, Q_accelerator, check_valid_string); \
- IIFORMAT_VALID_KEYWORD (type, Q_label, check_valid_anything); \
- IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_callback, check_valid_callback); \
- IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_callback_ex, check_valid_callback); \
- IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_descriptor, check_valid_string_or_vector); \
+#define VALID_GUI_KEYWORDS(type) do { \
+ IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_active, check_valid_anything); \
+ IIFORMAT_VALID_KEYWORD (type, Q_suffix, check_valid_anything); \
+ IIFORMAT_VALID_KEYWORD (type, Q_keys, check_valid_string); \
+ IIFORMAT_VALID_KEYWORD (type, Q_style, check_valid_symbol); \
+ IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_selected, check_valid_anything); \
+ IIFORMAT_VALID_KEYWORD (type, Q_filter, check_valid_anything); \
+ IIFORMAT_VALID_KEYWORD (type, Q_config, check_valid_symbol); \
+ IIFORMAT_VALID_KEYWORD (type, Q_included, check_valid_anything); \
+ IIFORMAT_VALID_KEYWORD (type, Q_initial_focus, check_valid_anything); \
+ IIFORMAT_VALID_KEYWORD (type, Q_key_sequence, check_valid_string); \
+ IIFORMAT_VALID_KEYWORD (type, Q_accelerator, check_valid_string); \
+ IIFORMAT_VALID_KEYWORD (type, Q_label, check_valid_anything); \
+ IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_callback, check_valid_callback); \
+ IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_callback_ex, check_valid_callback); \
+ IIFORMAT_VALID_NONCOPY_KEYWORD (type, Q_descriptor, \
+ check_valid_string_or_vector); \
} while (0)
-#define VALID_WIDGET_KEYWORDS(type) do { \
- IIFORMAT_VALID_KEYWORD (type, Q_width, check_valid_int); \
- IIFORMAT_VALID_KEYWORD (type, Q_height, check_valid_int); \
- IIFORMAT_VALID_KEYWORD (type, Q_pixel_width, check_valid_int_or_function);\
- IIFORMAT_VALID_KEYWORD (type, Q_pixel_height, check_valid_int_or_function);\
- IIFORMAT_VALID_KEYWORD (type, Q_face, check_valid_face); \
+#define VALID_WIDGET_KEYWORDS(type) do { \
+ IIFORMAT_VALID_KEYWORD (type, Q_width, check_valid_int); \
+ IIFORMAT_VALID_KEYWORD (type, Q_height, check_valid_int); \
+ IIFORMAT_VALID_KEYWORD (type, Q_pixel_width, check_valid_int_or_function); \
+ IIFORMAT_VALID_KEYWORD (type, Q_pixel_height, check_valid_int_or_function); \
+ IIFORMAT_VALID_KEYWORD (type, Q_face, check_valid_face); \
} while (0)
{ /* we only do this for properties */
INITIALIZE_IMAGE_INSTANTIATOR_FORMAT_NO_SYM (widget, "widget");
IIFORMAT_HAS_METHOD (widget, property);
- IIFORMAT_HAS_METHOD (widget, set_property);
+ IIFORMAT_HAS_METHOD (widget, update);
IIFORMAT_HAS_METHOD (widget, query_geometry);
IIFORMAT_HAS_METHOD (widget, layout);
}
IIFORMAT_HAS_SHARED_METHOD (button, governing_domain, subwindow);
IIFORMAT_HAS_METHOD (button, query_geometry);
IIFORMAT_VALID_KEYWORD (button,
- Q_image, check_valid_glyph_or_instantiator);
+ Q_image, check_valid_instantiator);
VALID_WIDGET_KEYWORDS (button);
VALID_GUI_KEYWORDS (button);
}
IIFORMAT_VALID_KEYWORD (combo_box, Q_width, check_valid_int);
IIFORMAT_VALID_KEYWORD (combo_box, Q_height, check_valid_int);
- IIFORMAT_VALID_KEYWORD (combo_box, Q_pixel_width, check_valid_int_or_function);
+ IIFORMAT_VALID_KEYWORD (combo_box, Q_pixel_width,
+ check_valid_int_or_function);
IIFORMAT_VALID_KEYWORD (combo_box, Q_face, check_valid_face);
- IIFORMAT_VALID_KEYWORD (combo_box, Q_properties, check_valid_item_list);
+ IIFORMAT_VALID_KEYWORD (combo_box, Q_items, check_valid_item_list);
}
static void image_instantiator_scrollbar (void)
IIFORMAT_HAS_SHARED_METHOD (scrollbar, governing_domain, subwindow);
VALID_GUI_KEYWORDS (scrollbar);
- IIFORMAT_VALID_KEYWORD (scrollbar, Q_pixel_width, check_valid_int_or_function);
- IIFORMAT_VALID_KEYWORD (scrollbar, Q_pixel_height, check_valid_int_or_function);
+ IIFORMAT_VALID_KEYWORD (scrollbar, Q_pixel_width,
+ check_valid_int_or_function);
+ IIFORMAT_VALID_KEYWORD (scrollbar, Q_pixel_height,
+ check_valid_int_or_function);
IIFORMAT_VALID_KEYWORD (scrollbar, Q_face, check_valid_face);
}
IIFORMAT_HAS_SHARED_METHOD (progress_gauge, instantiate, widget);
IIFORMAT_HAS_SHARED_METHOD (progress_gauge, post_instantiate, widget);
IIFORMAT_HAS_SHARED_METHOD (progress_gauge, governing_domain, subwindow);
- IIFORMAT_HAS_METHOD (progress_gauge, set_property);
+ IIFORMAT_HAS_METHOD (progress_gauge, update);
VALID_WIDGET_KEYWORDS (progress_gauge);
VALID_GUI_KEYWORDS (progress_gauge);
+
+ IIFORMAT_VALID_KEYWORD (progress_gauge, Q_value, check_valid_int);
}
static void image_instantiator_tree_view (void)
IIFORMAT_HAS_SHARED_METHOD (tree_view, instantiate, widget);
IIFORMAT_HAS_SHARED_METHOD (tree_view, post_instantiate, widget);
IIFORMAT_HAS_SHARED_METHOD (tree_view, governing_domain, subwindow);
+ IIFORMAT_HAS_SHARED_METHOD (tree_view, update, tab_control);
IIFORMAT_HAS_METHOD (tree_view, query_geometry);
VALID_WIDGET_KEYWORDS (tree_view);
VALID_GUI_KEYWORDS (tree_view);
- IIFORMAT_VALID_KEYWORD (tree_view, Q_properties, check_valid_item_list);
+ IIFORMAT_VALID_KEYWORD (tree_view, Q_items, check_valid_item_list);
}
static void image_instantiator_tab_control (void)
IIFORMAT_HAS_SHARED_METHOD (tab_control, post_instantiate, widget);
IIFORMAT_HAS_SHARED_METHOD (tab_control, governing_domain, subwindow);
IIFORMAT_HAS_METHOD (tab_control, query_geometry);
- IIFORMAT_HAS_METHOD (tab_control, set_property);
+ IIFORMAT_HAS_METHOD (tab_control, update);
VALID_WIDGET_KEYWORDS (tab_control);
VALID_GUI_KEYWORDS (tab_control);
- IIFORMAT_VALID_KEYWORD (tab_control, Q_orientation, check_valid_tab_orientation);
- IIFORMAT_VALID_KEYWORD (tab_control, Q_properties, check_valid_item_list);
+ IIFORMAT_VALID_KEYWORD (tab_control, Q_orientation,
+ check_valid_tab_orientation);
+ IIFORMAT_VALID_KEYWORD (tab_control, Q_items, check_valid_item_list);
}
static void image_instantiator_labels (void)
IIFORMAT_VALID_KEYWORD (label, Q_descriptor, check_valid_string);
}
-#define VALID_LAYOUT_KEYWORDS(layout) \
- VALID_WIDGET_KEYWORDS (layout); \
- IIFORMAT_VALID_KEYWORD (layout, Q_orientation, check_valid_orientation); \
- IIFORMAT_VALID_KEYWORD (layout, Q_justify, check_valid_justification); \
- IIFORMAT_VALID_KEYWORD (layout, Q_border, check_valid_border); \
- IIFORMAT_VALID_KEYWORD (layout, Q_margin_width, check_valid_int); \
- IIFORMAT_VALID_KEYWORD (layout, Q_items, \
- check_valid_glyph_or_instantiator_list)
+#define VALID_LAYOUT_KEYWORDS(layout) \
+ VALID_WIDGET_KEYWORDS (layout); \
+ IIFORMAT_VALID_KEYWORD (layout, Q_orientation, check_valid_orientation); \
+ IIFORMAT_VALID_KEYWORD (layout, Q_justify, check_valid_justification); \
+ IIFORMAT_VALID_KEYWORD (layout, Q_border, check_valid_border); \
+ IIFORMAT_VALID_KEYWORD (layout, Q_margin_width, check_valid_int); \
+ IIFORMAT_VALID_KEYWORD (layout, Q_items, \
+ check_valid_instantiator_list)
static void image_instantiator_layout (void)
{
IIFORMAT_HAS_METHOD (layout, normalize);
IIFORMAT_HAS_METHOD (layout, query_geometry);
IIFORMAT_HAS_METHOD (layout, layout);
+ IIFORMAT_HAS_METHOD (layout, update);
+ IIFORMAT_HAS_METHOD (layout, property);
VALID_GUI_KEYWORDS (layout);
VALID_LAYOUT_KEYWORDS (layout);
IIFORMAT_HAS_SHARED_METHOD (native_layout, normalize, layout);
IIFORMAT_HAS_SHARED_METHOD (native_layout, query_geometry, layout);
IIFORMAT_HAS_SHARED_METHOD (native_layout, layout, layout);
+ IIFORMAT_HAS_SHARED_METHOD (native_layout, property, layout);
VALID_GUI_KEYWORDS (native_layout);
VALID_LAYOUT_KEYWORDS (native_layout);
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
-
You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
/* Synched up with: Not in FSF. */
+/* 7-8-00 This file is more or less Mule-ized in my Mule workspace. */
+
/* Original author: Jamie Zawinski for 19.8
font-truename stuff added by Jamie Zawinski for 19.10
subwindow support added by Chuck Thompson
if (DEVICE_LIVE_P (XDEVICE (IMAGE_INSTANCE_DEVICE (p))))
{
- Display *dpy = DEVICE_X_DISPLAY
+ Display *dpy = DEVICE_X_DISPLAY
(XDEVICE (IMAGE_INSTANCE_DEVICE (p)));
if (0)
;
{
const char *ext_data;
- TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (XCDR (XCDR (mask_data))),
- C_STRING_ALLOCA, ext_data,
- Qbinary);
+ LISP_STRING_TO_EXTERNAL (XCAR (XCDR (XCDR (mask_data))), ext_data, Qbinary);
mask = pixmap_from_xbm_inline (IMAGE_INSTANCE_DEVICE (ii),
XINT (XCAR (mask_data)),
XINT (XCAR (XCDR (mask_data))),
assert (!NILP (data));
- TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (XCDR (XCDR (data))),
- C_STRING_ALLOCA, ext_data,
- Qbinary);
+ LISP_STRING_TO_EXTERNAL (XCAR (XCDR (XCDR (data))), ext_data, Qbinary);
xbm_instantiate_1 (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, XINT (XCAR (data)),
assert (!NILP (data));
- TO_EXTERNAL_FORMAT (LISP_STRING, data,
- C_STRING_ALLOCA, dstring,
- Qbinary);
+ LISP_STRING_TO_EXTERNAL (data, dstring, Qbinary);
if ((p = strchr (dstring, ':')))
{
static Lisp_Object
autodetect_normalize (Lisp_Object instantiator,
- Lisp_Object console_type)
+ Lisp_Object console_type,
+ Lisp_Object dest_mask)
{
Lisp_Object file = find_keyword_in_vector (instantiator, Q_data);
Lisp_Object filename = Qnil;
if (dest_mask & IMAGE_POINTER_MASK)
{
const char *name_ext;
- TO_EXTERNAL_FORMAT (LISP_STRING, data,
- C_STRING_ALLOCA, name_ext,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (data, name_ext, Qfile_name);
if (XmuCursorNameToIndex (name_ext) != -1)
{
result = alist_to_tagged_vector (Qcursor_font, alist);
if (!(dest_mask & IMAGE_POINTER_MASK))
incompatible_image_types (instantiator, dest_mask, IMAGE_POINTER_MASK);
- TO_EXTERNAL_FORMAT (LISP_STRING, data,
- C_STRING_ALLOCA, name_ext,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (data, name_ext, Qfile_name);
if ((i = XmuCursorNameToIndex (name_ext)) == -1)
signal_simple_error ("Unrecognized cursor-font name", data);
x, y, dga->width, dga->height);
XMoveWindow (IMAGE_INSTANCE_X_SUBWINDOW_DISPLAY (p),
subwindow, -dga->xoffset, -dga->yoffset);
- XMapWindow (IMAGE_INSTANCE_X_SUBWINDOW_DISPLAY (p),
- IMAGE_INSTANCE_X_CLIPWINDOW (p));
+ if (!IMAGE_INSTANCE_SUBWINDOW_DISPLAYEDP (p))
+ XMapWindow (IMAGE_INSTANCE_X_SUBWINDOW_DISPLAY (p),
+ IMAGE_INSTANCE_X_CLIPWINDOW (p));
}
else /* must be a widget */
{
dga->width, dga->height, 0);
XtMoveWidget (IMAGE_INSTANCE_X_WIDGET_ID (p),
-dga->xoffset, -dga->yoffset);
- XtMapWidget (IMAGE_INSTANCE_X_CLIPWIDGET (p));
+ if (!IMAGE_INSTANCE_SUBWINDOW_DISPLAYEDP (p))
+ XtMapWidget (IMAGE_INSTANCE_X_CLIPWIDGET (p));
}
}
/* when you click on a widget you may activate another widget this
needs to be checked and all appropriate widgets updated */
static void
-x_update_subwindow (Lisp_Image_Instance *p)
+x_redisplay_subwindow (Lisp_Image_Instance *p)
{
/* Update the subwindow size if necessary. */
if (IMAGE_INSTANCE_SIZE_CHANGED (p))
/* Update all attributes that have changed. Lwlib actually does most
of this for us. */
static void
-x_update_widget (Lisp_Image_Instance *p)
+x_redisplay_widget (Lisp_Image_Instance *p)
{
/* This function can GC if IN_REDISPLAY is false. */
#ifdef HAVE_WIDGETS
XSETIMAGE_INSTANCE (image_instance, p);
wv = gui_items_to_widget_values
- (image_instance, IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (p));
+ (image_instance, IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (p),
+ /* #### this is not right; we need to keep track of which widgets
+ want accelerators and which don't */ 0);
wv->change = STRUCTURAL_CHANGE;
- /* now modify the widget */
- lw_modify_all_widgets (IMAGE_INSTANCE_X_WIDGET_LWID (p),
- wv, True);
- free_widget_value_tree (wv);
}
-
- /* Now do non structural updates. */
- wv = lw_get_all_values (IMAGE_INSTANCE_X_WIDGET_LWID (p));
-
- if (!wv)
- return;
+ else
+ {
+ /* Assume the lotus position, breath deeply and chant to
+ yourself lwlibsux, lwlibsux ... lw_get_all_values returns a
+ reference to the real values rather than a copy thus any
+ changes we make to the values we get back will look like they
+ have already been applied. If we rebuild the widget tree then
+ we may lose propertie. */
+ wv = copy_widget_value_tree (lw_get_all_values
+ (IMAGE_INSTANCE_X_WIDGET_LWID (p)),
+ NO_CHANGE);
+ }
/* Possibly update the colors and font */
if (IMAGE_INSTANCE_WIDGET_FACE_CHANGED (p)
{
char* str;
Lisp_Object val = IMAGE_INSTANCE_WIDGET_TEXT (p);
- TO_EXTERNAL_FORMAT (LISP_STRING, val,
- C_STRING_ALLOCA, str,
- Qnative);
+ LISP_STRING_TO_EXTERNAL (val, str, Qnative);
wv->value = str;
}
/* now modify the widget */
lw_modify_all_widgets (IMAGE_INSTANCE_X_WIDGET_LWID (p),
- wv, False);
+ wv, True);
+ free_widget_value_tree (wv);
#endif
}
(IMAGE_INSTANCE_WIDGET_TEXT (ii),
IMAGE_INSTANCE_WIDGET_FACE (ii),
domain))));
+ wv->change = VISIBLE_CHANGE;
+ /* #### Megahack - but its just getting too complicated to do this
+ in the right place. */
+ if (EQ (IMAGE_INSTANCE_WIDGET_TYPE (ii), Qtab_control))
+ update_tab_widget_face (wv, ii, domain);
}
static void
domain);
XColor fcolor = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (pixel));
lw_add_widget_value_arg (val, XtNtabForeground, fcolor.pixel);
+ wv->change = VISIBLE_CHANGE;
+ val->change = VISIBLE_CHANGE;
for (cur = val->next; cur; cur = cur->next)
{
+ cur->change = VISIBLE_CHANGE;
if (cur->value)
{
lw_copy_widget_value_args (val, cur);
IMAGE_INSTANCE_TYPE (ii) = IMAGE_WIDGET;
if (!NILP (IMAGE_INSTANCE_WIDGET_TEXT (ii)))
- TO_EXTERNAL_FORMAT (LISP_STRING, IMAGE_INSTANCE_WIDGET_TEXT (ii),
- C_STRING_ALLOCA, nm,
- Qnative);
+ LISP_STRING_TO_EXTERNAL (IMAGE_INSTANCE_WIDGET_TEXT (ii), nm, Qnative);
ii->data = xnew_and_zero (struct x_subwindow_data);
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii);
Lisp_Object glyph = find_keyword_in_vector (instantiator, Q_image);
- widget_value* wv = gui_items_to_widget_values (image_instance, gui);
+ widget_value* wv = gui_items_to_widget_values (image_instance, gui, 1);
if (!NILP (glyph))
{
i.e. although the arg contents may be the same the args look
different and so are re-applied to the widget. */
static void
-x_button_update (Lisp_Object image_instance)
+x_button_redisplay (Lisp_Object image_instance)
{
/* This function can GC if IN_REDISPLAY is false. */
Lisp_Image_Instance *p = XIMAGE_INSTANCE (image_instance);
widget_value* wv =
gui_items_to_widget_values (image_instance,
- IMAGE_INSTANCE_WIDGET_ITEMS (p));
+ IMAGE_INSTANCE_WIDGET_ITEMS (p), 1);
/* now modify the widget */
lw_modify_all_widgets (IMAGE_INSTANCE_X_WIDGET_LWID (p),
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii);
- widget_value* wv = gui_items_to_widget_values (image_instance, gui);
+ widget_value* wv = gui_items_to_widget_values (image_instance, gui, 0);
x_widget_instantiate (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain, "progress", wv);
}
-/* set the properties of a progres guage */
+/* set the properties of a progress gauge */
static void
-x_progress_gauge_update (Lisp_Object image_instance)
+x_progress_gauge_redisplay (Lisp_Object image_instance)
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii);
- widget_value* wv = gui_items_to_widget_values (image_instance, gui);
+ widget_value* wv = gui_items_to_widget_values (image_instance, gui, 0);
x_widget_instantiate (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain, "text-field", wv);
pointer_bg, dest_mask, domain);
wv = gui_items_to_widget_values (image_instance,
- IMAGE_INSTANCE_WIDGET_ITEMS (ii));
+ IMAGE_INSTANCE_WIDGET_ITEMS (ii), 0);
x_widget_instantiate (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain, "combo-box", wv);
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
widget_value * wv =
gui_items_to_widget_values (image_instance,
- IMAGE_INSTANCE_WIDGET_ITEMS (ii));
-
+ IMAGE_INSTANCE_WIDGET_ITEMS (ii), 0);
update_tab_widget_face (wv, ii,
IMAGE_INSTANCE_FRAME (ii));
-
x_widget_instantiate (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain, "tab-control", wv);
}
-/* set the properties of a tab control */
+/* Set the properties of a tab control */
static void
-x_tab_control_update (Lisp_Object image_instance)
+x_tab_control_redisplay (Lisp_Object image_instance)
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
+ if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii)
+ ||
+ IMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (ii))
+ {
+ /* If only the order has changed then simply select the first
+ one of the pending set. This stops horrendous rebuilding -
+ and hence flicker - of the tabs each time you click on
+ one. */
+ if (tab_control_order_only_changed (image_instance))
+ {
+ Lisp_Object rest, selected =
+ gui_item_list_find_selected
+ (NILP (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)) ?
+ XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)) :
+ XCDR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)));
+
+ LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)))
+ {
+ if (gui_item_equal_sans_selected (XCAR (rest), selected, 0))
+ {
+ /* There may be an encapsulated way of doing this,
+ but I couldn't find it. */
+ Lisp_Object old_selected =gui_item_list_find_selected
+ (XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)));
+ Arg al [1];
+ char* name;
+ unsigned int num_children, i;
+ Widget* children;
+
+ LISP_STRING_TO_EXTERNAL (XGUI_ITEM (XCAR (rest))->name,
+ name, Qnative);
+ /* The name may contain a `.' which confuses
+ XtNameToWidget, so we do it ourselves. */
+ children = XtCompositeChildren (IMAGE_INSTANCE_X_WIDGET_ID (ii),
+ &num_children);
+ for (i = 0; i < num_children; i++)
+ {
+ if (!strcmp (XtName (children [i]), name))
+ {
+ XtSetArg (al [0], XtNtopWidget, children [i]);
+ XtSetValues (IMAGE_INSTANCE_X_WIDGET_ID (ii), al, 1);
+ break;
+ }
+ }
+ /* Pick up the new selected item. */
+ XGUI_ITEM (old_selected)->selected =
+ XGUI_ITEM (XCAR (rest))->selected;
+ XGUI_ITEM (XCAR (rest))->selected =
+ XGUI_ITEM (selected)->selected;
+ /* We're not actually changing the items anymore. */
+ IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii) = 0;
+ IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii) = Qnil;
+ break;
+ }
+ }
+ }
+ }
/* Possibly update the face. */
if (IMAGE_INSTANCE_WIDGET_FACE_CHANGED (ii)
||
||
IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii))
{
- widget_value* wv = lw_get_all_values (IMAGE_INSTANCE_X_WIDGET_LWID (ii));
+ /* See previous comments on the brokeness of lwlib.
- /* #### I don't know why this can occur. */
- if (!wv)
- return;
+ #### There's actually not much point in doing this here
+ since, colors will have been set appropriately by
+ x_redisplay_widget. */
+ widget_value* wv =copy_widget_value_tree
+ (lw_get_all_values
+ (IMAGE_INSTANCE_X_WIDGET_LWID (ii)),
+ NO_CHANGE);
update_tab_widget_face (wv, ii,
IMAGE_INSTANCE_FRAME (ii));
lw_modify_all_widgets (IMAGE_INSTANCE_X_WIDGET_LWID (ii), wv, True);
+ free_widget_value_tree (wv);
}
}
{
Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii);
- widget_value* wv = gui_items_to_widget_values (image_instance, gui);
+ widget_value* wv = gui_items_to_widget_values (image_instance, gui, 0);
x_widget_instantiate (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain, "button", wv);
CONSOLE_HAS_METHOD (x, locate_pixmap_file);
CONSOLE_HAS_METHOD (x, unmap_subwindow);
CONSOLE_HAS_METHOD (x, map_subwindow);
- CONSOLE_HAS_METHOD (x, update_widget);
- CONSOLE_HAS_METHOD (x, update_subwindow);
+ CONSOLE_HAS_METHOD (x, redisplay_widget);
+ CONSOLE_HAS_METHOD (x, redisplay_subwindow);
}
void
INITIALIZE_DEVICE_IIFORMAT (x, button);
IIFORMAT_HAS_DEVMETHOD (x, button, property);
IIFORMAT_HAS_DEVMETHOD (x, button, instantiate);
- IIFORMAT_HAS_DEVMETHOD (x, button, update);
+ IIFORMAT_HAS_DEVMETHOD (x, button, redisplay);
/* general widget methods. */
INITIALIZE_DEVICE_IIFORMAT (x, widget);
IIFORMAT_HAS_DEVMETHOD (x, widget, property);
/* progress gauge */
INITIALIZE_DEVICE_IIFORMAT (x, progress_gauge);
- IIFORMAT_HAS_DEVMETHOD (x, progress_gauge, update);
+ IIFORMAT_HAS_DEVMETHOD (x, progress_gauge, redisplay);
IIFORMAT_HAS_DEVMETHOD (x, progress_gauge, instantiate);
/* text field */
INITIALIZE_DEVICE_IIFORMAT (x, edit_field);
/* combo box */
INITIALIZE_DEVICE_IIFORMAT (x, combo_box);
IIFORMAT_HAS_DEVMETHOD (x, combo_box, instantiate);
- IIFORMAT_HAS_SHARED_DEVMETHOD (x, combo_box, update, tab_control);
+ IIFORMAT_HAS_SHARED_DEVMETHOD (x, combo_box, redisplay, tab_control);
#endif
/* tab control widget */
INITIALIZE_DEVICE_IIFORMAT (x, tab_control);
IIFORMAT_HAS_DEVMETHOD (x, tab_control, instantiate);
- IIFORMAT_HAS_DEVMETHOD (x, tab_control, update);
+ IIFORMAT_HAS_DEVMETHOD (x, tab_control, redisplay);
/* label */
INITIALIZE_DEVICE_IIFORMAT (x, label);
IIFORMAT_HAS_DEVMETHOD (x, label, instantiate);
#include "xintrinsic.h"
#include "../lwlib/lwlib.h"
+#include "../lwlib/lwlib-utils.h"
/****************************************************************************
* Image-Instance Object *
};
#define IMAGE_UNSPECIFIED_GEOMETRY -1
+#define IMAGE_UNCHANGED_GEOMETRY -2
#define WIDGET_BORDER_HEIGHT 4
#define WIDGET_BORDER_WIDTH 4
that should be used in a glyph, for devices of type CONSOLE_TYPE.
Signal an error if conversion fails. */
Lisp_Object (*normalize_method) (Lisp_Object instantiator,
- Lisp_Object console_type);
+ Lisp_Object console_type,
+ Lisp_Object dest_mask);
/* Governing domain method: Return an int indicating what type of
domain an instance in this format is governed by. */
Lisp_Object property,
Lisp_Object val);
/* Asynchronously update properties. */
- void (*update_method) (Lisp_Object image_instance);
+ void (*update_method) (Lisp_Object image_instance,
+ Lisp_Object instantiator);
+ void (*redisplay_method) (Lisp_Object image_instance);
/* Find out the desired geometry, as given by disp, of this image
instance. Actual geometry is stored in the appropriate slots in the
/* Layout the instance and its children bounded by the provided
dimensions. Returns success or failure. */
int (*layout_method) (Lisp_Object image_instance,
- int width, int height, Lisp_Object domain);
+ int width, int height, int xoffset, int yoffset,
+ Lisp_Object domain);
};
/***** Calling an image-instantiator method *****/
#define IIFORMAT_VALID_MULTI_KEYWORD(format, keyw, validate_fun) \
IIFORMAT_VALID_GENERIC_KEYWORD(format, keyw, validate_fun, 1, 1)
-/* Same as IIFORMAT_VALID_KEYWORD execpt that the argument is not
+/* Same as IIFORMAT_VALID_KEYWORD except that the argument is not
copied by the specifier functions. This is necessary for things
like callbacks etc. */
#define IIFORMAT_VALID_NONCOPY_KEYWORD(format, keyw, validate_fun) \
void check_valid_int (Lisp_Object data);
void check_valid_face (Lisp_Object data);
void check_valid_vector (Lisp_Object data);
-void check_valid_item_list_1 (Lisp_Object items);
+void check_valid_item_list (Lisp_Object items);
void initialize_subwindow_image_instance (Lisp_Image_Instance*);
void subwindow_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
enum image_instance_geometry disp,
Lisp_Object domain);
void image_instance_layout (Lisp_Object image_instance,
- int width, int height,
+ int width, int height, int xoffset, int yoffset,
Lisp_Object domain);
int layout_layout (Lisp_Object image_instance,
- int width, int height,
+ int width, int height, int xoffset, int yoffset,
Lisp_Object domain);
int invalidate_glyph_geometry_maybe (Lisp_Object glyph_or_ii, struct window* w);
/* The glyph from which we were instantiated. This is a weak
reference. */
Lisp_Object parent;
+ /* The instantiator from which we were instantiated. */
+ Lisp_Object instantiator;
enum image_instance_type type;
unsigned int x_offset, y_offset; /* for layout purposes */
int width, height, margin_width;
unsigned int dirty : 1;
unsigned int size_changed : 1;
unsigned int text_changed : 1;
- unsigned int layout_changed : 1;
+ unsigned int layout_changed : 1;
unsigned int optimize_output : 1; /* For outputting layouts. */
unsigned int initialized : 1; /* When we're fully done. */
+ unsigned int wants_initial_focus : 1;
union
{
struct
{
void* subwindow; /* specific devices can use this as necessary */
- struct
+ struct
{ /* We need these so we can do without
subwindow_cachel */
- unsigned int x, y;
+ unsigned int x, y;
unsigned int width, height;
} display_data;
unsigned int being_displayed : 1; /* used to detect when needs
unsigned int justification : 2; /* Left, right or center. */
/* Face for colors and font. We specify this here because we
want people to be able to put :face in the instantiator
- spec. Using gyph-face is more inconvenient, although more
+ spec. Using glyph-face is more inconvenient, although more
general. */
Lisp_Object face;
Lisp_Object type;
/* Change flags to augment dirty. */
unsigned int face_changed : 1;
unsigned int items_changed : 1;
+ unsigned int action_occurred : 1;
} subwindow;
} u;
#define IMAGE_INSTANCE_FRAME(i) (DOMAIN_FRAME ((i)->domain))
#define IMAGE_INSTANCE_NAME(i) ((i)->name)
#define IMAGE_INSTANCE_PARENT(i) ((i)->parent)
+#define IMAGE_INSTANCE_INSTANTIATOR(i) ((i)->instantiator)
#define IMAGE_INSTANCE_GLYPH(i) (image_instance_parent_glyph(i))
#define IMAGE_INSTANCE_TYPE(i) ((i)->type)
#define IMAGE_INSTANCE_XOFFSET(i) ((i)->x_offset)
#define IMAGE_INSTANCE_FACE(i) \
(GLYPHP (IMAGE_INSTANCE_GLYPH (i)) ? \
XGLYPH_FACE (IMAGE_INSTANCE_GLYPH (i)) : Qnil)
+#define IMAGE_INSTANCE_WANTS_INITIAL_FOCUS(i) ((i)->wants_initial_focus)
/* Changed flags */
#define IMAGE_INSTANCE_TEXT_CHANGED(i) ((i)->text_changed)
((i)->u.subwindow.face_changed)
#define IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED(i) \
((i)->u.subwindow.items_changed)
+#define IMAGE_INSTANCE_WIDGET_ACTION_OCCURRED(i) \
+ ((i)->u.subwindow.action_occurred)
#define IMAGE_INSTANCE_LAYOUT_CHANGED(i) ((i)->layout_changed)
#define IMAGE_INSTANCE_OPTIMIZE_OUTPUT(i) ((i)->optimize_output)
((i)->u.subwindow.orientation)
#define IMAGE_INSTANCE_SUBWINDOW_JUSTIFY(i) \
((i)->u.subwindow.justification)
+#define IMAGE_INSTANCE_SUBWINDOW_FACE(i) \
+((i)->u.subwindow.face)
/* Widget properties */
#define IMAGE_INSTANCE_WIDGET_WIDTH(i) \
IMAGE_INSTANCE_GLYPH (XIMAGE_INSTANCE (i))
#define XIMAGE_INSTANCE_PARENT(i) \
IMAGE_INSTANCE_PARENT (XIMAGE_INSTANCE (i))
+#define XIMAGE_INSTANCE_INSTANTIATOR(i) \
+ IMAGE_INSTANCE_INSTANTIATOR (XIMAGE_INSTANCE (i))
#define XIMAGE_INSTANCE_TYPE(i) \
IMAGE_INSTANCE_TYPE (XIMAGE_INSTANCE (i))
#define XIMAGE_INSTANCE_DISPLAY_HASH(i) \
IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (XIMAGE_INSTANCE (i))
#define XIMAGE_INSTANCE_WIDGET_TEXT(i) \
IMAGE_INSTANCE_WIDGET_TEXT (XIMAGE_INSTANCE (i))
+#define XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED(i) \
+ IMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (XIMAGE_INSTANCE (i))
#define XIMAGE_INSTANCE_LAYOUT_CHILDREN(i) \
IMAGE_INSTANCE_LAYOUT_CHILDREN (XIMAGE_INSTANCE (i))
IMAGE_INSTANCE_SUBWINDOW_ORIENT (XIMAGE_INSTANCE (i))
#define XIMAGE_INSTANCE_SUBWINDOW_JUSTIFY(i) \
IMAGE_INSTANCE_SUBWINDOW_JUSTIFY (XIMAGE_INSTANCE (i))
+#define XIMAGE_INSTANCE_SUBWINDOW_FACE(i) \
+ IMAGE_INSTANCE_SUBWINDOW_FACE (XIMAGE_INSTANCE (i))
#define MARK_IMAGE_INSTANCE_CHANGED(i) \
(IMAGE_INSTANCE_DIRTYP (i) = 1);
void string_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
Lisp_Object pointer_fg, Lisp_Object pointer_bg,
int dest_mask, Lisp_Object domain);
+int tab_control_order_only_changed (Lisp_Object image_instance);
Lisp_Object allocate_glyph (enum glyph_type type,
void (*after_change) (Lisp_Object glyph,
Lisp_Object property,
Lisp_Object locale));
+Lisp_Object normalize_image_instantiator (Lisp_Object instantiator,
+ Lisp_Object contype,
+ Lisp_Object dest_mask);
+void glyph_query_geometry (Lisp_Object glyph_or_image, int* width, int* height,
+ enum image_instance_geometry disp,
+ Lisp_Object domain);
+void glyph_do_layout (Lisp_Object glyph_or_image, int width, int height,
+ int xoffset, int yoffset,
+ Lisp_Object domain);
void query_string_geometry ( Lisp_Object string, Lisp_Object face,
- int* width, int* height, int* descent,
+ int* width, int* height, int* descent,
Lisp_Object domain);
Lisp_Object query_string_font (Lisp_Object string,
Lisp_Object face, Lisp_Object domain);
void map_subwindow (Lisp_Object subwindow, int x, int y,
struct display_glyph_area *dga);
int find_matching_subwindow (struct frame* f, int x, int y, int width, int height);
-void update_widget (Lisp_Object widget);
+void redisplay_widget (Lisp_Object widget);
void update_widget_instances (Lisp_Object frame);
-void update_subwindow (Lisp_Object subwindow);
+void redisplay_subwindow (Lisp_Object subwindow);
Lisp_Object image_instance_parent_glyph (struct Lisp_Image_Instance*);
int image_instance_changed (Lisp_Object image);
-void free_frame_subwindow_instance_cache (struct frame* f);
+void free_frame_subwindow_instances (struct frame* f);
void reset_frame_subwindow_instance_cache (struct frame* f);
+int unmap_subwindow_instance_cache_mapper (Lisp_Object key,
+ Lisp_Object value, void* finalize);
struct expose_ignore
{
conn.maxMod = ((1<<KG_SHIFT)|(1<<KG_ALT)|(1<<KG_CTRL));
/* Reset some silly static variables so that multiple Gpm_Open()
- ** calls have even a sligh chance of working
+ ** calls have even a slight chance of working
*/
gpm_tried = 0;
gpm_flag = 0;
image_instance = Fgethash (make_int (id),
FRAME_MSWINDOWS_WIDGET_HASH_TABLE1 (f), Qnil);
+ /* It is possible for a widget action to cause it to get out of sync
+ with its instantiator. Thus it is necessary to signal this
+ possibility. */
+ if (IMAGE_INSTANCEP (image_instance))
+ XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (image_instance) = 1;
callback = Fgethash (make_int (id),
FRAME_MSWINDOWS_WIDGET_HASH_TABLE2 (f), Qnil);
callback_ex = Fgethash (make_int (id),
return Qt;
}
-DEFUN ("mswindows-shell-execute", Fmswindows_shell_execute, 2, 4, 0, /*
-Get Windows to perform OPERATION on DOCUMENT.
-This is a wrapper around the ShellExecute system function, which
-invokes the application registered to handle OPERATION for DOCUMENT.
-OPERATION is typically \"open\", \"print\" or \"explore\" (but can be
-nil for the default action), and DOCUMENT is typically the name of a
-document file or URL, but can also be a program executable to run or
-a directory to open in the Windows Explorer.
-
-If DOCUMENT is a program executable, PARAMETERS can be a string
-containing command line parameters, but otherwise should be nil.
-
-SHOW-FLAG can be used to control whether the invoked application is hidden
-or minimized. If SHOW-FLAG is nil, the application is displayed normally,
-otherwise it is an integer representing a ShowWindow flag:
-
- 0 - start hidden
- 1 - start normally
- 3 - start maximized
- 6 - start minimized
-*/
- (operation, document, parameters, show_flag))
-{
- /* Encode filename and current directory. */
- Lisp_Object current_dir = Ffile_name_directory (document);
- char* path = NULL;
- char* doc = NULL;
- Extbyte* f=0;
- int ret;
- struct gcpro gcpro1, gcpro2;
-
- CHECK_STRING (document);
-
- if (NILP (current_dir))
- current_dir = current_buffer->directory;
-
- GCPRO2 (current_dir, document);
-
- /* Use mule and cygwin-safe APIs top get at file data. */
- if (STRINGP (current_dir))
- {
- TO_EXTERNAL_FORMAT (LISP_STRING, current_dir,
- C_STRING_ALLOCA, f,
- Qfile_name);
-#ifdef CYGWIN
- CYGWIN_WIN32_PATH (f, path);
-#else
- path = f;
-#endif
- }
-
- if (STRINGP (document))
- {
- TO_EXTERNAL_FORMAT (LISP_STRING, document,
- C_STRING_ALLOCA, f,
- Qfile_name);
-#ifdef CYGWIN
- CYGWIN_WIN32_PATH (f, doc);
-#else
- doc = f;
-#endif
- }
-
- UNGCPRO;
-
- ret = (int) ShellExecute (NULL,
- (STRINGP (operation) ?
- XSTRING_DATA (operation) : NULL),
- doc,
- (STRINGP (parameters) ?
- XSTRING_DATA (parameters) : NULL),
- path,
- (INTP (show_flag) ?
- XINT (show_flag) : SW_SHOWDEFAULT));
-
- if (ret > 32)
- return Qt;
-
- if (ret == ERROR_FILE_NOT_FOUND)
- signal_simple_error ("file not found", document);
- else if (ret == ERROR_PATH_NOT_FOUND)
- signal_simple_error ("path not found", current_dir);
- else if (ret == ERROR_BAD_FORMAT)
- signal_simple_error ("bad executable format", document);
- else
- error ("internal error");
-
- return Qnil;
-}
-
void
syms_of_gui_mswindows (void)
{
- DEFSUBR (Fmswindows_shell_execute);
}
/* General GUI code -- X-specific. (menubars, scrollbars, toolbars, dialogs)
Copyright (C) 1995 Board of Trustees, University of Illinois.
- Copyright (C) 1995, 1996 Ben Wing.
+ Copyright (C) 1995, 1996, 2000 Ben Wing.
Copyright (C) 1995 Sun Microsystems, Inc.
Copyright (C) 1998 Free Software Foundation, Inc.
/* Synched up with: Not in FSF. */
+/* This file Mule-ized by Ben Wing, 7-8-00. */
+
#include <config.h>
#include "lisp.h"
#include "redisplay.h"
#include "opaque.h"
-Lisp_Object Qmenu_no_selection_hook;
-
/* we need a unique id for each popup menu, dialog box, and scrollbar */
static unsigned int lwlib_id_tick;
static void
print_widget_value (widget_value *wv, int depth)
{
- /* !!#### This function has not been Mule-ized */
- char d [200];
+ /* strings in wv are in external format; use printf not stdout_out
+ because the latter takes internal-format strings */
+ Extbyte d [200];
int i;
for (i = 0; i < depth; i++) d[i] = ' ';
d[depth]=0;
callback = XCAR (XCDR (data));
callback_ex = XCDR (XCDR (data));
update_subwindows_p = 1;
+ /* It is possible for a widget action to cause it to get out of
+ sync with its instantiator. Thus it is necessary to signal
+ this possibility. */
+ if (IMAGE_INSTANCEP (image_instance))
+ XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (image_instance) = 1;
if (!NILP (callback_ex) && !UNBOUNDP (callback_ex))
{
event = Fmake_event (Qnil, Qnil);
-
+
XEVENT (event)->event_type = misc_user_event;
XEVENT (event)->channel = frame;
XEVENT (event)->event.eval.function = Qeval;
#endif
if (!NILP (event))
enqueue_Xt_dispatch_event (event);
- /* The result of this evaluation could cause other instances to change so
+ /* The result of this evaluation could cause other instances to change so
enqueue an update callback to check this. */
if (update_subwindows_p && !NILP (event))
enqueue_magic_eval_event (update_widget_instances, frame);
((void) (slot = (!NILP (form))))
#endif
-char *
-menu_separator_style (const char *s)
+Extbyte *
+menu_separator_style_and_to_external (const Bufbyte *s)
{
- const char *p;
- char first;
+ const Bufbyte *p;
+ Bufbyte first;
if (!s || s[0] == '\0')
return NULL;
? NULL /* single etched is the default */
: xstrdup ("shadowDoubleEtchedIn"));
else if (*p == ':')
- return xstrdup (p+1);
+ {
+ Extbyte *retval;
+
+ C_STRING_TO_EXTERNAL_MALLOC (p + 1, retval, Qlwlib_encoding);
+ return retval;
+ }
return NULL;
}
-char *
-strdup_and_add_accel (char *name)
+Extbyte *
+add_accel_and_to_external (Lisp_Object string)
{
int i;
int found_accel = 0;
+ Extbyte *retval;
+ Bufbyte *name = XSTRING_DATA (string);
- for (i=0; name[i]; ++i)
+ for (i = 0; name[i]; ++i)
if (name[i] == '%' && name[i+1] == '_')
{
found_accel = 1;
}
if (found_accel)
- return xstrdup (name);
+ LISP_STRING_TO_EXTERNAL_MALLOC (string, retval, Qlwlib_encoding);
else
{
- char *chars = (char *) alloca (strlen (name) + 3);
+ size_t namelen = XSTRING_LENGTH (string);
+ Bufbyte *chars = (Bufbyte *) alloca (namelen + 3);
chars[0] = '%';
chars[1] = '_';
- memcpy (chars+2, name, strlen (name) + 1);
- return xstrdup (chars);
+ memcpy (chars + 2, name, namelen + 1);
+ C_STRING_TO_EXTERNAL_MALLOC (chars, retval, Qlwlib_encoding);
}
+
+ return retval;
}
/* This does the dirty work. gc_currently_forbidden is 1 when this is called.
int
button_item_to_widget_value (Lisp_Object gui_object_instance,
Lisp_Object gui_item, widget_value *wv,
- int allow_text_field_p, int no_keys_p,
- int menu_entry_p)
+ int allow_text_field_p, int no_keys_p,
+ int menu_entry_p, int accel_p)
{
- /* !!#### This function has not been Mule-ized */
/* This function cannot GC because gc_currently_forbidden is set when
it's called */
Lisp_Gui_Item* pgui = 0;
if (STRINGP (gui_item))
{
wv->type = TEXT_TYPE;
- wv->name = (char *) XSTRING_DATA (gui_item);
- wv->name = strdup_and_add_accel (wv->name);
+ if (accel_p)
+ wv->name = add_accel_and_to_external (gui_item);
+ else
+ LISP_STRING_TO_EXTERNAL_MALLOC (gui_item, wv->name, Qlwlib_encoding);
return 1;
}
else if (!GUI_ITEMP (gui_item))
- signal_simple_error("need a string or a gui_item here", gui_item);
+ syntax_error ("need a string or a gui_item here", gui_item);
pgui = XGUI_ITEM (gui_item);
if (!NILP (pgui->filter))
- signal_simple_error(":filter keyword not permitted on leaf nodes", gui_item);
+ syntax_error (":filter keyword not permitted on leaf nodes", gui_item);
#ifdef HAVE_MENUBARS
if (menu_entry_p && !gui_item_included_p (gui_item, Vmenubar_configuration))
pgui->name = Feval (pgui->name);
CHECK_STRING (pgui->name);
- wv->name = (char *) XSTRING_DATA (pgui->name);
- wv->name = xstrdup (wv->name);
- wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
+ if (accel_p)
+ {
+ wv->name = add_accel_and_to_external (pgui->name);
+ wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
+ }
+ else
+ {
+ LISP_STRING_TO_EXTERNAL_MALLOC (pgui->name, wv->name, Qlwlib_encoding);
+ wv->accel = LISP_TO_VOID (Qnil);
+ }
if (!NILP (pgui->suffix))
{
- const char *const_bogosity;
Lisp_Object suffix2;
/* Shortcut to avoid evaluating suffix each time */
CHECK_STRING (suffix2);
}
- TO_EXTERNAL_FORMAT (LISP_STRING, suffix2,
- C_STRING_ALLOCA, const_bogosity,
- Qfile_name);
- wv->value = (char *) const_bogosity;
- wv->value = xstrdup (wv->value);
+ LISP_STRING_TO_EXTERNAL_MALLOC (suffix2, wv->value, Qlwlib_encoding);
}
wv_set_evalable_slot (wv->enabled, pgui->active);
CHECK_STRING (pgui->keys);
pgui->keys = Fsubstitute_command_keys (pgui->keys);
if (XSTRING_LENGTH (pgui->keys) > 0)
- wv->key = xstrdup ((char *) XSTRING_DATA (pgui->keys));
+ LISP_STRING_TO_EXTERNAL_MALLOC (pgui->keys, wv->key, Qlwlib_encoding);
else
wv->key = 0;
}
/* #### Warning, dependency here on current_buffer and point */
where_is_to_char (pgui->callback, buf);
if (buf [0])
- wv->key = xstrdup (buf);
+ C_STRING_TO_EXTERNAL_MALLOC (buf, wv->key, Qlwlib_encoding);
else
wv->key = 0;
}
CHECK_SYMBOL (pgui->style);
if (NILP (pgui->style))
{
+ Bufbyte *intname;
/* If the callback is nil, treat this item like unselectable text.
This way, dashes will show up as a separator. */
if (!wv->enabled)
wv->type = BUTTON_TYPE;
- if (separator_string_p (wv->name))
+ EXTERNAL_TO_C_STRING (wv->name, intname, Qlwlib_encoding);
+ if (separator_string_p (intname))
{
wv->type = SEPARATOR_TYPE;
- wv->value = menu_separator_style (wv->name);
+ wv->value = menu_separator_style_and_to_external (intname);
}
else
{
#endif
}
else
- signal_simple_error_2 ("Unknown style", pgui->style, gui_item);
+ syntax_error_2 ("Unknown style", pgui->style, gui_item);
if (!allow_text_field_p && (wv->type == TEXT_TYPE))
- signal_simple_error ("Text field not allowed in this context", gui_item);
+ syntax_error ("Text field not allowed in this context", gui_item);
if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
- signal_simple_error (
- ":selected only makes sense with :style toggle, radio or button",
- gui_item);
+ syntax_error
+ (":selected only makes sense with :style toggle, radio or button",
+ gui_item);
return 1;
}
/* parse tree's of gui items into widget_value hierarchies */
-static void gui_item_children_to_widget_values (Lisp_Object gui_object_instance,
+static void gui_item_children_to_widget_values (Lisp_Object
+ gui_object_instance,
Lisp_Object items,
- widget_value* parent);
+ widget_value* parent,
+ int accel_p);
static widget_value *
gui_items_to_widget_values_1 (Lisp_Object gui_object_instance,
Lisp_Object items, widget_value* parent,
- widget_value* prev)
+ widget_value* prev, int accel_p)
{
widget_value* wv = 0;
/* now walk the tree creating widget_values as appropriate */
if (!CONSP (items))
{
- wv = xmalloc_widget_value();
+ wv = xmalloc_widget_value ();
if (parent)
parent->contents = wv;
else
prev->next = wv;
if (!button_item_to_widget_value (gui_object_instance,
- items, wv, 0, 1, 0))
+ items, wv, 0, 1, 0, accel_p))
{
free_widget_value_tree (wv);
if (parent)
prev->next = 0;
}
else
- {
- wv->value = xstrdup (wv->name); /* what a mess... */
- }
+ wv->value = xstrdup (wv->name); /* what a mess... */
}
else
{
/* first one is the parent */
if (CONSP (XCAR (items)))
- signal_simple_error ("parent item must not be a list", XCAR (items));
+ syntax_error ("parent item must not be a list", XCAR (items));
if (parent)
wv = gui_items_to_widget_values_1 (gui_object_instance,
- XCAR (items), parent, 0);
+ XCAR (items), parent, 0, accel_p);
else
wv = gui_items_to_widget_values_1 (gui_object_instance,
- XCAR (items), 0, prev);
+ XCAR (items), 0, prev, accel_p);
/* the rest are the children */
gui_item_children_to_widget_values (gui_object_instance,
- XCDR (items), wv);
+ XCDR (items), wv, accel_p);
}
return wv;
}
static void
gui_item_children_to_widget_values (Lisp_Object gui_object_instance,
- Lisp_Object items, widget_value* parent)
+ Lisp_Object items, widget_value* parent,
+ int accel_p)
{
widget_value* wv = 0, *prev = 0;
Lisp_Object rest;
/* first one is master */
prev = gui_items_to_widget_values_1 (gui_object_instance, XCAR (items),
- parent, 0);
+ parent, 0, accel_p);
/* the rest are the children */
LIST_LOOP (rest, XCDR (items))
{
Lisp_Object tab = XCAR (rest);
- wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev);
+ wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev,
+ accel_p);
prev = wv;
}
}
widget_value *
-gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items)
+gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items,
+ int accel_p)
{
- /* !!#### This function has not been Mule-ized */
/* This function can GC */
widget_value *control = 0, *tmp = 0;
int count = specpdl_depth ();
Lisp_Object wv_closure;
if (NILP (items))
- signal_simple_error ("must have some items", items);
+ syntax_error ("must have some items", items);
/* Inhibit GC during this conversion. The reasons for this are
the same as in menu_item_descriptor_to_widget_value(); see
/* Also make sure that we free the partially-created widget_value
tree on Lisp error. */
- control = xmalloc_widget_value();
+ control = xmalloc_widget_value ();
wv_closure = make_opaque_ptr (control);
record_unwind_protect (widget_value_unwind, wv_closure);
- gui_items_to_widget_values_1 (gui_object_instance, items, control, 0);
+ gui_items_to_widget_values_1 (gui_object_instance, items, control, 0,
+ accel_p);
/* mess about getting the data we really want */
tmp = control;
syms_of_gui_x (void)
{
INIT_LRECORD_IMPLEMENTATION (popup_data);
-
- defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
}
void
Vpopup_callbacks = Qnil;
staticpro (&Vpopup_callbacks);
-
-#if 0
- /* This DEFVAR_LISP is just for the benefit of make-docfile. */
- /* #### misnamed */
- DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
-Function or functions to call when a menu or dialog box is dismissed
-without a selection having been made.
-*/ );
-#endif
- Fset (Qmenu_no_selection_hook, Qnil);
}
/* General GUI code -- X-specific header file.
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
- Copyright (C) 1996 Ben Wing.
+ Copyright (C) 1996, 2000 Ben Wing.
This file is part of XEmacs.
/* Synched up with: Not in FSF. */
+/* This file Mule-ized by Ben Wing, 7-8-00. */
+
#ifndef INCLUDED_gui_x_h_
#define INCLUDED_gui_x_h_
void free_popup_widget_value_tree (widget_value *wv);
void popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
XtPointer client_data);
-char *strdup_and_add_accel (char *name);
+Extbyte *add_accel_and_to_external (Lisp_Object string);
int button_item_to_widget_value (Lisp_Object gui_object_instance,
Lisp_Object gui_item, widget_value *wv,
- int allow_text_field_p, int no_keys_p,
- int menu_entry_p);
+ int allow_text_field_p, int no_keys_p,
+ int menu_entry_p, int accel_p);
widget_value * gui_items_to_widget_values (Lisp_Object gui_object_instance,
- Lisp_Object items);
-Lisp_Object menu_name_to_accelerator (char *name);
-char *menu_separator_style (const char *s);
+ Lisp_Object items, int accel_p);
+Extbyte *menu_separator_style_and_to_external (const Bufbyte *s);
Lisp_Object widget_value_unwind (Lisp_Object closure);
#endif /* INCLUDED_gui_x_h_ */
/* Synched up with: Not in FSF. */
+/* This file not quite Mule-ized yet but will be when merged with my
+ Mule workspace. --ben */
+
#include <config.h>
#include "lisp.h"
#include "gui.h"
#include "buffer.h"
#include "bytecode.h"
-Lisp_Object Q_active, Q_suffix, Q_keys, Q_style, Q_selected;
-Lisp_Object Q_filter, Q_config, Q_included, Q_key_sequence;
-Lisp_Object Q_accelerator, Q_label, Q_callback, Q_callback_ex, Q_value;
-Lisp_Object Qtoggle, Qradio;
+Lisp_Object Qmenu_no_selection_hook;
+Lisp_Object Vmenu_no_selection_hook;
static Lisp_Object parse_gui_item_tree_list (Lisp_Object list);
#endif /* HAVE_POPUPS */
int
-separator_string_p (const char *s)
+separator_string_p (const Bufbyte *s)
{
- const char *p;
- char first;
+ const Bufbyte *p;
+ Bufbyte first;
if (!s || s[0] == '\0')
return 0;
Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
if (!KEYWORDP (key))
- signal_simple_error_2 ("Non-keyword in gui item", key, pgui_item->name);
+ syntax_error_2 ("Non-keyword in gui item", key, pgui_item->name);
if (EQ (key, Q_suffix)) pgui_item->suffix = val;
else if (EQ (key, Q_active)) pgui_item->active = val;
if (SYMBOLP (val) || CHARP (val))
pgui_item->accelerator = val;
else if (ERRB_EQ (errb, ERROR_ME))
- signal_simple_error ("Bad keyboard accelerator", val);
+ syntax_error ("Bad keyboard accelerator", val);
}
else if (ERRB_EQ (errb, ERROR_ME))
- signal_simple_error_2 ("Unknown keyword in gui item", key,
+ syntax_error_2 ("Unknown keyword in gui item", key,
pgui_item->name);
}
contents = XVECTOR_DATA (item);
if (length < 1)
- signal_simple_error ("GUI item descriptors must be at least 1 elts long", item);
+ syntax_error ("GUI item descriptors must be at least 1 elts long", item);
/* length 1: [ "name" ]
length 2: [ "name" callback ]
{
int i;
if ((length - start) & 1)
- signal_simple_error (
+ syntax_error (
"GUI item descriptor has an odd number of keywords and values",
item);
|| !NILP (Feval (XGUI_ITEM (gui_item)->selected)));
}
+Lisp_Object
+gui_item_list_find_selected (Lisp_Object gui_item_list)
+{
+ /* This function can GC. */
+ Lisp_Object rest;
+ LIST_LOOP (rest, gui_item_list)
+ {
+ if (gui_item_selected_p (XCAR (rest)))
+ return XCAR (rest);
+ }
+ return XCAR (gui_item_list);
+}
+
/*
* Decide whether a GUI item is included by evaluating its :included
* form if given, and testing its :config form against supplied CONFLIST
static DOESNT_RETURN
signal_too_long_error (Lisp_Object name)
{
- signal_simple_error ("GUI item produces too long displayable string", name);
+ syntax_error ("GUI item produces too long displayable string", name);
}
#ifdef HAVE_WINDOW_SYSTEM
return id;
}
-static int
-gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+int
+gui_item_equal_sans_selected (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
Lisp_Gui_Item *p1 = XGUI_ITEM (obj1);
Lisp_Gui_Item *p2 = XGUI_ITEM (obj2);
&&
EQ (p1->style, p2->style)
&&
- EQ (p1->selected, p2->selected)
- &&
EQ (p1->accelerator, p2->accelerator)
&&
EQ (p1->keys, p2->keys)
return 1;
}
+static int
+gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+{
+ Lisp_Gui_Item *p1 = XGUI_ITEM (obj1);
+ Lisp_Gui_Item *p2 = XGUI_ITEM (obj2);
+
+ if (!(gui_item_equal_sans_selected (obj1, obj2, depth)
+ &&
+ EQ (p1->selected, p2->selected)))
+ return 0;
+ return 1;
+}
+
static void
print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
}
else if (GUI_ITEMP (arg))
return copy_gui_item (arg);
- else
+ else
return arg;
}
CHECK_STRING (entry);
}
else
- signal_simple_error ("item must be a vector or a string", entry);
+ syntax_error ("item must be a vector or a string", entry);
RETURN_UNGCPRO (ret);
}
{
INIT_LRECORD_IMPLEMENTATION (gui_item);
- defkeyword (&Q_active, ":active");
- defkeyword (&Q_suffix, ":suffix");
- defkeyword (&Q_keys, ":keys");
- defkeyword (&Q_key_sequence,":key-sequence");
- defkeyword (&Q_style, ":style");
- defkeyword (&Q_selected, ":selected");
- defkeyword (&Q_filter, ":filter");
- defkeyword (&Q_config, ":config");
- defkeyword (&Q_included, ":included");
- defkeyword (&Q_accelerator, ":accelerator");
- defkeyword (&Q_label, ":label");
- defkeyword (&Q_callback, ":callback");
- defkeyword (&Q_callback_ex, ":callback-ex");
- defkeyword (&Q_value, ":value");
-
- defsymbol (&Qtoggle, "toggle");
- defsymbol (&Qradio, "radio");
+ DEFSYMBOL (Qmenu_no_selection_hook);
#ifdef HAVE_POPUPS
DEFSUBR (Fpopup_up_p);
void
vars_of_gui (void)
{
+ DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
+Function or functions to call when a menu or dialog box is dismissed
+without a selection having been made.
+*/ );
+ Vmenu_no_selection_hook = Qnil;
}
#ifndef INCLUDED_gui_h_
#define INCLUDED_gui_h_
-int separator_string_p (const char *s);
+int separator_string_p (const Bufbyte *s);
void get_gui_callback (Lisp_Object, Lisp_Object *, Lisp_Object *);
+int gui_item_equal_sans_selected (Lisp_Object obj1, Lisp_Object obj2, int depth);
extern int popup_up_p;
#define CHECK_GUI_ITEM(x) CHECK_RECORD (x, gui_item)
#define CONCHECK_GUI_ITEM(x) CONCHECK_RECORD (x, gui_item)
-extern Lisp_Object Q_accelerator, Q_active, Q_config, Q_filter, Q_included;
-extern Lisp_Object Q_keys, Q_selected, Q_suffix, Qradio, Qtoggle;
-extern Lisp_Object Q_key_sequence, Q_label, Q_callback, Q_callback_ex, Q_value;
-
void gui_item_add_keyval_pair (Lisp_Object,
Lisp_Object key, Lisp_Object val,
Error_behavior errb);
void gui_add_item_keywords_to_plist (Lisp_Object plist, Lisp_Object gui_item);
int gui_item_active_p (Lisp_Object);
int gui_item_selected_p (Lisp_Object);
+Lisp_Object gui_item_list_find_selected (Lisp_Object gui_item_list);
int gui_item_included_p (Lisp_Object, Lisp_Object into);
Lisp_Object gui_item_accelerator (Lisp_Object gui_item);
Lisp_Object gui_name_accelerator (Lisp_Object name);
Lisp_Object parse_gui_item_tree_children (Lisp_Object list);
Lisp_Object copy_gui_item_tree (Lisp_Object arg);
+extern Lisp_Object Qmenu_no_selection_hook, Qdelete_dialog_box_hook;
+
/* this is mswindows biased but reasonably safe I think */
#define GUI_ITEM_ID_SLOTS 8
#define GUI_ITEM_ID_MIN(s) (s * 0x2000)
#include "gui-x.h"
#endif
+#ifdef HAVE_MS_WINDOWS
+#include "console-msw.h"
+#endif
+
#ifdef FILE_CODING
#include "file-coding.h"
#endif
static XIMStyle best_style (XIMStyles *user, XIMStyles *xim);
+/* #### it appears this prototype is missing from the X11R6.4 includes,
+ at least the XFree86 version ... */
+char * XSetIMValues(XIM, ...);
+
void
Initialize_Locale (void)
{
#ifdef THIS_IS_X11R6
DEVICE_X_XIM (d) = NULL;
XRegisterIMInstantiateCallback (DEVICE_X_DISPLAY (d), NULL, NULL, NULL,
- IMInstantiateCallback, (XPointer) d);
+ IMInstantiateCallback,
+ /* The sixth parameter is of type
+ XPointer in XFree86 but (XPointer *)
+ on most other X11's. */
+ (void *) d);
return;
#else
Display *dpy = DEVICE_X_DISPLAY (d);
{
Lisp_Keymap *k;
- if ((modifiers & ~(XEMACS_MOD_CONTROL | XEMACS_MOD_META | XEMACS_MOD_SUPER | XEMACS_MOD_HYPER
- | XEMACS_MOD_ALT | XEMACS_MOD_SHIFT)) != 0)
+ modifiers &= ~(XEMACS_MOD_BUTTON1 | XEMACS_MOD_BUTTON2 | XEMACS_MOD_BUTTON3
+ | XEMACS_MOD_BUTTON4 | XEMACS_MOD_BUTTON5);
+ if ((modifiers & ~(XEMACS_MOD_CONTROL | XEMACS_MOD_META | XEMACS_MOD_SUPER
+ | XEMACS_MOD_HYPER | XEMACS_MOD_ALT | XEMACS_MOD_SHIFT))
+ != 0)
abort ();
k = XKEYMAP (keymap);
int modifiers = key->modifiers;
Lisp_Keymap *k = XKEYMAP (keymap);
+ modifiers &= ~(XEMACS_MOD_BUTTON1 | XEMACS_MOD_BUTTON2 | XEMACS_MOD_BUTTON3
+ | XEMACS_MOD_BUTTON4 | XEMACS_MOD_BUTTON5);
assert ((modifiers & ~(XEMACS_MOD_CONTROL | XEMACS_MOD_META
| XEMACS_MOD_SUPER | XEMACS_MOD_HYPER
| XEMACS_MOD_ALT | XEMACS_MOD_SHIFT)) == 0);
XVECTOR_DATA (new_keys) [i] = XVECTOR_DATA (keys) [i];
}
else
- abort ();
+ {
+ new_keys = Qnil;
+ abort ();
+ }
if (EQ (keys, new_keys))
error_with_frob (mpc_binding,
if (!NILP (elt_prefix))
buffer_insert_lisp_string (buf, elt_prefix);
- if (modifiers & XEMACS_MOD_META) buffer_insert_c_string (buf, "M-");
- if (modifiers & XEMACS_MOD_CONTROL) buffer_insert_c_string (buf, "C-");
- if (modifiers & XEMACS_MOD_SUPER) buffer_insert_c_string (buf, "S-");
- if (modifiers & XEMACS_MOD_HYPER) buffer_insert_c_string (buf, "H-");
- if (modifiers & XEMACS_MOD_ALT) buffer_insert_c_string (buf, "Alt-");
- if (modifiers & XEMACS_MOD_SHIFT) buffer_insert_c_string (buf, "Sh-");
+ if (modifiers & XEMACS_MOD_META)
+ buffer_insert_c_string (buf, "M-");
+ if (modifiers & XEMACS_MOD_CONTROL)
+ buffer_insert_c_string (buf, "C-");
+ if (modifiers & XEMACS_MOD_SUPER)
+ buffer_insert_c_string (buf, "S-");
+ if (modifiers & XEMACS_MOD_HYPER)
+ buffer_insert_c_string (buf, "H-");
+ if (modifiers & XEMACS_MOD_ALT)
+ buffer_insert_c_string (buf, "Alt-");
+ if (modifiers & XEMACS_MOD_SHIFT)
+ buffer_insert_c_string (buf, "Sh-");
if (SYMBOLP (keysym))
{
Lisp_Object code = Fget (keysym, Vcharacter_set_property, Qnil);
EXFUN (Fwhere_is_internal, 5);
extern Lisp_Object Qalt, Qcontrol, Qhyper, Qmeta, Qshift, Qsuper;
+extern Lisp_Object Qbutton1, Qbutton2, Qbutton3, Qbutton4, Qbutton5;
extern Lisp_Object Vmeta_prefix_char;
Lisp_Object get_keymap (Lisp_Object object, int errorp, int autoload);
}
/* Flag LINE_NUMBER_BEGV (b) as dirty. Do it only if the line number
- cache is already initialized. */
+ cache is already initialized. */
void
narrow_line_number_cache (struct buffer *b)
{
xset_var->gu.type = Lisp_Type_Char; \
xset_var->gu.val = xset_value; \
} while (0)
-# define XSETOBJ(var, vartype, value) do { \
+# define XSETOBJ(var, value) do { \
EMACS_UINT xset_value = (EMACS_UINT) (value); \
(var).ui = xset_value; \
} while (0)
make_int (EMACS_INT val)
{
Lisp_Object obj;
- XSETINT(obj, val);
+ XSETINT (obj, val);
return obj;
}
make_char (Emchar val)
{
Lisp_Object obj;
- XSETCHAR(obj, val);
+ XSETCHAR (obj, val);
+ return obj;
+}
+
+INLINE_HEADER Lisp_Object wrap_object (void *ptr);
+INLINE_HEADER Lisp_Object
+wrap_object (void *ptr)
+{
+ Lisp_Object obj;
+ XSETOBJ (obj, ptr);
return obj;
}
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* This prevents Emacs dumping an unsqueezed binary with the
SQUEEZE bit set in the magic number. */
#define UNEXEC "unexfx2800.o"
#define LIBS_MACHINE "-lalliant"
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES*/
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* Do not define LOAD_AVE_TYPE or LOAD_AVE_CVT
since there is no /dev/kmem */
-/* Undefine VIRT_ADDR_VARIES because the virtual addresses of
- pure and impure space as loaded do not vary. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define HAVE_ALLOCA because we use the system's version of alloca. */
#define HAVE_ALLOCA
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
-
/* this brings in alloca() if we're using cc */
#ifdef USG
#define NO_REMAP
#endif /* USG */
#ifdef WIN32_NATIVE
-#define VIRT_ADDR_VARIES
#define DATA_END get_data_end ()
#define DATA_START get_data_start ()
#define HAVE_ALLOCA
and temacs will do (load "loadup") automatically unless told otherwise. */
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */ /* Karl Kleinpaste says this isn't needed. */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
and temacs will do (load "loadup") automatically unless told otherwise. */
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */ /* Karl Kleinpaste says this isn't needed. */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/*#define VIRT_ADDR_VARIES*/
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/*#define CANNOT_DUMP*/
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that data space precedes text space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that data space precedes text space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define NO_REMAP if memory segmentation makes it not work well
to change the boundary between the text section and data section
when Emacs is dumped. If you define this, the preloaded Lisp
/*#define CANNOT_DUMP /**/
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES /**/
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#define VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#define VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* XEmacs: Richard Cognot <cognot@ensg.u-nancy.fr> says we need this for
HPUX; but eeide@asylum.cs.utah.edu (Eric Eide) says it loses on BSD. */
#ifndef BSD
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define addresses, macros, change some setup for dump */
#define NO_REMAP
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
#ifdef XENIX
/* Define NO_REMAP if memory segmentation makes it not work well
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
#ifdef linux
#define NO_REMAP
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* ns16000's have an unexec, so should the mg-1 */
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-/* hmmmm... not sure. copied sequent.h */
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#define LOAD_AVE_CVT(x) (int) (((double) (x)) * 100.0 / FSCALE)
#else /* mklinux */
-/* Define NO_ARG_ARRAY if you cannot take the address of the first of a
- * group of arguments and treat it as an array of the arguments. */
-
-#define NO_ARG_ARRAY
-
/* Define addresses, macros, change some setup for dump */
#define NO_REMAP
-/* Use type int rather than a union, to represent Lisp_Object */
-
-/* #define NO_UNION_TYPE */
-
#ifdef CANNOT_DUMP
#endif /* CANNOT_DUMP */
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* The STRIDE system is more powerful than standard USG5. */
#define HAVE_PTYS
and temacs will do (load "loadup") automatically unless told otherwise. */
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */ /* Karl Kleinpaste says this isn't needed. */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
and temacs will do (load "loadup") automatically unless told otherwise. */
/*#define CANNOT_DUMP*/
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-/* #define VIRT_ADDR_VARIES */
-
/* Define NO_REMAP if memory segmentation makes it not work well
to change the boundary between the text section and data section
when Emacs is dumped. If you define this, the preloaded Lisp
#define CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#define VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that data space precedes text space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
#undef CANNOT_DUMP
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-#undef VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
operating system this machine is likely to run.
USUAL-OPSYS="<name of system .h file here, without the s- or .h>" */
-/* Define NO_ARG_ARRAY if you cannot take the address of the first of a
- * group of arguments and treat it as an array of the arguments. */
-
-#define NO_ARG_ARRAY
-
/* Now define a symbol for the cpu type, if your compiler
does not define it automatically:
Ones defined so far include vax, m68000, ns16000, pyramid,
orion, tahoe, APOLLO and many others */
-/* Use type int rather than a union, to represent Lisp_Object */
-/* This is desirable for most machines. */
-
-#define NO_UNION_TYPE
-
-/* Data type of load average, as read out of kmem. */
-
-#define LOAD_AVE_TYPE long
-
-/* Convert that into an integer that is 100 for a load average of 1.0 */
-
-#define LOAD_AVE_CVT(x) (int) (((double) (x)) * 100.0 / FSCALE)
-
/* Define CANNOT_DUMP on machines where unexec does not work.
Then the function dump-emacs will not be defined
and temacs will do (load "loadup") automatically unless told otherwise. */
#define CANNOT_UNEXEC 1
*/
+/* Do not define LOAD_AVE_TYPE or LOAD_AVE_CVT
+ since there is no load average available. */
+
/* Start and end of text and data. */
#define DATA_END get_data_end ()
#define DATA_START get_data_start ()
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* Text does precede data space, but this is never a safe assumption. */
-#define VIRT_ADDR_VARIES
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
/* #define CANNOT_DUMP */
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
/* Define C_ALLOCA if this machine does not support a true alloca
and the one written in C should be used instead.
Define HAVE_ALLOCA to say that the system provides a properly
$generated_header{$_} = 1;
}
+# Although this is not technically true, it ought to be true,
+# and makes the generated Makefile smaller.
+$uses{'lisp.h'}{'config.h'} = 1;
+
for my $file (keys %exists) {
open (FILE, $file) or die "$file: $!";
undef $/; $_ = <FILE>;
# Print file header
print
-"## This file automatically generated by $myName. Do not modify.
+"## This file is automatically generated by \`$myName'. Do not modify.
-#ifdef USE_UNION_TYPE
+#if defined(USE_UNION_TYPE)
LISP_UNION_H=lisp-union.h
#else
LISP_UNION_H=lisp-disunion.h
#endif
";
-my @LISP_H = ('lisp.h', 'config.h');
-#@LISP_H = grep (! /lisp-(dis)?union\.h/, @LISP_H);
-print "LISP_H = @{[grep (!/lisp-(dis)?union\.h/, @LISP_H)]} \$(LISP_UNION_H)\n";
+my @LISP_H = ('lisp.h', keys %{$uses{'lisp.h'}});
+print "LISP_H=@{[grep (!/lisp-(dis)?union\.h/, @LISP_H)]} \$(LISP_UNION_H)\n";
sub PrintDeps {
my $file = shift;
sub PrintPatternDeps {
my ($pattern, $CPP_SYMBOL) = @_;
- print "#ifdef $CPP_SYMBOL\n";
+ print "#if defined($CPP_SYMBOL)\n";
for my $file (sort grep (/$pattern/ && /\.c$/, keys %uses)) {
PrintDeps($file);
delete $uses{$file};
print "#endif\n";
}
-PrintPatternDeps ('-msw', "HAVE_MS_WINDOWS");
-PrintPatternDeps ('-x', "HAVE_X_WINDOWS");
-PrintPatternDeps ('database', "HAVE_DATABASE");
-PrintPatternDeps ('^mule', "MULE");
+PrintPatternDeps ('-msw\\.', "HAVE_MS_WINDOWS");
+PrintPatternDeps ('-x\\.', "HAVE_X_WINDOWS");
+PrintPatternDeps ('-tty\\.', "HAVE_TTY");
+PrintPatternDeps ('^database', "HAVE_DATABASE");
+PrintPatternDeps ('^mule', "MULE");
PrintPatternDeps ('^(?:External|extw-)', "EXTERNAL_WIDGET");
for my $file (sort grep (/\.c$/, keys %uses)) { PrintDeps($file); }
+# Surprisingly robust regexp to remove comments from arbitrary C code
sub RemoveComments {
$_[0] =~
s{ (
#define MENU_ITEM_ID_BITS(x) (((x) & 0x7FFF) | 0x8000)
static HMENU top_level_menu;
-/* Translate (in place) %_ to &, %% to %.
- Return new length, and (through accel) the accelerator character.
- (If there is no accelerator, it will be added on the first character.)
- len = number of bytes (not including zero terminator).
- maxlen = size of buffer.
- We assume and maintain zero-termination. To be absolutely sure
- of not hitting an error, maxlen should be >= 2*len + 3. */
-
+/*
+ * Translate (in place) X accelerator syntax to win32 accelerator syntax.
+ * Return new length.
+ * len = number of bytes (not including zero terminator).
+ * maxlen = size of buffer.
+ * accel = (Emchar*) to receive the accelerator character
+ * or NULL to suppress accelerators in the menu or dialog item.
+ *
+ * %% is replaced with %
+ * if accel is NULL:
+ * %_ is removed.
+ * if accel is non-NULL:
+ * %_ is replaced with &.
+ * The accelerator character is passed back in *accel.
+ * (If there is no accelerator, it will be added on the first character.)
+ *
+ * We assume and maintain zero-termination. To be absolutely sure
+ * of not hitting an error, maxlen should be >= 2*len + 3.
+ */
Bytecount
mswindows_translate_menu_or_dialog_item (Bufbyte *item, Bytecount len,
- Bytecount maxlen, Emchar *accel,
- Lisp_Object error_name)
+ Bytecount maxlen, Emchar *accel,
+ Lisp_Object error_name)
{
Bufbyte *ptr;
- *accel = '\0';
+ if (accel)
+ *accel = '\0';
/* Escape '&' as '&&' */
-
ptr = item;
while ((ptr = (Bufbyte *) memchr (ptr, '&', len - (ptr - item))) != NULL)
{
if (len + 2 > maxlen)
- signal_simple_error ("Menu item produces too long displayable string",
- error_name);
+ syntax_error ("Menu item produces too long displayable string",
+ error_name);
memmove (ptr + 1, ptr, (len - (ptr - item)) + 1);
len++;
ptr += 2;
{
if (*(ptr + 1) == '_')
{
- *ptr = '&';
- if (!*accel)
- /* #### urk ! We need a reference translation table for
- case changes that aren't buffer-specific. */
- *accel = DOWNCASE (current_buffer, charptr_emchar (ptr + 2));
- memmove (ptr + 1, ptr + 2, len - (ptr - item + 2) + 1);
- len--;
+ if (accel)
+ {
+ *ptr = '&';
+ if (!*accel)
+ /* #### urk ! We need a reference translation table for
+ case changes that aren't buffer-specific. */
+ *accel = DOWNCASE (current_buffer, charptr_emchar (ptr + 2));
+ memmove (ptr + 1, ptr + 2, len - (ptr - item + 2) + 1);
+ len--;
+ }
+ else /* Skip accelerator */
+ {
+ memmove (ptr, ptr + 2, len - (ptr - item + 2) + 1);
+ len-=2;
+ }
}
else if (*(ptr + 1) == '%')
{
memmove (ptr + 1, ptr + 2, len - (ptr - item + 2) + 1);
len--;
+ ptr++;
}
- ptr++;
+ else /* % on its own - shouldn't happen */
+ ptr++;
}
- if (!*accel)
+ if (accel && !*accel)
{
+ /* Force a default accelerator */
if (len + 2 > maxlen)
- signal_simple_error ("Menu item produces too long displayable string",
- error_name);
+ syntax_error ("Menu item produces too long displayable string",
+ error_name);
ptr = item;
memmove (ptr + 1, ptr, len + 1);
/* #### urk ! We need a reference translation table for
/* We construct the name in a static buffer. That's fine, because
menu items longer than 128 chars are probably programming errors,
and better be caught than displayed! */
-
+
static char buf[MAX_MENUITEM_LENGTH+2];
/* Left flush part of the string */
return HASH2 (internal_hash (XVECTOR_DATA(item)[0], 0),
internal_hash (XVECTOR_DATA(item)[1], 0));
}
-
+
/* An error - will be caught later */
return 0;
}
int flush_right, int bar_p)
{
MENUITEMINFO item_info;
+ UINT oldflags = MF_BYPOSITION;
+ UINT olduidnewitem = 0;
+ LPCTSTR oldlpnewitem = 0;
item_info.cbSize = sizeof (item_info);
item_info.fMask = MIIM_TYPE | MIIM_STATE | MIIM_ID;
{
/* Separator or unselectable text */
if (separator_string_p (XSTRING_DATA (item)))
- item_info.fType = MFT_SEPARATOR;
+ {
+ item_info.fType = MFT_SEPARATOR;
+ oldflags |= MF_SEPARATOR;
+ }
else
{
item_info.fType = MFT_STRING;
item_info.fState = MFS_DISABLED;
item_info.dwTypeData = XSTRING_DATA (item);
+ oldflags |= MF_STRING | MF_DISABLED;
+ oldlpnewitem = item_info.dwTypeData;
}
}
else if (CONSP (item))
menu_parse_submenu_keywords (item, gui_item);
if (!STRINGP (pgui_item->name))
- signal_simple_error ("Menu name (first element) must be a string",
+ syntax_error ("Menu name (first element) must be a string",
item);
if (!gui_item_included_p (gui_item, Vmenubar_configuration))
- {
- UNGCPRO;
- goto done;
- }
+ {
+ UNGCPRO;
+ goto done;
+ }
if (!gui_item_active_p (gui_item))
- item_info.fState = MFS_GRAYED;
+ {
+ item_info.fState = MFS_GRAYED;
+ oldflags |= MF_GRAYED;
+ }
/* Temptation is to put 'else' right here. Although, the
displayed item won't have an arrow indicating that it is a
popup. So we go ahead a little bit more and create a popup */
item_info.fMask |= MIIM_SUBMENU;
item_info.dwTypeData = displayable_menu_item (gui_item, bar_p, &accel);
item_info.hSubMenu = submenu;
+ olduidnewitem = (UINT) submenu;
+ oldlpnewitem = item_info.dwTypeData;
+ oldflags |= MF_POPUP;
if (accel && bar_p)
*accel_list = Fcons (make_char (accel), *accel_list);
Fputhash (hmenu_to_lisp_object (submenu), path, hash_tab);
}
UNGCPRO;
- }
+ }
else if (VECTORP (item))
{
/* An ordinary item */
GCPRO2 (gui_item, *accel_list);
if (!gui_item_included_p (gui_item, Vmenubar_configuration))
- {
- UNGCPRO;
- goto done;
- }
+ {
+ UNGCPRO;
+ goto done;
+ }
if (!STRINGP (pgui_item->name))
pgui_item->name = Feval (pgui_item->name);
if (!gui_item_active_p (gui_item))
- item_info.fState = MFS_GRAYED;
+ {
+ item_info.fState = MFS_GRAYED;
+ oldflags = MF_GRAYED;
+ }
style = (NILP (pgui_item->selected) || NILP (Feval (pgui_item->selected))
? Qnil : pgui_item->style);
{
item_info.fType |= MFT_RADIOCHECK;
item_info.fState |= MFS_CHECKED;
+ oldflags |= MF_CHECKED; /* Can't support radio-button checkmarks
+ under 3.51 */
}
else if (EQ (style, Qtoggle))
{
item_info.fState |= MFS_CHECKED;
+ oldflags |= MF_CHECKED;
}
id = allocate_menu_item_id (path, pgui_item->name,
item_info.wID = (UINT) XINT (id);
item_info.fType |= MFT_STRING;
item_info.dwTypeData = displayable_menu_item (gui_item, bar_p, &accel);
+ olduidnewitem = item_info.wID;
+ oldflags |= MF_STRING;
+ oldlpnewitem = item_info.dwTypeData;
if (accel && bar_p)
*accel_list = Fcons (make_char (accel), *accel_list);
UNGCPRO;
}
else
- {
- signal_simple_error ("Malformed menu item descriptor", item);
- }
+ syntax_error ("Malformed menu item descriptor", item);
if (flush_right)
- item_info.fType |= MFT_RIGHTJUSTIFY;
+ item_info.fType |= MFT_RIGHTJUSTIFY; /* can't support in 3.51 */
- InsertMenuItem (menu, UINT_MAX, TRUE, &item_info);
+ if (xInsertMenuItemA)
+ xInsertMenuItemA (menu, UINT_MAX, TRUE, &item_info);
+ else
+ InsertMenu (menu, UINT_MAX, oldflags, olduidnewitem, oldlpnewitem);
done:;
-}
+}
/*
* This function is called from populate_menu and checksum_menu.
/* Check that menu name is specified when expected */
if (NILP (pgui_item->name) && deep_p)
- signal_simple_error ("Menu must have a name", desc);
+ syntax_error ("Menu must have a name", desc);
/* Apply filter if specified */
if (!NILP (pgui_item->filter))
checksum = HASH2 (checksum,
checksum_menu_item (XCAR (item_desc)));
}
-
+
if (populate_p)
{
/* Remove the "(empty)" item, if there are other ones */
{
CHECK_STRING (pgui_item->name);
InsertMenu (menu, 0, MF_BYPOSITION | MF_STRING | MF_DISABLED,
- 0, XSTRING_DATA(pgui_item->name));
+ 0, displayable_menu_item (gui_item, bar_p, NULL));
InsertMenu (menu, 1, MF_BYPOSITION | MF_SEPARATOR, 0, NULL);
- SetMenuDefaultItem (menu, 0, MF_BYPOSITION);
+ if (xSetMenuDefaultItem) /* not in NT 3.5x */
+ xSetMenuDefaultItem (menu, 0, MF_BYPOSITION);
}
}
Fputhash (hmenu_to_lisp_object (menubar), Qnil,
FRAME_MSWINDOWS_MENU_HASH_TABLE (f));
- populate_menu (menubar, Qnil, desc,
+ populate_menu (menubar, Qnil, desc,
FRAME_MSWINDOWS_MENU_HASH_TABLE (f), 1);
UNGCPRO;
}
{
Lisp_Object hash = FRAME_MSWINDOWS_MENU_HASH_TABLE (f);
- assert (HASH_TABLEP (hash));
+ if (NILP (hash))
+ return 0;
/* !!#### not Mule-ized */
return !NILP (memq_no_quit (make_char (tolower (ch)),
Fgethash (Qt, hash, Qnil)));
}
-
+
\f
/*------------------------------------------------------------------------*/
/* Message handlers */
XSETFRAME (frame, f);
/* this used to call mswindows_enqueue_misc_user_event but that
breaks customize because the misc_event gets eval'ed in some
- cicumstances. Don't change it back unless you can fix the
+ circumstances. Don't change it back unless you can fix the
customize problem also.*/
enqueue_misc_user_event (frame, fn, arg);
mswindows_enqueue_magic_event (NULL, XM_BUMPQUEUE);
menu = create_empty_popup_menu ();
Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hash_table);
top_level_menu = menu;
-
+
/* see comments in menubar-x.c */
if (zmacs_regions)
zmacs_region_stays = 1;
-
+
ok = TrackPopupMenu (menu,
TPM_LEFTALIGN | TPM_LEFTBUTTON | TPM_RIGHTBUTTON,
pt.x, pt.y, 0,
/* Implements an elisp-programmable menubar -- X interface.
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+ Copyright (C) 2000 Ben Wing.
This file is part of XEmacs.
/* Synched up with: Not in FSF. */
+/* This file Mule-ized by Ben Wing, 7-8-00. */
+
/* Authorship:
Created 16-dec-91 by Jamie Zawinski.
/* This function cannot GC.
It is only called from menu_item_descriptor_to_widget_value, which
prohibits GC. */
- /* !!#### This function has not been Mule-ized */
int menubar_root_p = (menu_type == MENUBAR_TYPE && depth == 0);
int count = specpdl_depth ();
int partition_seen = 0;
if (STRINGP (desc))
{
- char *string_chars = (char *) XSTRING_DATA (desc);
+ Bufbyte *string_chars = XSTRING_DATA (desc);
wv->type = (separator_string_p (string_chars) ? SEPARATOR_TYPE :
TEXT_TYPE);
-#if 1
- /* #### - should internationalize with X resources instead.
- Not so! --ben */
- string_chars = GETTEXT (string_chars);
-#endif
if (wv->type == SEPARATOR_TYPE)
{
- wv->value = menu_separator_style (string_chars);
+ wv->value = menu_separator_style_and_to_external (string_chars);
}
else
{
- wv->name = xstrdup (string_chars);
+ LISP_STRING_TO_EXTERNAL_MALLOC (desc, wv->name, Qlwlib_encoding);
wv->enabled = 1;
/* dverna Dec. 98: command_builder_operate_menu_accelerator will
manipulate the accel as a Lisp_Object if the widget has a name.
if (!button_item_to_widget_value (Qmenubar,
gui_item, wv, 1,
(menu_type == MENUBAR_TYPE
- && depth <= 1), 1))
+ && depth <= 1), 1, 1))
{
/* :included form was nil */
wv = NULL;
int active_spec = 0;
wv->type = CASCADE_TYPE;
wv->enabled = 1;
- wv->name = (char *) XSTRING_DATA (LISP_GETTEXT (XCAR (desc)));
- wv->name = strdup_and_add_accel (wv->name);
+ wv->name = add_accel_and_to_external (XCAR (desc));
- accel = gui_name_accelerator (LISP_GETTEXT (XCAR (desc)));
+ accel = gui_name_accelerator (XCAR (desc));
wv->accel = LISP_TO_VOID (accel);
desc = Fcdr (desc);
Lisp_Object cascade = desc;
desc = Fcdr (desc);
if (NILP (desc))
- signal_simple_error ("Keyword in menu lacks a value",
- cascade);
+ syntax_error ("Keyword in menu lacks a value", cascade);
val = Fcar (desc);
desc = Fcdr (desc);
if (EQ (key, Q_included))
|| CHARP (val))
wv->accel = LISP_TO_VOID (val);
else
- signal_simple_error ("bad keyboard accelerator", val);
+ syntax_error ("bad keyboard accelerator", val);
}
else if (EQ (key, Q_label))
{
/* implement in 21.2 */
}
else
- signal_simple_error ("Unknown menu cascade keyword", cascade);
+ syntax_error ("Unknown menu cascade keyword", cascade);
}
if ((!NILP (config_tag)
title_wv->enabled = 1;
title_wv->next = sep_wv;
sep_wv->type = SEPARATOR_TYPE;
- sep_wv->value = menu_separator_style ("==");
+ sep_wv->value = menu_separator_style_and_to_external ("==");
sep_wv->next = 0;
wv->contents = title_wv;
}
else
{
- signal_simple_error ("Menu name (first element) must be a string",
- desc);
+ syntax_error ("Menu name (first element) must be a string", desc);
}
if (deep_p || menubar_root_p)
if (menubar_root_p && NILP (child)) /* the partition */
{
if (partition_seen)
- error (
- "More than one partition (nil) in menubar description");
+ syntax_error
+ ("More than one partition (nil) in menubar description",
+ desc);
partition_seen = 1;
next = xmalloc_widget_value ();
next->type = PUSHRIGHT_TYPE;
wv = NULL;
}
else if (NILP (desc))
- error ("nil may not appear in menu descriptions");
+ syntax_error ("nil may not appear in menu descriptions", desc);
else
- signal_simple_error ("Unrecognized menu descriptor", desc);
+ syntax_error ("Unrecognized menu descriptor", desc);
menu_item_done:
INC_CHARPTR (name_data);
}
+ if (string_result_ptr - string_result == XSTRING_LENGTH (name)
+ && !memcmp (string_result, XSTRING_DATA (name), XSTRING_LENGTH (name)))
+ return name;
+
return make_string (string_result, string_result_ptr - string_result);
}
:included (memq symbol menubar-configuration)
See the variable `menubar-configuration'.
- :filter <function> A menu filter can only be used in a menu item list.
- (i.e. not in a menu item itself). It is used to
+ :filter <function> A menu filter can only be used at the beginning of a
+ submenu description (i.e. not in a menu item itself).
+ (Remember that most of the keywords can take evaluated
+ expressions as well as constants.) The filter is used to
incrementally create a submenu only when it is selected
by the user and not every time the menubar is activated.
The filter function is passed the list of menu items in
- the submenu and must return a list of menu items to be
- used for the menu. It must not destructively modify
+ the submenu and must return the modified list to be
+ actually used. The filter MUST NOT destructively modify
the list of menu items passed to it. It is called only
when the menu is about to be displayed, so other menus
may already be displayed. Vile and terrible things will
:key-sequence keys Used in FSF Emacs as an hint to an equivalent keybinding.
Ignored by XEmacs for easymenu.el compatibility.
+ (XEmacs computes this information automatically.)
For example:
extern int in_menu_callback;
#endif
-
+
#endif /* HAVE_MENUBARS */
#endif /* INCLUDED_menubar_h_ */
#include <unistd.h>
#endif
+/* NAS <= 1.2p5 defines {BIG,LITTLE}_ENDIAN in <audio/fileutil.h>,
+ conflicting with GNU libc (at least); newer versions avoid this
+ name space pollution.
+ DO NOT USE THOSE MACROS in this file. Use NAS_{BIG,LITTLE}_ENDIAN.
+
+ It would be slightly more reliable to do this via configure, but that
+ seems unnecessarily complex.
+*/
#undef LITTLE_ENDIAN
#undef BIG_ENDIAN
+
#include <audio/audiolib.h>
#include <audio/soundlib.h>
#include <audio/snd.h>
#include <audio/wave.h>
#include <audio/fileutil.h>
+/* NAS <= 1.2p5 <audio/fileutil.h> doesn't define the NAS_ versions */
+#ifndef NAS_LITTLE_ENDIAN
+#define NAS_LITTLE_ENDIAN LITTLE_ENDIAN
+#define NAS_BIG_ENDIAN BIG_ENDIAN
+#endif
+
#ifdef emacs
# define XTOOLKIT
memcpy (&si->h, data, sizeof (SndHeader));
- if (LITTLE_ENDIAN)
+ if (NAS_LITTLE_ENDIAN)
{
char n;
char n;
if ((status = dread(c, sizeof(RiffChunk), 1)))
- if (BIG_ENDIAN)
+ if (NAS_BIG_ENDIAN)
swapl(&c->ckSize, n);
return status;
{
AuInt32 dummy;
- wi->format = DataReadS(BIG_ENDIAN);
- wi->channels = DataReadS(BIG_ENDIAN);
- wi->sampleRate = DataReadL(BIG_ENDIAN);
+ wi->format = DataReadS(NAS_BIG_ENDIAN);
+ wi->channels = DataReadS(NAS_BIG_ENDIAN);
+ wi->sampleRate = DataReadL(NAS_BIG_ENDIAN);
/* we don't care about the next two fields */
- dummy = DataReadL(BIG_ENDIAN);
- dummy = DataReadS(BIG_ENDIAN);
+ dummy = DataReadL(NAS_BIG_ENDIAN);
+ dummy = DataReadS(NAS_BIG_ENDIAN);
if (wi->format != RIFF_WAVE_FORMAT_PCM)
Err();
- wi->bitsPerSample = DataReadS(BIG_ENDIAN);
+ wi->bitsPerSample = DataReadS(NAS_BIG_ENDIAN);
/* skip any other format specific fields */
dseek(PAD2(ck.ckSize - 16), 1);
#endif
}
-/* Emulate getloadavg. */
-int
-getloadavg (double loadavg[], int nelem)
-{
- int i;
-
- /* A faithful emulation is going to have to be saved for a rainy day. */
- for (i = 0; i < nelem; i++)
- {
- loadavg[i] = 0.0;
- }
- return i;
-}
-
/* Emulate getpwuid, getpwnam and others. */
#define PASSWD_FIELD_SIZE 256
}
/* Emacs never uses this value, so don't bother making it match
- value returned by stat(). */
+ value returned by xemacs_stat(). */
dir_static.d_ino = 1;
dir_static.d_reclen = sizeof (struct direct) - MAXNAMLEN + 3 +
but is useful for Win32 processes on both Win95 and NT as well. */
Lisp_Object Vwin32_pipe_read_delay;
-/* Control whether stat() attempts to generate fake but hopefully
+/* Control whether xemacs_stat() attempts to generate fake but hopefully
"accurate" inode values, by hashing the absolute truenames of files.
This should detect aliasing between long and short names, but still
allows the possibility of hash collisions. */
start.hStdError = GetStdHandle (STD_ERROR_HANDLE);
/* Explicitly specify no security */
+ /* #### not supported under win98, but will go away */
if (!InitializeSecurityDescriptor (&sec_desc, SECURITY_DESCRIPTOR_REVISION))
goto EH_Fail;
+ /* #### not supported under win98, but will go away */
if (!SetSecurityDescriptorDacl (&sec_desc, TRUE, NULL, FALSE))
goto EH_Fail;
sec_attrs.nLength = sizeof (sec_attrs);
}
/* Handle executable names without an executable suffix. */
- program = make_string (cmdname, strlen (cmdname));
+ program = build_string (cmdname);
GCPRO1 (program);
if (NILP (Ffile_executable_p (program)))
{
if (!IsValidLocale (XINT (lcid), LCID_SUPPORTED))
return Qnil;
+ /* #### not supported under win98, but will go away */
if (!SetThreadLocale (XINT (lcid)))
return Qnil;
combinations. Only the one at index 0, neither underlined nor
struk through is created with the font instance. Other fonts are
created as necessary during redisplay, using the one at index 0
- as protptype */
+ as prototype */
#define MSWINDOWS_NUM_FONT_VARIANTS 4
struct mswindows_font_instance_data
{
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1995 Board of Trustees, University of Illinois.
Copyright (C) 1995 Tinker Systems.
- Copyright (C) 1995, 1996 Ben Wing.
+ Copyright (C) 1995, 1996, 2000 Ben Wing.
Copyright (C) 1995 Sun Microsystems, Inc.
This file is part of XEmacs.
/* Authors: Jamie Zawinski, Chuck Thompson, Ben Wing */
+/* This file Mule-ized by Ben Wing, 7-10-00. */
+
#include <config.h>
#include "lisp.h"
match - tries the next nearest...
Return value is 1 for normal success, 2 for nearest color success,
- 3 for Non-deallocable sucess. */
+ 3 for Non-deallocable success. */
int
allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
XColor *color_def)
bl = color_def->blue << (bbits - 8);
else
bl = color_def->blue >> (8 - bbits);
- color_def->pixel = (rd << rshift) | (gr << gshift) | (bl << bshift);
+ color_def->pixel = (rd << rshift) | (gr << gshift) | (bl <<
+ bshift);
status = 3;
}
}
int x;
if( cells == NULL )
- {
- cells = alloca_array (XColor, no_cells);
- for (x = 0; x < no_cells; x++)
- cells[x].pixel = x;
+ {
+ cells = alloca_array (XColor, no_cells);
+ for (x = 0; x < no_cells; x++)
+ cells[x].pixel = x;
- /* read the current colormap */
- XQueryColors (display, colormap, cells, no_cells);
- }
+ /* read the current colormap */
+ XQueryColors (display, colormap, cells, no_cells);
+ }
nearest = 0;
/* I'm assuming CSE so I'm not going to condense this. */
* ((color_def->red >> 8) - (cells[0].red >> 8)))
+
(((color_def->green >> 8) - (cells[0].green >> 8))
- * ((color_def->green >> 8) - (cells[0].green >> 8)))
+ * ((color_def->green >> 8) - (cells[0].green >>
+ 8)))
+
(((color_def->blue >> 8) - (cells[0].blue >> 8))
- * ((color_def->blue >> 8) - (cells[0].blue >> 8))));
+ * ((color_def->blue >> 8) - (cells[0].blue >>
+ 8))));
for (x = 1; x < no_cells; x++)
{
trial_delta = ((((color_def->red >> 8) - (cells[x].red >> 8))
* ((color_def->red >> 8) - (cells[x].red >> 8)))
+
(((color_def->green >> 8) - (cells[x].green >> 8))
- * ((color_def->green >> 8) - (cells[x].green >> 8)))
+ * ((color_def->green >> 8) - (cells[x].green >>
+ 8)))
+
(((color_def->blue >> 8) - (cells[x].blue >> 8))
- * ((color_def->blue >> 8) - (cells[x].blue >> 8))));
+ * ((color_def->blue >> 8) - (cells[x].blue >>
+ 8))));
/* less? Ignore cells marked as previously failing */
if( (trial_delta < nearest_delta) &&
color_def->green = cells[nearest].green;
color_def->blue = cells[nearest].blue;
if (XAllocColor (display, colormap, color_def) != 0)
- status = 2;
+ status = 2;
else
- /* LSK: Either the colour map has changed since
- * we read it, or the colour is allocated
- * read/write... Mark this cmap entry so it's
- * ignored in the next iteration.
- */
- cells[nearest].pixel = ULONG_MAX;
+ /* LSK: Either the colour map has changed since
+ * we read it, or the colour is allocated
+ * read/write... Mark this cmap entry so it's
+ * ignored in the next iteration.
+ */
+ cells[nearest].pixel = ULONG_MAX;
}
}
return status;
}
-int
-x_parse_nearest_color (struct device *d, XColor *color, Bufbyte *name,
- Bytecount len, Error_behavior errb)
+static int
+x_parse_nearest_color (struct device *d, XColor *color, Lisp_Object name,
+ Error_behavior errb)
{
Display *dpy = DEVICE_X_DISPLAY (d);
Colormap cmap = DEVICE_X_COLORMAP (d);
xzero (*color);
{
const Extbyte *extname;
- Extcount extnamelen;
- TO_EXTERNAL_FORMAT (DATA, (name, len),
- ALLOCA, (extname, extnamelen),
- Qbinary);
- result = XParseColor (dpy, cmap, (char *) extname, color);
+ LISP_STRING_TO_EXTERNAL (name, extname, Qx_color_name_encoding);
+ result = XParseColor (dpy, cmap, extname, color);
}
if (!result)
{
- maybe_signal_simple_error ("Unrecognized color", make_string (name, len),
- Qcolor, errb);
+ maybe_signal_simple_error ("Unrecognized color", name, Qcolor, errb);
return 0;
}
result = allocate_nearest_color (dpy, cmap, visual, color);
if (!result)
{
- maybe_signal_simple_error ("Couldn't allocate color",
- make_string (name, len), Qcolor, errb);
+ maybe_signal_simple_error ("Couldn't allocate color", name, Qcolor,
+ errb);
return 0;
}
XColor color;
int result;
- result = x_parse_nearest_color (XDEVICE (device), &color,
- XSTRING_DATA (name),
- XSTRING_LENGTH (name),
- errb);
+ result = x_parse_nearest_color (XDEVICE (device), &color, name, errb);
if (!result)
return 0;
Lisp_Object printcharfun,
int escapeflag)
{
- char buf[100];
+ Bufbyte buf[100];
XColor color = COLOR_INSTANCE_X_COLOR (c);
sprintf (buf, " %ld=(%X,%X,%X)",
color.pixel, color.red, color.green, color.blue);
{
if (COLOR_INSTANCE_X_DEALLOC (c))
{
- XFreeColors (DEVICE_X_DISPLAY (XDEVICE (c->device)), DEVICE_X_COLORMAP (XDEVICE (c->device)),
+ XFreeColors (DEVICE_X_DISPLAY (XDEVICE (c->device)),
+ DEVICE_X_COLORMAP (XDEVICE (c->device)),
&COLOR_INSTANCE_X_COLOR (c).pixel, 1, 0);
}
}
XColor c;
Display *dpy = DEVICE_X_DISPLAY (d);
Colormap cmap = DEVICE_X_COLORMAP (d);
+ const Extbyte *extname;
- const char *extname;
-
- TO_EXTERNAL_FORMAT (LISP_STRING, color, C_STRING_ALLOCA, extname, Qctext);
+ LISP_STRING_TO_EXTERNAL (color, extname, Qx_color_name_encoding);
return XParseColor (dpy, cmap, extname, &c);
}
{
Display *dpy = DEVICE_X_DISPLAY (XDEVICE (device));
XFontStruct *xf;
- const char *extname;
+ const Extbyte *extname;
- TO_EXTERNAL_FORMAT (LISP_STRING, f->name, C_STRING_ALLOCA, extname, Qctext);
+ LISP_STRING_TO_EXTERNAL (f->name, extname, Qx_font_name_encoding);
xf = XLoadQueryFont (dpy, extname);
if (!xf)
Lisp_Object printcharfun,
int escapeflag)
{
- char buf[200];
+ Bufbyte buf[200];
sprintf (buf, " 0x%lx", (unsigned long) FONT_INSTANCE_X_FONT (f)->fid);
write_c_string (buf, printcharfun);
}
"bitstream" fonts even if the bitstream fonts are earlier in the path, and
also picking 100dpi adobe fonts over 75dpi adobe fonts even though the
75dpi are in the path earlier) but sometimes appears to be doing something
- else entirely (for example, removing the bitsream fonts from the path will
+ else entirely (for example, removing the bitstream fonts from the path will
cause the 75dpi adobe fonts to be used instead of the 100dpi, even though
their relative positions in the path (and their names!) have not changed).
The documentation for XSetFontPath() seems to indicate that the order of
- entries in the font path means something, but it's pretty noncommital about
+ entries in the font path means something, but it's pretty noncommittal about
it, and the spirit of the law is apparently not being obeyed...
All the fonts I've seen have a property named `FONT' which contains the
that the various servers are actually doing, please let me know! -- jwz. */
static int
-valid_x_font_name_p (Display *dpy, char *name)
+valid_x_font_name_p (Display *dpy, Extbyte *name)
{
/* Maybe this should be implemented by calling XLoadFont and trapping
the error. That would be a lot of work, and wasteful as hell, but
might be more correct.
*/
int nnames = 0;
- char **names = 0;
+ SExtbyte **names = 0;
if (! name)
return 0;
names = XListFonts (dpy, name, 1, &nnames);
return (nnames != 0);
}
-static char *
+static Extbyte *
truename_via_FONT_prop (Display *dpy, XFontStruct *font)
{
unsigned long value = 0;
- char *result = 0;
+ Extbyte *result = 0;
if (XGetFontProperty (font, XA_FONT, &value))
result = XGetAtomName (dpy, value);
/* result is now 0, or the string value of the FONT property. */
return result; /* this must be freed by caller if non-0 */
}
-static char *
+static Extbyte *
truename_via_random_props (Display *dpy, XFontStruct *font)
{
struct device *d = get_device_from_display (dpy);
unsigned long value = 0;
- char *foundry, *family, *weight, *slant, *setwidth, *add_style;
+ Extbyte *foundry, *family, *weight, *slant, *setwidth, *add_style;
unsigned long pixel, point, res_x, res_y;
- char *spacing;
+ Extbyte *spacing;
unsigned long avg_width;
- char *registry, *encoding;
- char composed_name [2048];
+ Extbyte *registry, *encoding;
+ Extbyte composed_name [2048];
int ok = 0;
- char *result;
+ Extbyte *result;
#define get_string(atom,var) \
if (XGetFontProperty (font, (atom), &value)) \
if (ok)
{
int L = strlen (composed_name) + 1;
- result = (char *) xmalloc (L);
+ result = (Extbyte *) xmalloc (L);
strncpy (result, composed_name, L);
}
else
/* Unbounded, for sufficiently small values of infinity... */
#define MAX_FONT_COUNT 5000
-static char *
-truename_via_XListFonts (Display *dpy, char *font_name)
+static Extbyte *
+truename_via_XListFonts (Display *dpy, Extbyte *font_name)
{
- char *result = 0;
- char **names;
+ Extbyte *result = 0;
+ SExtbyte **names;
int count = 0;
#ifndef XOPENFONT_SORTS
/* But the world I live in is much more perverse. */
names = XListFonts (dpy, font_name, MAX_FONT_COUNT, &count);
while (count--)
+ /* !!#### Not Mule-friendly */
/* If names[count] is lexicographically less than result, use it.
(#### Should we be comparing case-insensitively?) */
if (result == 0 || (strcmp (result, names [count]) < 0))
}
static Lisp_Object
-x_font_truename (Display *dpy, char *name, XFontStruct *font)
+x_font_truename (Display *dpy, Extbyte *name, XFontStruct *font)
{
- char *truename_FONT = 0;
- char *truename_random = 0;
- char *truename = 0;
+ Extbyte *truename_FONT = 0;
+ Extbyte *truename_random = 0;
+ Extbyte *truename = 0;
/* The search order is:
- if FONT property exists, and is a valid name, return it.
if (truename)
{
- Lisp_Object result = build_string (truename);
+ Lisp_Object result = build_ext_string (truename, Qx_font_name_encoding);
XFree (truename);
return result;
}
if (NILP (FONT_INSTANCE_X_TRUENAME (f)))
{
Display *dpy = DEVICE_X_DISPLAY (d);
- char *name = (char *) XSTRING_DATA (f->name);
{
+ Extbyte *nameext;
+
+ LISP_STRING_TO_EXTERNAL (f->name, nameext, Qx_font_name_encoding);
FONT_INSTANCE_X_TRUENAME (f) =
- x_font_truename (dpy, name, FONT_INSTANCE_X_FONT (f));
+ x_font_truename (dpy, nameext, FONT_INSTANCE_X_FONT (f));
}
if (NILP (FONT_INSTANCE_X_TRUENAME (f)))
{
XSETFONT_INSTANCE (font_instance, f);
maybe_signal_simple_error ("Couldn't determine font truename",
- font_instance, Qfont, errb);
+ font_instance, Qfont, errb);
/* Ok, just this once, return the font name as the truename.
(This is only used by Fequal() right now.) */
return f->name;
props = FONT_INSTANCE_X_FONT (f)->properties;
for (i = FONT_INSTANCE_X_FONT (f)->n_properties - 1; i >= 0; i--)
{
- char *name_str = 0;
- char *val_str = 0;
Lisp_Object name, value;
Atom atom = props [i].name;
- name_str = XGetAtomName (dpy, atom);
+ Bufbyte *name_str = 0;
+ Extbyte *namestrext = XGetAtomName (dpy, atom);
+
+ if (namestrext)
+ EXTERNAL_TO_C_STRING (namestrext, name_str, Qx_atom_name_encoding);
+
name = (name_str ? intern (name_str) : Qnil);
if (name_str &&
(atom == XA_FONT ||
!strcmp (name_str, "RELATIVE_WEIGHT") ||
!strcmp (name_str, "STYLE")))
{
- val_str = XGetAtomName (dpy, props [i].card32);
- value = (val_str ? build_string (val_str) : Qnil);
+ Extbyte *val_str = XGetAtomName (dpy, props [i].card32);
+
+ value = (val_str ? build_ext_string (val_str, Qx_atom_name_encoding)
+ : Qnil);
}
else
value = make_int (props [i].card32);
- if (name_str) XFree (name_str);
+ if (namestrext) XFree (namestrext);
result = Fcons (Fcons (name, value), result);
}
return result;
static Lisp_Object
x_list_fonts (Lisp_Object pattern, Lisp_Object device)
{
- char **names;
+ SExtbyte **names;
int count = 0;
Lisp_Object result = Qnil;
- const char *patternext;
+ const Extbyte *patternext;
- TO_EXTERNAL_FORMAT (LISP_STRING, pattern,
- C_STRING_ALLOCA, patternext,
- Qbinary);
+ LISP_STRING_TO_EXTERNAL (pattern, patternext, Qx_font_name_encoding);
names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
patternext, MAX_FONT_COUNT, &count);
while (count--)
- result = Fcons (build_ext_string (names [count], Qbinary), result);
+ result = Fcons (build_ext_string (names[count], Qx_font_name_encoding),
+ result);
if (names)
XFreeFontNames (names);
return result;
static Lisp_Object
x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset)
{
- char **names;
+ SExtbyte **names;
int count = 0;
Lisp_Object result = Qnil;
- const char *patternext;
+ const Extbyte *patternext;
int i;
- TO_EXTERNAL_FORMAT (LISP_STRING, font,
- C_STRING_ALLOCA, patternext,
- Qbinary);
+ LISP_STRING_TO_EXTERNAL (font, patternext, Qx_font_name_encoding);
names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
patternext, MAX_FONT_COUNT, &count);
/* #### This code seems awfully bogus -- mrb */
for (i = 0; i < count; i ++)
{
- const char *intname;
+ const Bufbyte *intname;
- TO_INTERNAL_FORMAT (C_STRING, names[i],
- C_STRING_ALLOCA, intname,
- Qbinary);
+ EXTERNAL_TO_C_STRING (names[i], intname, Qx_font_name_encoding);
if (x_font_spec_matches_charset (XDEVICE (device), charset,
- (Bufbyte *) intname, Qnil, 0, -1))
+ intname, Qnil, 0, -1))
{
result = build_string (intname);
break;
/* Synched up with: Not in FSF. */
+/* This file Mule-ized (more like Mule-verified) by Ben Wing, 7-10-00. */
+
#ifndef INCLUDED_objects_x_h_
#define INCLUDED_objects_x_h_
#define COLOR_INSTANCE_X_COLOR(c) (X_COLOR_INSTANCE_DATA (c)->color)
#define COLOR_INSTANCE_X_DEALLOC(c) (X_COLOR_INSTANCE_DATA (c)->dealloc_on_gc)
-int allocate_nearest_color (Display *display, Colormap screen_colormap, Visual *visual,
- XColor *color_def);
-int x_parse_nearest_color (struct device *d, XColor *color, Bufbyte *name,
- Bytecount len, Error_behavior errb);
+int allocate_nearest_color (Display *display, Colormap screen_colormap,
+ Visual *visual, XColor *color_def);
/*****************************************************************************
Font-Instance
finalose (void *ptr)
{
Lisp_Object obj;
- XSETOBJ (obj, Lisp_Type_Record, ptr);
+ XSETOBJ (obj, ptr);
signal_simple_error
("Can't dump an emacs containing window system objects", obj);
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*/
-#ifndef INCLUDED_offix_h_
-#define INCLUDED_offix_h_
+#ifndef __DragAndDropH__
+#define __DragAndDropH__ 1L
/* The standard DND types are defined here */
#include "offix-types.h"
int width,int height,
char *image,char *mask,
int hot_x,int hot_y);
-
-#endif /* INCLUDED_offix_h_ */
+#endif
/* The subroutine object for external-debugging-output is kept here
for the convenience of the debugger. */
-Lisp_Object Qexternal_debugging_output;
+Lisp_Object Qexternal_debugging_output, Qalternate_debugging_output;
+
+#ifdef HAVE_MS_WINDOWS
+Lisp_Object Qmswindows_debugging_output;
+#endif
/* Avoid actual stack overflow in print. */
static int print_depth;
int stdout_needs_newline;
-#ifdef WIN32_NATIVE
-static int no_useful_stderr;
-#endif
-
static void
std_handle_out_external (FILE *stream, Lisp_Object lstream,
const Extbyte *extptr, Extcount extlen,
if (stream)
{
#ifdef WIN32_NATIVE
- if (!no_useful_stderr)
- no_useful_stderr = GetStdHandle (STD_ERROR_HANDLE) == 0 ? 1 : -1;
+ HANDLE errhand = GetStdHandle (STD_INPUT_HANDLE);
+ int no_useful_stderr = errhand == 0 || errhand == INVALID_HANDLE_VALUE;
+ if (!no_useful_stderr)
+ no_useful_stderr = !PeekNamedPipe (errhand, 0, 0, 0, 0, 0);
/* we typically have no useful stdout/stderr under windows if we're
being invoked graphically. */
- if (!noninteractive || no_useful_stderr > 0)
+ if (no_useful_stderr)
mswindows_output_console_string (extptr, extlen);
else
#endif
extptr = (Extbyte *) kludge;
extlen = (Extcount) strlen ((char *) kludge);
}
-
+
std_handle_out_external (stream, Qnil, extptr, extlen, 1, 1);
return retval;
}
the flag print-gensym is non-nil, prefix it with #n= to read the
object back with the #n# reader syntax later if needed. */
if (!NILP (Vprint_gensym)
- /* #### Test whether this produces a noticable slow-down for
+ /* #### Test whether this produces a noticeable slow-down for
printing when print-gensym is non-nil. */
&& !EQ (obj, oblookup (Vobarray,
string_data (symbol_name (XSYMBOL (obj))),
UNGCPRO;
}
\f
-/* #ifdef DEBUG_XEMACS */
-/* I don't like seeing `Note: Strange doc (not fboundp) for function
- alternate-debugging-output @ 429542' -slb */
-/* #### Eek! Any clue how to get rid of it? In fact, how about
- getting rid of this function altogether? Does anything actually
- *use* it? --hniksic */
+/* Useful on systems or in places where writing to stdout is unavailable or
+ not working. */
static int alternate_do_pointer;
static char alternate_do_string[5000];
alternate_do_string[alternate_do_pointer] = 0;
return character;
}
-/* #endif / * DEBUG_XEMACS */
DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
Write CHAR-OR-STRING to stderr or stdout.
Vprint_level = make_int (debug_print_level);
print_internal (debug_print_obj, Qexternal_debugging_output, 1);
+ alternate_do_pointer = 0;
+ print_internal (debug_print_obj, Qalternate_debugging_output, 1);
+#ifdef WIN32_NATIVE
+ /* Write out to the debugger, as well */
+ print_internal (debug_print_obj, Qmswindows_debugging_output, 1);
+#endif
Vinhibit_quit = save_Vinhibit_quit;
Vprint_level = save_Vprint_level;
DEFSUBR (Fexternal_debugging_output);
DEFSUBR (Fopen_termscript);
defsymbol (&Qexternal_debugging_output, "external-debugging-output");
+ defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
+#ifdef HAVE_MS_WINDOWS
+ defsymbol (&Qmswindows_debugging_output, "mswindows-debugging-output");
+#endif
DEFSUBR (Fwith_output_to_temp_buffer);
}
#include <winsock.h>
#endif
+/* Bound by win32-native.el */
+Lisp_Object Qmswindows_construct_process_command_line;
+
/* Arbitrary size limit for code fragments passed to run_in_other_process */
#define FRAGMENT_CODE_SIZE 32
/* ---------------------------- the 95 way ------------------------------- */
static BOOL CALLBACK
-find_child_console (HWND hwnd, struct nt_process_data *cp)
+find_child_console (HWND hwnd, long putada)
{
DWORD thread_id;
DWORD process_id;
+ struct nt_process_data *cp = (struct nt_process_data *) putada;
thread_id = GetWindowThreadProcessId (hwnd, &process_id);
if (process_id == cp->dwProcessId)
static int
send_signal (struct nt_process_data *cp, int pid, int signo)
{
- return send_signal_the_nt_way (cp, pid, signo)
+ return (!mswindows_windows9x_p () && send_signal_the_nt_way (cp, pid, signo))
|| send_signal_the_95_way (cp, pid, signo);
}
if (signo != SIGKILL && signo != SIGTERM
&& signo != SIGQUIT && signo != SIGINT
&& signo != SIGHUP)
- signal_simple_error ("Signal number not supported", make_int (signo));
+ invalid_argument ("Signal number not supported", make_int (signo));
}
\f
/*-----------------------------------------------------------------------*/
signal_cannot_launch (Lisp_Object image_file, DWORD err)
{
mswindows_set_errno (err);
- signal_simple_error_2 ("Error starting", image_file, lisp_strerror (errno));
+ report_file_error ("Error starting", image_file);
}
static void
already does this. */
/* Find out whether the application is windowed or not */
- {
- /* SHGetFileInfo tends to return ERROR_FILE_NOT_FOUND on most
- errors. This leads to bogus error message. */
- DWORD image_type;
- char *p = strrchr ((char *)XSTRING_DATA (program), '.');
- if (p != NULL &&
- (stricmp (p, ".exe") == 0 ||
- stricmp (p, ".com") == 0 ||
- stricmp (p, ".bat") == 0 ||
- stricmp (p, ".cmd") == 0))
- {
- image_type = SHGetFileInfo ((char *)XSTRING_DATA (program), 0,NULL,
- 0, SHGFI_EXETYPE);
- }
- else
- {
- char progname[MAX_PATH];
- sprintf (progname, "%s.exe", (char *)XSTRING_DATA (program));
- image_type = SHGetFileInfo (progname, 0, NULL, 0, SHGFI_EXETYPE);
- }
- if (image_type == 0)
- signal_cannot_launch (program, (GetLastError () == ERROR_FILE_NOT_FOUND
- ? ERROR_BAD_FORMAT : GetLastError ()));
- windowed = HIWORD (image_type) != 0;
- }
+ if (xSHGetFileInfoA)
+ {
+ /* SHGetFileInfo tends to return ERROR_FILE_NOT_FOUND on most
+ errors. This leads to bogus error message. */
+ DWORD image_type;
+ char *p = strrchr ((char *)XSTRING_DATA (program), '.');
+ if (p != NULL &&
+ (stricmp (p, ".exe") == 0 ||
+ stricmp (p, ".com") == 0 ||
+ stricmp (p, ".bat") == 0 ||
+ stricmp (p, ".cmd") == 0))
+ {
+ image_type = xSHGetFileInfoA ((char *)XSTRING_DATA (program), 0,NULL,
+ 0, SHGFI_EXETYPE);
+ }
+ else
+ {
+ char progname[MAX_PATH];
+ sprintf (progname, "%s.exe", (char *)XSTRING_DATA (program));
+ image_type = xSHGetFileInfoA (progname, 0, NULL, 0, SHGFI_EXETYPE);
+ }
+ if (image_type == 0)
+ signal_cannot_launch (program, (GetLastError () == ERROR_FILE_NOT_FOUND
+ ? ERROR_BAD_FORMAT : GetLastError ()));
+ windowed = HIWORD (image_type) != 0;
+ }
+ else /* NT 3.5; we have no idea so just guess. */
+ windowed = 0;
/* Decide whether to do I/O on process handles, or just mark the
process exited immediately upon successful launching. We do I/O if the
hmyslurp = htmp;
}
- /* Convert an argv vector into Win32 style command line. */
+ /* Convert an argv vector into Win32 style command line by a call to
+ lisp function `mswindows-construct-process-command-line'
+ (in win32-native.el) */
{
int i;
- Bufbyte **quoted_args;
- int is_dos_app, is_cygnus_app;
- int is_command_shell;
- int do_quoting = 0;
- char escape_char = 0;
-
- nargv++; /* include program; we access argv offset by 1 below */
- quoted_args = alloca_array (Bufbyte *, nargv);
-
- /* Determine whether program is a 16-bit DOS executable, or a Win32
- executable that is implicitly linked to the Cygnus dll (implying it
- was compiled with the Cygnus GNU toolchain and hence relies on
- cygwin.dll to parse the command line - we use this to decide how to
- escape quote chars in command line args that must be quoted). */
- mswindows_executable_type (XSTRING_DATA (program),
- &is_dos_app, &is_cygnus_app);
+ Lisp_Object args_or_ret = Qnil;
+ struct gcpro gcpro1;
- {
- /* #### Bleeeeeeeeeeeeeeeeech!!!! The command shells appear to
- use '^' as a quote character, at least under NT. #### I haven't
- tested 95. If it allows no quoting conventions at all, set
- escape_char to 0 and the code below will work. (e.g. NT tolerates
- no quoting -- this command
-
- cmd /c "ls "/Program Files""
-
- actually works.) */
-
- struct gcpro gcpro1, gcpro2;
- Lisp_Object progname = Qnil;
-
- GCPRO2 (program, progname);
- progname = Ffile_name_nondirectory (program);
- progname = Fdowncase (progname, Qnil);
-
- is_command_shell =
- internal_equal (progname, build_string ("command.com"), 0)
- || internal_equal (progname, build_string ("cmd.exe"), 0);
- UNGCPRO;
- }
-
-#if 0
- /* #### we need to port this. */
- /* On Windows 95, if cmdname is a DOS app, we invoke a helper
- application to start it by specifying the helper app as cmdname,
- while leaving the real app name as argv[0]. */
- if (is_dos_app)
- {
- cmdname = (char*) alloca (MAXPATHLEN);
- if (egetenv ("CMDPROXY"))
- strcpy ((char*)cmdname, egetenv ("CMDPROXY"));
- else
- {
- strcpy ((char*)cmdname, XSTRING_DATA (Vinvocation_directory));
- strcat ((char*)cmdname, "cmdproxy.exe");
- }
- }
-#endif
-
- /* we have to do some conjuring here to put argv and envp into the
- form CreateProcess wants... argv needs to be a space separated/null
- terminated list of parameters, and envp is a null
- separated/double-null terminated list of parameters.
-
- Additionally, zero-length args and args containing whitespace or
- quote chars need to be wrapped in double quotes - for this to work,
- embedded quotes need to be escaped as well. The aim is to ensure
- the child process reconstructs the argv array we start with
- exactly, so we treat quotes at the beginning and end of arguments
- as embedded quotes.
-
- The Win32 GNU-based library from Cygnus doubles quotes to escape
- them, while MSVC uses backslash for escaping. (Actually the MSVC
- startup code does attempt to recognize doubled quotes and accept
- them, but gets it wrong and ends up requiring three quotes to get a
- single embedded quote!) So by default we decide whether to use
- quote or backslash as the escape character based on whether the
- binary is apparently a Cygnus compiled app.
-
- Note that using backslash to escape embedded quotes requires
- additional special handling if an embedded quote is already
- preceded by backslash, or if an arg requiring quoting ends with
- backslash. In such cases, the run of escape characters needs to be
- doubled. For consistency, we apply this special handling as long
- as the escape character is not quote.
-
- Since we have no idea how large argv and envp are likely to be we
- figure out list lengths on the fly and allocate them. */
-
- if (!NILP (Vmswindows_quote_process_args))
- {
- do_quoting = 1;
- /* Override escape char by binding mswindows-quote-process-args to
- desired character, or use t for auto-selection. */
- if (INTP (Vmswindows_quote_process_args))
- escape_char = (char) XINT (Vmswindows_quote_process_args);
- else
- escape_char = is_command_shell ? '^' : is_cygnus_app ? '"' : '\\';
- }
-
- /* do argv... */
- for (i = 0; i < nargv; ++i)
- {
- Bufbyte *targ = XSTRING_DATA (i == 0 ? program : argv[i - 1]);
- Bufbyte *p = targ;
- int need_quotes = 0;
- int escape_char_run = 0;
- int arglen = 0;
-
- if (*p == 0)
- need_quotes = 1;
- for ( ; *p; p++)
- {
- if (*p == '"')
- {
- /* allow for embedded quotes to be escaped */
- if (escape_char)
- arglen++;
- need_quotes = 1;
- /* handle the case where the embedded quote is already escaped */
- if (escape_char_run > 0)
- {
- /* To preserve the arg exactly, we need to double the
- preceding escape characters (plus adding one to
- escape the quote character itself). */
- arglen += escape_char_run;
- }
- }
- else if (*p == ' ' || *p == '\t')
- {
- need_quotes = 1;
- }
-
- if (escape_char && *p == escape_char && escape_char != '"')
- escape_char_run++;
- else
- escape_char_run = 0;
- }
- if (need_quotes)
- {
- arglen += 2;
- /* handle the case where the arg ends with an escape char - we
- must not let the enclosing quote be escaped. */
- if (escape_char_run > 0)
- arglen += escape_char_run;
- }
- arglen += strlen (targ) + 1;
-
- quoted_args[i] = alloca_array (Bufbyte, arglen);
- }
+ GCPRO1 (args_or_ret);
for (i = 0; i < nargv; ++i)
- {
- Bufbyte *targ = XSTRING_DATA (i == 0 ? program : argv[i - 1]);
- Bufbyte *p = targ;
- int need_quotes = 0;
- Bufbyte *parg = quoted_args[i];
-
- if (*p == 0)
- need_quotes = 1;
+ args_or_ret = Fcons (*argv++, args_or_ret);
+ args_or_ret = Fnreverse (args_or_ret);
+ args_or_ret = Fcons (program, args_or_ret);
- if (do_quoting)
- {
- for ( ; *p; p++)
- if (*p == ' ' || *p == '\t' || *p == '"')
- need_quotes = 1;
- }
- if (need_quotes)
- {
- int escape_char_run = 0;
- Bufbyte * first;
- Bufbyte * last;
-
- p = targ;
- first = p;
- last = p + strlen (p) - 1;
- *parg++ = '"';
-#if 0
- /* This version does not escape quotes if they occur at the
- beginning or end of the arg - this could lead to incorrect
- behavior when the arg itself represents a command line
- containing quoted args. I believe this was originally done
- as a hack to make some things work, before
- `mswindows-quote-process-args' was added. */
- while (*p)
- {
- if (*p == '"' && p > first && p < last)
- *parg++ = escape_char; /* escape embedded quotes */
- *parg++ = *p++;
- }
-#else
- for ( ; *p; p++)
- {
- if (escape_char && *p == '"')
- {
- /* double preceding escape chars if any */
- while (escape_char_run > 0)
- {
- *parg++ = escape_char;
- escape_char_run--;
- }
- /* escape all quote chars, even at beginning or end */
- *parg++ = escape_char;
- }
- *parg++ = *p;
-
- if (escape_char && *p == escape_char && escape_char != '"')
- escape_char_run++;
- else
- escape_char_run = 0;
- }
- /* double escape chars before enclosing quote */
- while (escape_char_run > 0)
- {
- *parg++ = escape_char;
- escape_char_run--;
- }
-#endif
- *parg++ = '"';
- }
- else
- {
- strcpy (parg, targ);
- parg += strlen (targ);
- }
- *parg = '\0';
- }
+ args_or_ret = call1 (Qmswindows_construct_process_command_line,
+ args_or_ret);
- {
- int total_cmdline_len = 0;
- Extcount *extargcount = (Extcount *) alloca_array (Extcount, nargv);
- Extbyte **extarg = (Extbyte **) alloca_array (Extbyte *, nargv);
- Extbyte *command_ptr;
+ if (!STRINGP (args_or_ret))
+ /* Luser wrote his/her own clever version */
+ invalid_argument
+ ("Bogus return value from `mswindows-construct-process-command-line'",
+ args_or_ret);
- for (i = 0; i < nargv; ++i)
- {
- TO_EXTERNAL_FORMAT (C_STRING, quoted_args[i], ALLOCA,
- (extarg[i], extargcount[i]), Qmswindows_tstr);
- /* account for space and terminating null */
- total_cmdline_len += extargcount[i] + EITCHAR_SIZE;
- }
+ LISP_STRING_TO_EXTERNAL (args_or_ret, command_line, Qmswindows_tstr);
- command_line = alloca_array (char, total_cmdline_len);
- command_ptr = command_line;
- for (i = 0; i < nargv; ++i)
- {
- memcpy (command_ptr, extarg[i], extargcount[i]);
- command_ptr += extargcount[i];
- EICOPY_TCHAR (command_ptr, ' ');
- command_ptr += EITCHAR_SIZE;
- }
- EICOPY_TCHAR (command_ptr, '\0');
- command_ptr += EITCHAR_SIZE;
- }
+ UNGCPRO; /* args_or_ret */
}
+
/* Set `proc_env' to a nul-separated array of the strings in
Vprocess_environment terminated by 2 nuls. */
}
*penv = 0;
}
+
+#if 0
+ /* #### we need to port this. */
+ /* On Windows 95, if cmdname is a DOS app, we invoke a helper
+ application to start it by specifying the helper app as cmdname,
+ while leaving the real app name as argv[0]. */
+ if (is_dos_app)
+ {
+ cmdname = (char*) alloca (MAXPATHLEN);
+ if (egetenv ("CMDPROXY"))
+ strcpy ((char*)cmdname, egetenv ("CMDPROXY"));
+ else
+ {
+ strcpy ((char*)cmdname, XSTRING_DATA (Vinvocation_directory));
+ strcat ((char*)cmdname, "cmdproxy.exe");
+ }
+ }
+#endif
/* Create process */
{
p->tick++;
process_tick++;
deactivate_process (*((Lisp_Object *) (&vol_proc)));
- error ("Broken pipe error sending to process %s; closed it",
- XSTRING_DATA (p->name));
+ invalid_operation ("Broken pipe error sending to process; closed it",
+ p->name);
}
{
/* Send signal */
if (!send_signal (NT_DATA (p), 0, signo))
- signal_simple_error ("Cannot send signal to process", proc);
+ invalid_operation ("Cannot send signal to process", proc);
}
/*
CHECK_STRING (host);
if (!EQ (protocol, Qtcp))
- signal_simple_error ("Unsupported protocol", protocol);
+ invalid_argument ("Unsupported protocol", protocol);
if (INTP (service))
port = htons ((unsigned short) XINT (service));
CHECK_STRING (service);
svc_info = getservbyname ((char *) XSTRING_DATA (service), "tcp");
if (svc_info == 0)
- signal_simple_error ("Unknown service", service);
+ invalid_argument ("Unknown service", service);
port = svc_info->s_port;
}
void
syms_of_process_nt (void)
{
+ DEFSYMBOL (Qmswindows_construct_process_command_line);
}
void
#include "systty.h"
#include "syswait.h"
+#ifdef HPUX
+#include <grp.h> /* See grantpt fixups for HPUX below. */
+#endif
/*
* Implementation-specific data. Pointed to by Lisp_Process->process_data
#define UNIX_DATA(p) ((struct unix_process_data*)((p)->process_data))
-#ifdef HAVE_PTYS
-/* The file name of the pty opened by allocate_pty. */
-
-static char pty_name[24];
-#endif
-
\f
/**********************************************************************/
/* This function used to be visible on the Lisp level, but there is no
real point in doing that. Here is the doc string:
- "Connect to an existing file descriptor.\n\
-Returns a subprocess-object to represent the connection.\n\
-Input and output work as for subprocesses; `delete-process' closes it.\n\
-Args are NAME BUFFER INFD OUTFD.\n\
-NAME is name for process. It is modified if necessary to make it unique.\n\
-BUFFER is the buffer (or buffer-name) to associate with the process.\n\
- Process output goes at end of that buffer, unless you specify\n\
- an output stream or filter function to handle the output.\n\
- BUFFER may be also nil, meaning that this process is not associated\n\
- with any buffer\n\
-INFD and OUTFD specify the file descriptors to use for input and\n\
+ "Connect to an existing file descriptor.
+Return a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER INFD OUTFD.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or buffer-name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may also be nil, meaning that this process is not associated
+ with any buffer.
+INFD and OUTFD specify the file descriptors to use for input and
output, respectively."
*/
CHECK_INT (outfd);
inch = XINT (infd);
- if (get_process_from_usid (FD_TO_USID(inch)))
- error ("There is already a process connected to fd %d", inch);
+ if (get_process_from_usid (FD_TO_USID (inch)))
+ invalid_operation ("There is already a process connected to fd", infd);
if (!NILP (buffer))
buffer = Fget_buffer_create (buffer);
proc = make_process_internal (name);
XPROCESS (proc)->pid = Fcons (infd, name);
XPROCESS (proc)->buffer = buffer;
- init_process_io_handles (XPROCESS (proc), (void*)inch, (void*)XINT (outfd), 0);
+ init_process_io_handles (XPROCESS (proc), (void*)inch, (void*)XINT (outfd),
+ 0);
UNIX_DATA (XPROCESS (proc))->connected_via_filedesc_p = 1;
event_stream_select_process (XPROCESS (proc));
}
#ifdef HAVE_PTYS
+static int allocate_pty_the_old_fashioned_way (void);
+
+/* The file name of the (slave) pty opened by allocate_pty(). */
+#ifndef MAX_PTYNAME_LEN
+#define MAX_PTYNAME_LEN 64
+#endif
+static char pty_name[MAX_PTYNAME_LEN];
/* Open an available pty, returning a file descriptor.
Return -1 on failure.
The file name of the terminal corresponding to the pty
- is left in the variable pty_name. */
+ is left in the variable `pty_name'. */
static int
allocate_pty (void)
{
-#ifndef PTY_OPEN
+ /* Unix98 standardized grantpt, unlockpt, and ptsname, but not the
+ functions required to open a master pty in the first place :-(
+
+ Modern Unix systems all seems to have convenience methods to open
+ a master pty fd in one function call, but there is little
+ agreement on how to do it.
+
+ allocate_pty() tries all the different known easy ways of opening
+ a pty. In case of failure, we resort to the old BSD-style pty
+ grovelling code in allocate_pty_the_old_fashioned_way(). */
+ int master_fd = -1;
+ const char *slave_name = NULL;
+ const char *clone = NULL;
+ static const char * const clones[] = /* Different pty master clone devices */
+ {
+ "/dev/ptmx", /* Various systems */
+ "/dev/ptm/clone", /* HPUX */
+ "/dev/ptc", /* AIX */
+ "/dev/ptmx_bsd" /* Tru64 */
+ };
+
+#ifdef HAVE_GETPT /* glibc */
+ master_fd = getpt ();
+ if (master_fd >= 0)
+ goto have_master;
+#endif /* HAVE_GETPT */
+
+
+#if defined(HAVE_OPENPTY) /* BSD, Tru64, glibc */
+ {
+ int slave_fd = -1;
+ int rc;
+ EMACS_BLOCK_SIGNAL (SIGCHLD);
+ rc = openpty (&master_fd, &slave_fd, NULL, NULL, NULL);
+ EMACS_UNBLOCK_SIGNAL (SIGCHLD);
+ if (rc == 0)
+ {
+ slave_name = ttyname (slave_fd);
+ close (slave_fd);
+ goto have_slave_name;
+ }
+ else
+ {
+ if (master_fd >= 0)
+ close (master_fd);
+ if (slave_fd >= 0)
+ close (slave_fd);
+ }
+ }
+#endif /* HAVE_OPENPTY */
+
+#if defined(HAVE__GETPTY) && defined (O_NDELAY) /* SGI */
+ master_fd = -1;
+ EMACS_BLOCK_SIGNAL (SIGCHLD);
+ slave_name = _getpty (&master_fd, O_RDWR | O_NDELAY, 0600, 0);
+ EMACS_UNBLOCK_SIGNAL (SIGCHLD);
+ if (master_fd >= 0 && slave_name != NULL)
+ goto have_slave_name;
+#endif /* HAVE__GETPTY */
+
+ /* Master clone devices are available on most systems */
+ {
+ int i;
+ for (i = 0; i < countof (clones); i++)
+ {
+ clone = clones[i];
+ master_fd = open (clone, O_RDWR | O_NONBLOCK | OPEN_BINARY, 0);
+ if (master_fd >= 0)
+ goto have_master;
+ }
+ clone = NULL;
+ }
+
+ goto lose;
+
+ have_master:
+
+#if defined (HAVE_PTSNAME)
+ slave_name = ptsname (master_fd);
+ if (slave_name)
+ goto have_slave_name;
+#endif
+
+ /* AIX docs say to use ttyname, not ptsname, to get slave_name */
+ if (clone
+ && !strcmp (clone, "/dev/ptc")
+ && (slave_name = ttyname (master_fd)) != NULL)
+ goto have_slave_name;
+
+ goto lose;
+
+ have_slave_name:
+ strncpy (pty_name, slave_name, sizeof (pty_name));
+ pty_name[sizeof (pty_name) - 1] = '\0';
+ setup_pty (master_fd);
+
+ /* We jump through some hoops to frob the pty.
+ It's not obvious that checking the return code here is useful. */
+
+ /* "The grantpt() function will fail if it is unable to successfully
+ invoke the setuid root program. It may also fail if the
+ application has installed a signal handler to catch SIGCHLD
+ signals." */
+#if defined (HAVE_GRANTPT) || defined (HAVE_UNLOCKPT)
+ EMACS_BLOCK_SIGNAL (SIGCHLD);
+
+#if defined (HAVE_GRANTPT)
+ grantpt (master_fd);
+#ifdef HPUX
+ /* grantpt() behavior on some versions of HP-UX differs from what's
+ specified in the man page: the group of the slave PTY is set to
+ the user's primary group, and we fix that. */
+ {
+ struct group *tty_group = getgrnam ("tty");
+ if (tty_group != NULL)
+ chown (pty_name, (uid_t) -1, tty_group->gr_gid);
+ }
+#endif /* HPUX has broken grantpt() */
+#endif /* HAVE_GRANTPT */
+
+#if defined (HAVE_UNLOCKPT)
+ unlockpt (master_fd);
+#endif
+
+ EMACS_UNBLOCK_SIGNAL (SIGCHLD);
+#endif /* HAVE_GRANTPT || HAVE_UNLOCKPT */
+
+ return master_fd;
+
+ lose:
+ if (master_fd >= 0)
+ close (master_fd);
+ return allocate_pty_the_old_fashioned_way ();
+}
+
+/* This function tries to allocate a pty by iterating through file
+ pairs with names like /dev/ptyp1 and /dev/ttyp1. */
+static int
+allocate_pty_the_old_fashioned_way (void)
+{
struct stat stb;
/* Some systems name their pseudoterminals so that there are gaps in
three failures in a row before deciding that we've reached the
end of the ptys. */
int failed_count = 0;
-#endif
int fd;
-#ifndef HAVE_GETPT
int i;
int c;
-#endif
#ifdef PTY_ITERATION
PTY_ITERATION
#else
+# ifndef FIRST_PTY_LETTER
+# define FIRST_PTY_LETTER 'p'
+# endif
for (c = FIRST_PTY_LETTER; c <= 'z'; c++)
for (i = 0; i < 16; i++)
-#endif
+#endif /* PTY_ITERATION */
+
{
#ifdef PTY_NAME_SPRINTF
PTY_NAME_SPRINTF
sprintf (pty_name, "/dev/pty%c%x", c, i);
#endif /* no PTY_NAME_SPRINTF */
-#ifdef PTY_OPEN
- PTY_OPEN;
-#else /* no PTY_OPEN */
-#ifdef IRIS
- /* Unusual IRIS code */
- *ptyv = open ("/dev/ptc", O_RDWR | O_NONBLOCK | OPEN_BINARY, 0);
- if (fd < 0)
- return -1;
- if (fstat (fd, &stb) < 0)
- return -1;
-#else /* not IRIS */
- if (stat (pty_name, &stb) < 0)
+ if (xemacs_stat (pty_name, &stb) < 0)
{
- failed_count++;
- if (failed_count >= 3)
+ if (++failed_count >= 3)
return -1;
}
else
failed_count = 0;
fd = open (pty_name, O_RDWR | O_NONBLOCK | OPEN_BINARY, 0);
-#endif /* not IRIS */
-#endif /* no PTY_OPEN */
if (fd >= 0)
{
- /* check to make certain that both sides are available
- this avoids a nasty yet stupid bug in rlogins */
#ifdef PTY_TTY_NAME_SPRINTF
PTY_TTY_NAME_SPRINTF
#else
sprintf (pty_name, "/dev/tty%c%x", c, i);
#endif /* no PTY_TTY_NAME_SPRINTF */
-#if !defined(UNIPLUS) && !defined(HAVE_GETPT)
- if (access (pty_name, 6) != 0)
+ if (access (pty_name, R_OK | W_OK) == 0)
{
- close (fd);
-#if !defined(IRIS) && !defined(__sgi)
- continue;
-#else
- return -1;
-#endif /* IRIS */
+ setup_pty (fd);
+ return fd;
}
-#endif /* not UNIPLUS */
- setup_pty (fd);
- return fd;
+ close (fd);
}
- }
+ } /* iteration */
return -1;
}
#endif /* HAVE_PTYS */
process_signal_char (int tty_fd, int signo)
{
/* If it's not a tty, pray that these default values work */
- if (!isatty(tty_fd)) {
+ if (! isatty (tty_fd)) {
#define CNTL(ch) (037 & (ch))
switch (signo)
{
- case SIGINT: return CNTL('C');
- case SIGQUIT: return CNTL('\\');
+ case SIGINT: return CNTL ('C');
+ case SIGQUIT: return CNTL ('\\');
#ifdef SIGTSTP
- case SIGTSTP: return CNTL('Z');
+ case SIGTSTP: return CNTL ('Z');
#endif
}
}
* Initialize any process local data. This is called when newly
* created process is connected to real OS file handles. The
* handles are generally represented by void* type, but are
- * of type int (file descriptors) for UNIX
+ * of type int (file descriptors) for UNIX.
*/
static void
Lisp_Object *argv, int nargv,
Lisp_Object program, Lisp_Object cur_dir)
{
- /* This function rewritten by ben@xemacs.org. */
-
int pid;
int inchannel = -1;
int outchannel = -1;
int xforkin = forkin;
int xforkout = forkout;
- if (!pty_flag)
- EMACS_SEPARATE_PROCESS_GROUP ();
-#ifdef HAVE_PTYS
- else
- {
- /* Disconnect the current controlling terminal, pursuant to
- making the pty be the controlling terminal of the process.
- Also put us in our own process group. */
+ /* Disconnect the current controlling terminal, pursuant to
+ making the pty be the controlling terminal of the process.
+ Also put us in our own process group. */
- disconnect_controlling_terminal ();
+ disconnect_controlling_terminal ();
+#ifdef HAVE_PTYS
+ if (pty_flag)
+ {
/* Open the pty connection and make the pty's terminal
our controlling terminal.
Must be done before using tc* functions on xforkin.
This guarantees that isatty(xforkin) is true. */
-# ifdef SETUP_SLAVE_PTY
- SETUP_SLAVE_PTY;
-# endif /* SETUP_SLAVE_PTY */
+# if defined (HAVE_ISASTREAM) && defined (I_PUSH)
+ if (isastream (xforkin))
+ {
+# if defined (I_FIND)
+# define stream_module_pushed(fd, module) (ioctl (fd, I_FIND, module) == 1)
+# else
+# define stream_module_pushed(fd, module) 0
+# endif
+ if (! stream_module_pushed (xforkin, "ptem"))
+ ioctl (xforkin, I_PUSH, "ptem");
+ if (! stream_module_pushed (xforkin, "ldterm"))
+ ioctl (xforkin, I_PUSH, "ldterm");
+ if (! stream_module_pushed (xforkin, "ttcompat"))
+ ioctl (xforkin, I_PUSH, "ttcompat");
+ }
+# endif /* HAVE_ISASTREAM */
# ifdef TIOCSCTTY
/* We ignore the return value
of our new controlling terminal. */
{
- int piddly = EMACS_GET_PROCESS_GROUP ();
+ pid_t piddly = EMACS_GET_PROCESS_GROUP ();
EMACS_SET_TTY_PROCESS_GROUP (xforkin, &piddly);
}
}
new_argv[i + 1] = 0;
- TO_EXTERNAL_FORMAT (LISP_STRING, cur_dir,
- C_STRING_ALLOCA, current_dir,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (cur_dir, current_dir, Qfile_name);
child_setup (xforkin, xforkout, xforkout, new_argv, current_dir);
}
if (pid < 0)
{
+ int save_errno = errno;
close_descriptor_pair (forkin, forkout);
+ errno = save_errno;
report_file_error ("Doing fork", Qnil);
}
/* #### JV: layering violation?
- This function knows too much about the relation between the encodingstream
- (DATA_OUTSTREAM) and te actual output stream p->output_stream.
+ This function knows too much about the relation between the encoding
+ stream (DATA_OUTSTREAM) and the actual output stream p->output_stream.
If encoding streams properly forwarded all calls, we could simply
use DATA_OUTSTREAM everywhere. */
-
+
if (!SETJMP (send_process_frame))
{
/* use a reasonable-sized buffer (somewhere around the size of the
p->tick++;
process_tick++;
deactivate_process (*((Lisp_Object *) (&vol_proc)));
- error ("SIGPIPE raised on process %s; closed it",
- XSTRING_DATA (p->name));
+ invalid_operation ("SIGPIPE raised on process; closed it", p->name);
}
old_sigpipe = (SIGTYPE (*) (int)) signal (SIGPIPE, send_process_trap);
return usid;
}
-/* send a signal number SIGNO to PROCESS.
+/* If the subtty field of the process data is not filled in, do so now. */
+static void
+try_to_initialize_subtty (struct unix_process_data *upd)
+{
+ if (upd->pty_flag
+ && (upd->subtty = -1 || ! isatty (upd->subtty))
+ && STRINGP (upd->tty_name))
+ upd->subtty = open (XSTRING_DATA (upd->tty_name), O_RDWR, 0);
+}
+
+/* Send signal number SIGNO to PROCESS.
CURRENT_GROUP means send to the process group that currently owns
the terminal being used to communicate with PROCESS.
This is used for various commands in shell mode.
If we can, we try to signal PROCESS by sending control characters
down the pty. This allows us to signal inferiors who have changed
- their uid, for which killpg would return an EPERM error.
+ their uid, for which killpg would return an EPERM error,
+ or processes running on other machines via remote login.
- The method signals an error if the given SIGNO is not valid
-*/
+ The method signals an error if the given SIGNO is not valid. */
static void
unix_kill_child_process (Lisp_Object proc, int signo,
int current_group, int nomsg)
{
- int gid;
- int no_pgrp = 0;
- int kill_retval;
+ pid_t pgid = -1;
Lisp_Process *p = XPROCESS (proc);
-
- if (!UNIX_DATA(p)->pty_flag)
- current_group = 0;
-
- /* If we are using pgrps, get a pgrp number and make it negative. */
- if (current_group)
- {
-#ifdef SIGNALS_VIA_CHARACTERS
- /* If possible, send signals to the entire pgrp
- by sending an input character to it. */
- {
- char sigchar = process_signal_char(UNIX_DATA(p)->subtty, signo);
- if (sigchar) {
- send_process (proc, Qnil, (Bufbyte *) &sigchar, 0, 1);
- return;
- }
- }
-#endif /* ! defined (SIGNALS_VIA_CHARACTERS) */
-
-#ifdef TIOCGPGRP
- /* Get the pgrp using the tty itself, if we have that.
- Otherwise, use the pty to get the pgrp.
- On pfa systems, saka@pfu.fujitsu.co.JP writes:
- "TIOCGPGRP symbol defined in sys/ioctl.h at E50.
- But, TIOCGPGRP does not work on E50 ;-P works fine on E60"
- His patch indicates that if TIOCGPGRP returns an error, then
- we should just assume that p->pid is also the process group id. */
- {
- int err;
-
- err = ioctl ( (UNIX_DATA(p)->subtty != -1
- ? UNIX_DATA(p)->subtty
- : UNIX_DATA(p)->infd), TIOCGPGRP, &gid);
-
-#ifdef pfa
- if (err == -1)
- gid = - XINT (p->pid);
-#endif /* ! defined (pfa) */
- }
- if (gid == -1)
- no_pgrp = 1;
- else
- gid = - gid;
-#else /* ! defined (TIOCGPGRP ) */
- /* Can't select pgrps on this system, so we know that
- the child itself heads the pgrp. */
- gid = - XINT (p->pid);
-#endif /* ! defined (TIOCGPGRP ) */
- }
- else
- gid = - XINT (p->pid);
+ struct unix_process_data *d = UNIX_DATA (p);
switch (signo)
{
case SIGINT:
case SIGQUIT:
case SIGKILL:
- flush_pending_output (UNIX_DATA(p)->infd);
+ flush_pending_output (d->infd);
break;
}
- /* If we don't have process groups, send the signal to the immediate
- subprocess. That isn't really right, but it's better than any
- obvious alternative. */
- if (no_pgrp)
- {
- kill_retval = kill (XINT (p->pid), signo) ? errno : 0;
- }
- else
+ if (! d->pty_flag)
+ current_group = 0;
+
+ /* If current_group is true, we want to send a signal to the
+ foreground process group of the terminal our child process is
+ running on. You would think that would be easy.
+
+ The BSD people invented the TIOCPGRP ioctl to get the foreground
+ process group of a tty. That, combined with killpg, gives us
+ what we want.
+
+ However, the POSIX standards people, in their infinite wisdom,
+ have seen fit to only allow this for processes which have the
+ terminal as controlling terminal, which doesn't apply to us.
+
+ Sooo..., we have to do something non-standard. The ioctls
+ TIOCSIGNAL, TIOCSIG, and TIOCSIGSEND send the signal directly on
+ many systems. POSIX tcgetpgrp(), since it is *documented* as not
+ doing what we want, is actually less likely to work than the BSD
+ ioctl TIOCGPGRP it is supposed to obsolete. Sometimes we have to
+ use TIOCGPGRP on the master end, sometimes the slave end
+ (probably an AIX bug). So we better get a fd for the slave if we
+ haven't got it yet. On some systems none of these work, so then
+ we just fall back to the non-current_group behavior and kill the
+ process group of the child. */
+ if (current_group)
{
- /* gid may be a pid, or minus a pgrp's number */
-#if defined (TIOCSIGNAL) || defined (TIOCSIGSEND)
- if (current_group)
+ try_to_initialize_subtty (d);
+
+#ifdef SIGNALS_VIA_CHARACTERS
+ /* If possible, send signals to the entire pgrp
+ by sending an input character to it. */
+ {
+ char sigchar = process_signal_char (d->subtty, signo);
+ if (sigchar)
+ {
+ send_process (proc, Qnil, (Bufbyte *) &sigchar, 0, 1);
+ return;
+ }
+ }
+#endif /* SIGNALS_VIA_CHARACTERS */
+
+#ifdef TIOCGPGRP
+ if (pgid == -1)
+ ioctl (d->infd, TIOCGPGRP, &pgid); /* BSD */
+ if (pgid == -1 && d->subtty != -1)
+ ioctl (d->subtty, TIOCGPGRP, &pgid); /* Only this works on AIX! */
+#endif /* TIOCGPGRP */
+
+ if (pgid == -1)
{
-#ifdef TIOCSIGNAL
- kill_retval = ioctl (UNIX_DATA(p)->infd, TIOCSIGNAL, signo);
-#else /* ! defined (TIOCSIGNAL) */
- kill_retval = ioctl (UNIX_DATA(p)->infd, TIOCSIGSEND, signo);
-#endif /* ! defined (TIOCSIGNAL) */
+ /* Many systems provide an ioctl to send a signal directly */
+#ifdef TIOCSIGNAL /* Solaris, HP-UX */
+ if (ioctl (d->infd, TIOCSIGNAL, signo) != -1)
+ return;
+#endif /* TIOCSIGNAL */
+
+#ifdef TIOCSIG /* BSD */
+ if (ioctl (d->infd, TIOCSIG, signo) != -1)
+ return;
+#endif /* TIOCSIG */
}
- else
- kill_retval = kill (- XINT (p->pid), signo) ? errno : 0;
-#else /* ! (defined (TIOCSIGNAL) || defined (TIOCSIGSEND)) */
- kill_retval = EMACS_KILLPG (-gid, signo) ? errno : 0;
-#endif /* ! (defined (TIOCSIGNAL) || defined (TIOCSIGSEND)) */
- }
-
- if (kill_retval < 0 && errno == EINVAL)
- error ("Signal number %d is invalid for this system", signo);
+ } /* current_group */
+
+ if (pgid == -1)
+ /* Either current_group is 0, or we failed to get the foreground
+ process group using the trickery above. So we fall back to
+ sending the signal to the process group of our child process.
+ Since this is often a shell that ignores signals like SIGINT,
+ the shell's subprocess is killed, which is the desired effect.
+ The process group of p->pid is always p->pid, since it was
+ created as a process group leader. */
+ pgid = XINT (p->pid);
+
+ /* Finally send the signal. */
+ if (EMACS_KILLPG (pgid, signo) == -1)
+ error ("kill (%ld, %ld) failed: %s",
+ (long) pgid, (long) signo, strerror (errno));
}
-/*
- * Kill any process in the system given its PID.
- *
- * Returns zero if a signal successfully sent, or
- * negative number upon failure
- */
+/* Send signal SIGCODE to any process in the system given its PID.
+ Return zero if successful, a negative number upon failure. */
static int
unix_kill_process_by_pid (int pid, int sigcode)
return kill (pid, sigcode);
}
-/*
- * Return TTY name used to communicate with subprocess
- */
+/* Return TTY name used to communicate with subprocess. */
static Lisp_Object
unix_get_tty_name (Lisp_Process *p)
return UNIX_DATA (p)->tty_name;
}
-/*
- * Canonicalize host name HOST, and return its canonical form
- *
- * The default implementation just takes HOST for a canonical name.
- */
+/* Canonicalize host name HOST, and return its canonical form.
+ The default implementation just takes HOST for a canonical name. */
#ifdef HAVE_SOCKETS
static Lisp_Object
hints.ai_family = AF_UNSPEC;
hints.ai_socktype = SOCK_STREAM;
hints.ai_protocol = 0;
- TO_EXTERNAL_FORMAT (LISP_STRING, host, C_STRING_ALLOCA, ext_host, Qnative);
+ LISP_STRING_TO_EXTERNAL (host, ext_host, Qnative);
retval = getaddrinfo (ext_host, NULL, &hints, &res);
if (retval != 0)
{
char *gai_error;
- TO_INTERNAL_FORMAT (C_STRING, gai_strerror (retval),
- C_STRING_ALLOCA, gai_error,
- Qnative);
+ EXTERNAL_TO_C_STRING (gai_strerror (retval), gai_error, Qnative);
maybe_error (Qprocess, ERROR_ME_NOT,
"%s \"%s\"", gai_error, XSTRING_DATA (host));
canonname = host;
#endif /* ! HAVE_GETADDRINFO */
}
-/* open a TCP network connection to a given HOST/SERVICE. Treated
- exactly like a normal process when reading and writing. Only
- differences are in status display and process deletion. A network
- connection has no PID; you cannot signal it. All you can do is
- deactivate and close it via delete-process */
+/* Open a TCP network connection to a given HOST/SERVICE.
+ Treated exactly like a normal process when reading and writing.
+ Only differences are in status display and process deletion.
+ A network connection has no PID; you cannot signal it. All you can
+ do is deactivate and close it via delete-process. */
static void
unix_open_network_stream (Lisp_Object name, Lisp_Object host, Lisp_Object service,
CHECK_STRING (host);
if (!EQ (protocol, Qtcp) && !EQ (protocol, Qudp))
- error ("Unsupported protocol \"%s\"",
- string_data (symbol_name (XSYMBOL (protocol))));
+ invalid_argument ("Unsupported protocol", protocol);
{
#if defined(HAVE_GETADDRINFO) && defined(HAVE_GETNAMEINFO)
else
{
CHECK_STRING (service);
- TO_EXTERNAL_FORMAT (LISP_STRING, service,
- C_STRING_ALLOCA, portstring,
- Qnative);
+ LISP_STRING_TO_EXTERNAL (service, portstring, Qnative);
port = 0;
}
else /* EQ (protocol, Qudp) */
hints.ai_socktype = SOCK_DGRAM;
hints.ai_protocol = 0;
- TO_EXTERNAL_FORMAT (LISP_STRING, host, C_STRING_ALLOCA, ext_host, Qnative);
+ LISP_STRING_TO_EXTERNAL (host, ext_host, Qnative);
retval = getaddrinfo (ext_host, portstring, &hints, &res);
if (retval != 0)
{
char *gai_error;
- TO_INTERNAL_FORMAT (C_STRING, gai_strerror (retval),
- C_STRING_ALLOCA, gai_error,
- Qnative);
+ EXTERNAL_TO_C_STRING (gai_strerror (retval), gai_error, Qnative);
error ("%s/%s %s", XSTRING_DATA (host), portstring, gai_error);
}
svc_info = getservbyname ((char *) XSTRING_DATA (service), "udp");
if (svc_info == 0)
- error ("Unknown service \"%s\"", XSTRING_DATA (service));
+ invalid_argument ("Unknown service", service);
port = svc_info->s_port;
}
*/
static void
-unix_open_multicast_group (Lisp_Object name, Lisp_Object dest, Lisp_Object port,
- Lisp_Object ttl, void** vinfd, void** voutfd)
+unix_open_multicast_group (Lisp_Object name, Lisp_Object dest,
+ Lisp_Object port, Lisp_Object ttl, void** vinfd,
+ void** voutfd)
{
struct ip_mreq imr;
struct sockaddr_in sa;
thettl = (unsigned char) XINT (ttl);
if ((udp = getprotobyname ("udp")) == NULL)
- error ("No info available for UDP protocol");
+ type_error (Qinvalid_operation, "No info available for UDP protocol");
/* Init the sockets. Yes, I need 2 sockets. I couldn't duplicate one. */
if ((rs = socket (PF_INET, SOCK_DGRAM, udp->p_proto)) < 0)
}
else
{
- if (!NILP (Ffile_directory_p (program)))
- error ("Specified program for new process is a directory");
+ /* we still need to canonicalize it and ensure it has the proper
+ ending, e.g. .exe */
+ struct gcpro ngcpro1;
+
+ tem = Qnil;
+ NGCPRO1 (tem);
+ locate_file (list1 (build_string ("")), program, Vlisp_EXEC_SUFFIXES,
+ &tem, X_OK);
+ if (NILP (tem))
+ report_file_error ("Searching for program", list1 (program));
+ program = tem;
+ NUNGCPRO;
}
+ if (!NILP (Ffile_directory_p (program)))
+ invalid_operation ("Specified program for new process is a directory",
+ program);
+
proc = make_process_internal (name);
XPROCESS (proc)->buffer = buffer;
connection has no PID; you cannot signal it. All you can do is
deactivate and close it via delete-process */
-DEFUN ("open-network-stream-internal", Fopen_network_stream_internal, 4, 5, 0, /*
+DEFUN ("open-network-stream-internal", Fopen_network_stream_internal, 4, 5,
+ 0, /*
Open a TCP connection for a service to a host.
Return a subprocess-object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
(Transmission Control Protocol) and 'udp (User Datagram Protocol) are
supported. When omitted, 'tcp is assumed.
-Ouput via `process-send-string' and input via buffer or filter (see
+Output via `process-send-string' and input via buffer or filter (see
`set-process-filter') are stream-oriented. That means UDP datagrams are
not guaranteed to be sent and received in discrete packets. (But small
datagrams around 500 bytes that are not truncated by `process-send-string'
\f
-/* send a signal number SIGNO to PROCESS.
- CURRENT_GROUP means send to the process group that currently owns
- the terminal being used to communicate with PROCESS.
- This is used for various commands in shell mode.
- If NOMSG is zero, insert signal-announcements into process's buffers
- right away.
-
- If we can, we try to signal PROCESS by sending control characters
- down the pty. This allows us to signal inferiors who have changed
- their uid, for which killpg would return an EPERM error. */
-
-static void
-process_send_signal (Lisp_Object process, int signo,
- int current_group, int nomsg)
-{
- /* This function can GC */
- Lisp_Object proc = get_process (process);
-
- if (network_connection_p (proc))
- error ("Network connection %s is not a subprocess",
- XSTRING_DATA (XPROCESS(proc)->name));
- CHECK_LIVE_PROCESS (proc);
-
- MAYBE_PROCMETH (kill_child_process, (proc, signo, current_group, nomsg));
-}
-
-DEFUN ("interrupt-process", Finterrupt_process, 0, 2, 0, /*
-Interrupt process PROCESS. May be process or name of one.
-Nil or no arg means current buffer's process.
-Second arg CURRENT-GROUP non-nil means send signal to
-the current process-group of the process's controlling terminal
-rather than to the process's own process group.
-If the process is a shell, this means interrupt current subjob
-rather than the shell.
-*/
- (process, current_group))
-{
- /* This function can GC */
- process_send_signal (process, SIGINT, !NILP (current_group), 0);
- return process;
-}
-
-DEFUN ("kill-process", Fkill_process, 0, 2, 0, /*
-Kill process PROCESS. May be process or name of one.
-See function `interrupt-process' for more details on usage.
-*/
- (process, current_group))
-{
- /* This function can GC */
-#ifdef SIGKILL
- process_send_signal (process, SIGKILL, !NILP (current_group), 0);
-#else
- error ("kill-process: Not supported on this system");
-#endif
- return process;
-}
-
-DEFUN ("quit-process", Fquit_process, 0, 2, 0, /*
-Send QUIT signal to process PROCESS. May be process or name of one.
-See function `interrupt-process' for more details on usage.
-*/
- (process, current_group))
-{
- /* This function can GC */
-#ifdef SIGQUIT
- process_send_signal (process, SIGQUIT, !NILP (current_group), 0);
-#else
- error ("quit-process: Not supported on this system");
-#endif
- return process;
-}
-
-DEFUN ("stop-process", Fstop_process, 0, 2, 0, /*
-Stop process PROCESS. May be process or name of one.
-See function `interrupt-process' for more details on usage.
-*/
- (process, current_group))
-{
- /* This function can GC */
-#ifdef SIGTSTP
- process_send_signal (process, SIGTSTP, !NILP (current_group), 0);
-#else
- error ("stop-process: Not supported on this system");
-#endif
- return process;
-}
-
-DEFUN ("continue-process", Fcontinue_process, 0, 2, 0, /*
-Continue process PROCESS. May be process or name of one.
-See function `interrupt-process' for more details on usage.
-*/
- (process, current_group))
+static int
+decode_signal (Lisp_Object signal_)
{
- /* This function can GC */
-#ifdef SIGCONT
- process_send_signal (process, SIGCONT, !NILP (current_group), 0);
-#else
- error ("continue-process: Not supported on this system");
-#endif
- return process;
-}
-
-DEFUN ("signal-process", Fsignal_process, 2, 2,
- "nProcess number: \nnSignal code: ", /*
-Send the process with process id PID the signal with code SIGCODE.
-PID must be an integer. The process need not be a child of this Emacs.
-SIGCODE may be an integer, or a symbol whose name is a signal name.
-*/
- (pid, sigcode))
-{
- CHECK_INT (pid);
-
- if (INTP (sigcode))
- ;
+ if (INTP (signal_))
+ return XINT (signal_);
else
{
Bufbyte *name;
- CHECK_SYMBOL (sigcode);
- name = string_data (XSYMBOL (sigcode)->name);
+ CHECK_SYMBOL (signal_);
+ name = string_data (XSYMBOL (signal_)->name);
-#define handle_signal(signal) \
- else if (!strcmp ((const char *) name, #signal)) \
- XSETINT (sigcode, signal)
+#define handle_signal(sym) do { \
+ if (!strcmp ((const char *) name, #sym)) \
+ return sym; \
+ } while (0)
- if (0)
- ;
handle_signal (SIGINT); /* ANSI */
handle_signal (SIGILL); /* ANSI */
handle_signal (SIGABRT); /* ANSI */
#ifdef SIGPWR
handle_signal (SIGPWR);
#endif
- else
- error ("Undefined signal name %s", name);
- }
#undef handle_signal
+ error ("Undefined signal name %s", name);
+ return 0; /* Unreached */
+ }
+}
+
+/* Send signal number SIGNO to PROCESS.
+ CURRENT-GROUP non-nil means send signal to the current
+ foreground process group of the process's controlling terminal rather
+ than to the process's own process group.
+ This is used for various commands in shell mode.
+ If NOMSG is zero, insert signal-announcements into process's buffers
+ right away.
+
+ If we can, we try to signal PROCESS by sending control characters
+ down the pty. This allows us to signal inferiors who have changed
+ their uid, for which kill() would return an EPERM error, or to
+ processes running on another computer through a remote login. */
+
+static void
+process_send_signal (Lisp_Object process, int signo,
+ int current_group, int nomsg)
+{
+ /* This function can GC */
+ Lisp_Object proc = get_process (process);
+
+ if (network_connection_p (proc))
+ error ("Network connection %s is not a subprocess",
+ XSTRING_DATA (XPROCESS(proc)->name));
+ CHECK_LIVE_PROCESS (proc);
+
+ MAYBE_PROCMETH (kill_child_process, (proc, signo, current_group, nomsg));
+}
+
+DEFUN ("process-send-signal", Fprocess_send_signal, 1, 3, 0, /*
+Send signal SIGNAL to process PROCESS.
+SIGNAL may be an integer, or a symbol naming a signal, like `SIGSEGV'.
+PROCESS may be a process, a buffer, the name of a process or buffer, or
+nil, indicating the current buffer's process.
+Third arg CURRENT-GROUP non-nil means send signal to the current
+foreground process group of the process's controlling terminal rather
+than to the process's own process group.
+If the process is a shell that supports job control, this means
+send the signal to the current subjob rather than the shell.
+*/
+ (signal_, process, current_group))
+{
+ /* This function can GC */
+ process_send_signal (process, decode_signal (signal_),
+ !NILP (current_group), 0);
+ return process;
+}
+
+DEFUN ("interrupt-process", Finterrupt_process, 0, 2, 0, /*
+Interrupt process PROCESS.
+See function `process-send-signal' for more details on usage.
+*/
+ (process, current_group))
+{
+ /* This function can GC */
+ process_send_signal (process, SIGINT, !NILP (current_group), 0);
+ return process;
+}
+
+DEFUN ("kill-process", Fkill_process, 0, 2, 0, /*
+Kill process PROCESS.
+See function `process-send-signal' for more details on usage.
+*/
+ (process, current_group))
+{
+ /* This function can GC */
+#ifdef SIGKILL
+ process_send_signal (process, SIGKILL, !NILP (current_group), 0);
+#else
+ error ("kill-process: Not supported on this system");
+#endif
+ return process;
+}
+
+DEFUN ("quit-process", Fquit_process, 0, 2, 0, /*
+Send QUIT signal to process PROCESS.
+See function `process-send-signal' for more details on usage.
+*/
+ (process, current_group))
+{
+ /* This function can GC */
+#ifdef SIGQUIT
+ process_send_signal (process, SIGQUIT, !NILP (current_group), 0);
+#else
+ error ("quit-process: Not supported on this system");
+#endif
+ return process;
+}
+
+DEFUN ("stop-process", Fstop_process, 0, 2, 0, /*
+Stop process PROCESS.
+See function `process-send-signal' for more details on usage.
+*/
+ (process, current_group))
+{
+ /* This function can GC */
+#ifdef SIGTSTP
+ process_send_signal (process, SIGTSTP, !NILP (current_group), 0);
+#else
+ error ("stop-process: Not supported on this system");
+#endif
+ return process;
+}
+
+DEFUN ("continue-process", Fcontinue_process, 0, 2, 0, /*
+Continue process PROCESS.
+See function `process-send-signal' for more details on usage.
+*/
+ (process, current_group))
+{
+ /* This function can GC */
+#ifdef SIGCONT
+ process_send_signal (process, SIGCONT, !NILP (current_group), 0);
+#else
+ error ("continue-process: Not supported on this system");
+#endif
+ return process;
+}
+
+DEFUN ("signal-process", Fsignal_process, 2, 2,
+ "nProcess number: \nnSignal code: ", /*
+Send the process with process id PID the signal with code SIGNAL.
+PID must be an integer. The process need not be a child of this Emacs.
+SIGNAL may be an integer, or a symbol naming a signal, like `SIGSEGV'.
+*/
+ (pid, signal_))
+{
+ CHECK_INT (pid);
+
return make_int (PROCMETH_OR_GIVEN (kill_process_by_pid,
- (XINT (pid), XINT (sigcode)), -1));
+ (XINT (pid), decode_signal (signal_)),
+ -1));
}
DEFUN ("process-send-eof", Fprocess_send_eof, 0, 1, 0, /*
#endif /* HAVE_SOCKETS */
DEFSUBR (Fprocess_send_region);
DEFSUBR (Fprocess_send_string);
+ DEFSUBR (Fprocess_send_signal);
DEFSUBR (Finterrupt_process);
DEFSUBR (Fkill_process);
DEFSUBR (Fquit_process);
#endif /* emacs */
-#ifdef HAVE_GETPT
-#define PTY_ITERATION
-#define PTY_OPEN \
- if ((fd = getpt()) < 0 || grantpt (fd) < 0 || unlockpt (fd) < 0) \
- return -1;
-#define PTY_NAME_SPRINTF
-#define PTY_TTY_NAME_SPRINTF strcpy (pty_name, ptsname (fd));
-#endif
-
#endif /* INCLUDED_process_h_ */
EMACS_INT first, last;
Lisp_Object args[4];
int oldlen;
-
+
again:
first = entry->first;
last = entry->last;
/* In AIX, you allocate a pty by opening /dev/ptc to get the master side.
To get the name of the slave side, you just ttyname() the master side. */
-#define PTY_ITERATION for (c = 0; !c ; c++)
-#define PTY_NAME_SPRINTF strcpy (pty_name, "/dev/ptc");
-#define PTY_TTY_NAME_SPRINTF strcpy (pty_name, ttyname (fd));
-
-/* XEmacs change: #### is this crap necessary? */
-#ifndef NOT_C_CODE
-#include <termios.h>
-#endif
-
/*
* Define HAVE_PTYS if the system supports pty devices.
*/
#define LIBS_DEBUG
#define LIBS_SYSTEM "-lutil -lcompat"
-#define HAVE_GETLOADAVG
-
/* System uses OXTABS instead of the expected TAB3.
(Copied from netbsd.h.) */
#define TABDLY OXTABS
# endif
# endif
+# if CYGWIN_VERSION_DLL_MAJOR < 20
+
void cygwin32_win32_to_posix_path_list (const char*, char*);
int cygwin32_win32_to_posix_path_list_buf_size (const char*);
void cygwin32_posix_to_win32_path_list (const char*, char*);
int cygwin32_posix_to_win32_path_list_buf_size (const char*);
-# if CYGWIN_VERSION_DLL_MAJOR < 20
+
+#define cygwin_win32_to_posix_path_list cygwin32_win32_to_posix_path_list
+#define cygwin_win32_to_posix_path_list_buf_size \
+ cygwin32_win32_to_posix_path_list_buf_size
+#define cygwin_posix_to_win32_path_list cygwin32_posix_to_win32_path_list
+#define cygwin_posix_to_win32_path_list_buf_size \
+ cygwin32_posix_to_win32_path_list_buf_size
+
struct timeval;
struct timezone;
struct itimerval;
int srandom (unsigned seed);
long random (void);
+# else /* not CYGWIN_VERSION_DLL_MAJOR < 20 */
+
+void cygwin_win32_to_posix_path_list (const char*, char*);
+int cygwin_win32_to_posix_path_list_buf_size (const char*);
+void cygwin_posix_to_win32_path_list (const char*, char*);
+int cygwin_posix_to_win32_path_list_buf_size (const char*);
+
# endif /* CYGWIN_VERSION_DLL_MAJOR < 20 */
# if CYGWIN_VERSION_DLL_MAJOR <= 20
double logb (double);
# endif /* CYGWIN_VERSION_DLL_MAJOR <= 20 */
+/* Still left out of 1.1! */
+double logb (double);
+
#endif
#ifndef ORDINARY_LINK
#undef MAIL_USE_SYSTEM_LOCK
-/* Define NO_ARG_ARRAY if you cannot take the address of the first of a
- * group of arguments and treat it as an array of the arguments. */
-
-#define NO_ARG_ARRAY
-
-/* Data type of load average, as read out of kmem. */
-
-#define LOAD_AVE_TYPE long
-
-/* Convert that into an integer that is 100 for a load average of 1.0 */
-
-#define LOAD_AVE_CVT(x) (int) (((double) (x)) * 100.0 / FSCALE)
+/* Do not define LOAD_AVE_TYPE or LOAD_AVE_CVT
+ since there is no load average available. */
/* Define VIRT_ADDR_VARIES if the virtual addresses of
pure and impure space as loaded can vary, and even their
#define SYSTEM_PURESIZE_EXTRA 15000
#define CYGWIN_CONV_PATH(src, dst) \
-dst = alloca (cygwin32_win32_to_posix_path_list_buf_size(src)); \
-cygwin32_win32_to_posix_path_list(src, dst)
+dst = alloca (cygwin_win32_to_posix_path_list_buf_size(src)); \
+cygwin_win32_to_posix_path_list(src, dst)
#define CYGWIN_WIN32_PATH(src, dst) \
-dst = alloca (cygwin32_posix_to_win32_path_list_buf_size(src)); \
-cygwin32_posix_to_win32_path_list(src, dst)
-
-/*
- * stolen from usg.
- */
-#define HAVE_PTYS
-#define FIRST_PTY_LETTER 'z'
-
-/* Pseudo-terminal support under SVR4 only loops to deal with errors. */
-
-#define PTY_ITERATION for (i = 0, c = 0; i < 1; i++)
-
-/* This sets the name of the master side of the PTY. */
-
-#define PTY_NAME_SPRINTF strcpy (pty_name, "/dev/ptmx");
-
-/* This sets the name of the slave side of the PTY. On SysVr4,
- grantpt(3) forks a subprocess, so keep sigchld_handler() from
- intercepting that death. If any child but grantpt's should die
- within, it should be caught after EMACS_UNBLOCK_SIGNAL. */
-
-#define PTY_OPEN \
- fd = open (pty_name, O_RDWR | O_NONBLOCK | OPEN_BINARY, 0)
-
-#define PTY_TTY_NAME_SPRINTF \
- { \
- extern char* ptsname(int); \
- char *ptyname; \
- \
- if (!(ptyname = ptsname (fd))) \
- { close (fd); return -1; } \
- strncpy (pty_name, ptyname, sizeof (pty_name)); \
- pty_name[sizeof (pty_name) - 1] = 0; \
- }
-
-/* ============================================================ */
-
+dst = alloca (cygwin_posix_to_win32_path_list_buf_size(src)); \
+cygwin_posix_to_win32_path_list(src, dst)
#endif /* not __ELF__ */
-#define HAVE_GETLOADAVG
/* #define NO_TERMIO */ /* detected in configure */
#define DECLARE_GETPWUID_WITH_UID_T
#undef SYSTEM_TYPE
#define SYSTEM_TYPE "gnu"
-/* XXX should getloadavg be in libc? Should we have a libutil?
-#define HAVE_GETLOADAVG */
-
#define LIBS_DEBUG
/* XXX emacs should not expect TAB3 to be defined. */
#define WNOHANG 0x1
-/* No need to use sprintf to get the tty name--we get that from _getpty. */
-#undef PTY_TTY_NAME_SPRINTF
-#define PTY_TTY_NAME_SPRINTF
-/* No need to get the pty name at all. */
-#define PTY_NAME_SPRINTF
-/* We need only try once to open a pty. */
-#define PTY_ITERATION
-/* Here is how to do it. */
-/* It is necessary to prevent SIGCHLD signals within _getpty.
- So we block them. */
-#define PTY_OPEN \
-{ \
- char *name; \
- struct stat stb; \
- EMACS_BLOCK_SIGCHLD; \
- name = _getpty (&fd, O_RDWR | O_NDELAY, 0600, 0); \
- EMACS_UNBLOCK_SIGCHLD; \
- if (name == 0) \
- return -1; \
- if (fd < 0) \
- return -1; \
- if (fstat (fd, &stb) < 0) \
- return -1; \
- strcpy (pty_name, name); \
-}
-
/* jpff@maths.bath.ac.uk reports `struct exception' is not defined
on this system, so inhibit use of matherr. */
#define NO_MATHERR
#undef SETUP_SLAVE_PTY
#endif
-/* No need to use sprintf to get the tty name--we get that from _getpty. */
-#ifdef PTY_TTY_NAME_SPRINTF
-#undef PTY_TTY_NAME_SPRINTF
-#endif
-#define PTY_TTY_NAME_SPRINTF
-/* No need to get the pty name at all. */
-#ifdef PTY_NAME_SPRINTF
-#undef PTY_NAME_SPRINTF
-#endif
-#define PTY_NAME_SPRINTF
-#ifdef emacs
-char *_getpty ();
-#endif
-/* We need only try once to open a pty. */
-#define PTY_ITERATION
-/* Here is how to do it. */
-/* It is necessary to prevent SIGCHLD signals within _getpty.
- So we block them. */
-#define PTY_OPEN \
-{ \
- char *name; \
- struct stat stb; \
- EMACS_BLOCK_SIGCHLD; \
- name = _getpty (&fd, O_RDWR | O_NDELAY, 0600, 0); \
- EMACS_UNBLOCK_SIGCHLD; \
- if (name == 0) \
- return -1; \
- if (fd < 0) \
- return -1; \
- if (fstat (fd, &stb) < 0) \
- return -1; \
- strcpy (pty_name, name); \
-}
-
/* jpff@maths.bath.ac.uk reports `struct exception' is not defined
on this system, so inhibit use of matherr. */
#define NO_MATHERR
/* XEmacs: removed setpgrp() definition because we use setpgid() when
it's available, and autodetect it. */
+
#undef KERNEL_FILE
#undef LDAV_SYMBOL
-#define HAVE_GETLOADAVG
#define PENDING_OUTPUT_COUNT(FILE) ((FILE)->_p - (FILE)->_bf._base)
#define USG5_4
#endif
-#if OS_RELEASE >= 57
-#define HAVE_GETLOADAVG
-#endif
-
/* Fix understandable GCC lossage on Solaris 2.6 */
#if defined(__GNUC__) && OS_RELEASE >= 56 && !defined(NOT_C_CODE)
#define HAVE_H_ERRNO
#define HAVE_STRUCT_UTIMBUF
-#define HAVE_STRCASECMP
-
/* Compatibility macros. Some used to be routines in nt.c */
#define strcasecmp(x,y) _stricmp(x,y)
#define random() (rand() << 15 | rand())
#endif
#endif
+/* Force the various NT 4 structures and constants to be included; we're
+ careful not to call (or even link with) functions not in NT 3.51 when
+ running on 3.51, but when running on NT 4 or Win9x, we use the later
+ functions, and need their headers. */
+/* The VC++ (5.0, at least) headers treat WINVER non-existent as 0x0400 */
+#if defined (WINVER) && WINVER < 0x0400
+# undef WINVER
+# define WINVER 0x0400
+#endif
+
/* MSVC 6.0 has a mechanism to declare functions which never return */
#if (_MSC_VER >= 1200)
#define DOESNT_RETURN __declspec(noreturn) void
struct scrollbar_instance *sb)
{
int orientation;
-
+
sb->scrollbar_data = xnew_and_zero (struct mswindows_scrollbar_data);
-
+
if (vertical)
orientation = SBS_VERT;
else
orientation = SBS_HORZ;
-
+
SCROLLBAR_MSW_HANDLE (sb) =
CreateWindowEx(0, "SCROLLBAR", 0, orientation|WS_CHILD,
CW_USEDEFAULT, CW_USEDEFAULT,
mswindows_free_scrollbar_instance (struct scrollbar_instance *sb)
{
DestroyWindow (SCROLLBAR_MSW_HANDLE (sb));
- if (sb->scrollbar_data)
+ if (sb->scrollbar_data)
xfree (sb->scrollbar_data);
}
UPDATE_POS_FIELD (scrollbar_width);
UPDATE_POS_FIELD (scrollbar_height);
- if (pos_changed)
+ if (pos_changed)
{
MoveWindow(SCROLLBAR_MSW_HANDLE (sb),
new_scrollbar_x, new_scrollbar_y,
f = XFRAME (frame);
/* SB_LINEDOWN == SB_CHARLEFT etc. This is the way they will
- always be - any Windows is binary compatible backward with
+ always be - any Windows is binary compatible backward with
old programs */
switch (code)
mswindows_enqueue_misc_user_event
(frame, vert ? Qscrollbar_line_down : Qscrollbar_char_right, win);
break;
-
+
case SB_LINEUP:
mswindows_enqueue_misc_user_event
(frame, vert ? Qscrollbar_line_up : Qscrollbar_char_left, win);
break;
-
+
case SB_PAGEDOWN:
mswindows_enqueue_misc_user_event
(win, vert ? Qscrollbar_page_down : Qscrollbar_page_right,
vert ? Qscrollbar_page_up : Qscrollbar_page_left,
vert ? Fcons (win, Qnil) : win);
break;
-
+
case SB_BOTTOM:
mswindows_enqueue_misc_user_event
(frame, vert ? Qscrollbar_to_bottom : Qscrollbar_to_right, win);
int
mswindows_handle_mousewheel_event (Lisp_Object frame, int keys, int delta)
{
- int hasVertBar, hasHorzBar; /* Indicates prescence of scroll bars */
+ int hasVertBar, hasHorzBar; /* Indicates presence of scroll bars */
unsigned wheelScrollLines = 0; /* Number of lines per wheel notch */
/* Find the currently selected window */
/* Synched up with: Not in FSF. */
+/* This file Mule-ized (more like Mule-verified) by Ben Wing, 7-8-00. */
+
#include <config.h>
#include "lisp.h"
mirror = find_scrollbar_window_mirror (f, id);
if (!mirror)
return;
-
+
win = real_window (mirror, 1);
if (NILP (win))
mirror = find_scrollbar_window_mirror (f, id);
if (!mirror)
return;
-
+
win = real_window (mirror, 1);
if (NILP (win))
{
x_offset = WINDOW_LEFT (w);
}
- else
+ else
{
x_offset = WINDOW_RIGHT (w) - scrollbar_width;
if (window_needs_vertical_divider (w))
This is a specifier; use `set-specifier' to change it.
*/ );
Vscrollbar_on_left_p = Fmake_specifier (Qboolean);
-
+
{
/* Kludge. Under X, we want athena scrollbars on the left,
while all other scrollbars go on the right by default. */
{
/* If it's NIL, we're in trouble. */
if (NILP (value)) return 0;
-
+
/* If it's an integer, assume it's a format ID */
if (INTP (value)) return (UINT) (XINT (value));
/* If it's a string, register the format(!) */
if (STRINGP (value))
return RegisterClipboardFormat (XSTRING_DATA (value));
-
+
/* Check for Windows clipboard format symbols */
if (EQ (value, QCF_TEXT)) return CF_TEXT;
if (EQ (value, QCF_BITMAP)) return CF_BITMAP;
if (EQ (value, QCF_TIFF)) return CF_TIFF;
if (EQ (value, QCF_OEMTEXT)) return CF_OEMTEXT;
if (EQ (value, QCF_DIB)) return CF_DIB;
+#ifdef CF_DIBV5
+ if (EQ (value, QCF_DIBV5)) return CF_DIBV5;
+#endif
if (EQ (value, QCF_PALETTE)) return CF_PALETTE;
if (EQ (value, QCF_PENDATA)) return CF_PENDATA;
if (EQ (value, QCF_RIFF)) return CF_RIFF;
case CF_TIFF: return QCF_TIFF;
case CF_OEMTEXT: return QCF_OEMTEXT;
case CF_DIB: return QCF_DIB;
+#ifdef CF_DIBV5
+ case CF_DIBV5: return QCF_DIBV5;
+#endif
case CF_PALETTE: return QCF_PALETTE;
case CF_PENDATA: return QCF_PENDATA;
case CF_RIFF: return QCF_RIFF;
{
switch (format)
{
- /* This list comes from the SDK documentation */
+ /* This list comes from the SDK documentation */
case CF_DSPENHMETAFILE:
case CF_DSPMETAFILEPICT:
case CF_ENHMETAFILE:
+ case CF_METAFILEPICT:
case CF_BITMAP:
case CF_DSPBITMAP:
case CF_PALETTE:
case CF_DIB:
+#ifdef CF_DIBV5
+ case CF_DIBV5:
+#endif
case CF_DSPTEXT:
case CF_OEMTEXT:
case CF_TEXT:
}
/* Do protocol to assert ourself as a selection owner.
-
+
Under mswindows, we:
* Only set the clipboard if (eq selection-name 'CLIPBOARD)
/* Only continue if we can figure out a clipboard type */
if (!cfType)
return Qnil;
-
+
cfObject = selection_type;
}
data = XCDR (data);
}
-
+
/* We support opaque or string values, but we only mention string
values for now... */
if (!OPAQUEP (data)
&& !STRINGP (data))
return Qnil;
-
+
/* Compute the data length */
if (OPAQUEP (data))
size = XOPAQUE_SIZE (data);
else
size = XSTRING_LENGTH (data) + 1;
-
+
/* Find the frame */
f = selected_frame ();
/* Open the clipboard */
if (!OpenClipboard (FRAME_MSWINDOWS_HANDLE (f)))
return Qnil;
-
+
/* Allocate memory */
hValue = GlobalAlloc (GMEM_DDESHARE | GMEM_MOVEABLE, size);
-
+
if (!hValue)
{
CloseClipboard ();
return Qnil;
}
-
+
/* Copy the data */
if (OPAQUEP (data))
src = XOPAQUE_DATA (data);
else
src = XSTRING_DATA (data);
-
+
dst = GlobalLock (hValue);
-
+
if (!dst)
{
GlobalFree (hValue);
CloseClipboard ();
-
+
return Qnil;
}
-
+
memcpy (dst, src, size);
GlobalUnlock (hValue);
{
Lisp_Object alist_elt = Qnil, rest;
Lisp_Object cfType_int = make_int (cfType);
-
+
/* First check if there's an element in the alist for this type
already. */
alist_elt = assq_no_quit (cfType_int, Vhandle_alist);
{
/* Free the original handle */
GlobalFree ((HGLOBAL) get_opaque_ptr (XCDR (alist_elt)));
-
+
/* Remove the original one (adding first makes life easier, because
we don't have to special case this being the first element) */
for (rest = Vhandle_alist; !NILP (rest); rest = Fcdr (rest))
}
}
}
-
+
CloseClipboard ();
/* #### Should really return a time, though this is because of the
if (!EQ (selection_name, QCLIPBOARD))
return Qnil;
-
+
/* Find the frame */
f = selected_frame ();
/* #### ajh - Should there be an unwind-protect handler around this?
It could (well it probably won't, but it's always better to
be safe) run out of memory and leave the clipboard open... */
-
+
while ((format = EnumClipboardFormats (format)))
types = Fcons (ms_cf_to_symbol (format), types);
/* If it's an integer, convert to a symbol if appropriate */
if (INTP (type_id))
type_id = ms_cf_to_symbol (XINT (type_id));
-
+
/* If this is a symbol, return it */
if (SYMBOLP (type_id))
return type_id;
MULE could hack it. */
name = make_ext_string (name_buf, numchars,
Fget_coding_system (Qraw_text));
-
+
return name;
}
-
+
return Qnil;
}
void *data;
struct frame *f = NULL;
struct gcpro gcpro1;
-
+
/* Only continue if we're trying to read the clipboard - mswindows doesn't
use the same selection model as X */
if (!EQ (selection_symbol, QCLIPBOARD))
return Qnil;
- /* If this is one fo the X-style atom name symbols, or NIL, convert it
+ /* If this is one of the X-style atom name symbols, or NIL, convert it
as appropriate */
if (NILP (target_type) || x_sym_p (target_type))
{
CloseClipboard ();
GCPRO1 (ret);
-
+
/* Convert this to the appropriate type. If we can't find anything,
then we return a cons of the form (DATA-TYPE . STRING), where the
string contains the raw binary data. */
ret);
UNGCPRO;
-
+
if (NILP (value))
return Fcons (cfObject, ret);
else
void
mswindows_destroy_selection (Lisp_Object selection)
{
- Lisp_Object alist_elt;
-
/* Do nothing if this isn't for the clipboard. */
if (!EQ (selection, QCLIPBOARD))
return;
/* Right. We need to delete everything in Vhandle_alist. */
- alist_elt = Vhandle_alist;
-
- for (alist_elt; !NILP (alist_elt); alist_elt = Fcdr (alist_elt))
- GlobalFree ((HGLOBAL) get_opaque_ptr (XCDR (alist_elt)));
+ {
+ LIST_LOOP_2 (elt, Vhandle_alist)
+ GlobalFree ((HGLOBAL) get_opaque_ptr (XCDR (elt)));
+ }
Vhandle_alist = Qnil;
}
{
char *fileext;
- TO_EXTERNAL_FORMAT (LISP_STRING, file,
- C_STRING_ALLOCA, fileext,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (file, fileext, Qfile_name);
/* #### NAS code should allow specification of a device. */
if (nas_play_sound_file (fileext, vol))
return Qnil;
char *fileext;
int result;
- TO_EXTERNAL_FORMAT (LISP_STRING, file,
- C_STRING_ALLOCA, fileext,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (file, fileext, Qfile_name);
/* #### ESD uses alarm(). But why should we also stop SIGIO? */
stop_interrupts ();
{
const char *fileext;
- TO_EXTERNAL_FORMAT (LISP_STRING, file,
- C_STRING_ALLOCA, fileext,
- Qfile_name);
+ LISP_STRING_TO_EXTERNAL (file, fileext, Qfile_name);
/* The sound code doesn't like getting SIGIO interrupts.
Unix sucks! */
stop_interrupts ();
DEFVAR_LISP ("native-sound-only-on-console", &Vnative_sound_only_on_console /*
Non-nil value means play sounds only if XEmacs is running
on the system console.
-Nil means always always play sounds, even if running on a non-console tty
+Nil means always play sounds, even if running on a non-console tty
or a secondary X display.
This variable only applies to native sound support.
#include "rangetab.h"
Lisp_Object Qspecifierp;
-Lisp_Object Qprepend, Qremove_tag_set_prepend, Qremove_tag_set_append;
-Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all;
-Lisp_Object Qfallback;
-
-/* Qinteger, Qboolean, Qgeneric defined in general.c. */
-Lisp_Object Qnatnum;
+Lisp_Object Qremove_tag_set_prepend, Qremove_tag_set_append;
+Lisp_Object Qremove_locale, Qremove_locale_type;
Lisp_Object Qconsole_type, Qdevice_class;
+Lisp_Object Qspecifier_syntax_error;
+Lisp_Object Qspecifier_argument_error;
+Lisp_Object Qspecifier_change_error;
+
static Lisp_Object Vuser_defined_tags;
typedef struct specifier_type_entry specifier_type_entry;
static const struct lrecord_description ste_description_1[] = {
{ XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) },
- { XD_STRUCT_PTR, offsetof (specifier_type_entry, meths), 1, &specifier_methods_description },
+ { XD_STRUCT_PTR, offsetof (specifier_type_entry, meths), 1,
+ &specifier_methods_description },
{ XD_END }
};
};
static const struct lrecord_description specifier_description[] = {
- { XD_STRUCT_PTR, offsetof (Lisp_Specifier, methods), 1, &specifier_methods_description },
+ { XD_STRUCT_PTR, offsetof (Lisp_Specifier, methods), 1,
+ &specifier_methods_description },
{ XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) },
{ XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) },
{ XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) },
{ XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) },
{ XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) },
{ XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) },
- { XD_STRUCT_PTR, offsetof (Lisp_Specifier, caching), 1, &specifier_caching_description },
+ { XD_STRUCT_PTR, offsetof (Lisp_Specifier, caching), 1,
+ &specifier_caching_description },
{ XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) },
{ XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) },
{ XD_SPECIFIER_END }
return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
}
- maybe_signal_simple_error ("Invalid specifier type", type,
- Qspecifier, errb);
+ maybe_signal_type_error (Qspecifier_argument_error, "Invalid specifier type",
+ type, Qspecifier, errb);
return 0;
}
? Qt : Qnil;
}
-DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
+DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0,
+ /*
Given a specifier LOCALE-TYPE, return non-nil if it is valid.
Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
\(Note, however, that in functions that accept either a locale or a locale
!NILP (Fvalid_specifier_locale_p (locale)) ||
!NILP (Fvalid_specifier_locale_type_p (locale)))
return;
- signal_simple_error ("Invalid specifier locale or locale type", locale);
+ signal_type_error (Qspecifier_argument_error,
+ "Invalid specifier locale or locale type", locale);
}
DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
{
/* This cannot GC. */
if (NILP (Fvalid_specifier_locale_p (locale)))
- signal_simple_error ("Invalid specifier locale", locale);
+ signal_type_error (Qspecifier_argument_error, "Invalid specifier locale",
+ locale);
if (DEVICEP (locale)) return Qdevice;
if (FRAMEP (locale)) return Qframe;
if (WINDOWP (locale)) return Qwindow;
else if (!NILP (Fvalid_specifier_locale_p (locale)))
return locale;
else
- signal_simple_error ("Invalid specifier locale", locale);
+ signal_type_error (Qspecifier_argument_error, "Invalid specifier locale",
+ locale);
return Qnil;
}
if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
- signal_simple_error ("Invalid specifier locale type", locale_type);
+ signal_type_error (Qspecifier_argument_error, "Invalid specifier locale type",
+ locale_type);
return LOCALE_GLOBAL; /* not reached */
}
}
else if (CONSP (locale))
{
- Lisp_Object elt;
EXTERNAL_LIST_LOOP_2 (elt, locale)
check_valid_locale_or_locale_type (elt);
return locale;
check_valid_domain (Lisp_Object domain)
{
if (NILP (Fvalid_specifier_domain_p (domain)))
- signal_simple_error ("Invalid specifier domain", domain);
+ signal_type_error (Qspecifier_argument_error, "Invalid specifier domain",
+ domain);
}
Lisp_Object
if (!NILP (Fvalid_specifier_tag_p (tag_set)))
return list1 (tag_set);
if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
- signal_simple_error ("Invalid specifier tag-set", tag_set);
+ signal_type_error (Qspecifier_argument_error, "Invalid specifier tag-set",
+ tag_set);
return tag_set;
}
(tag_set))
{
if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
- signal_simple_error ("Invalid tag set", tag_set);
+ signal_type_error (Qspecifier_argument_error, "Invalid tag set", tag_set);
return canonicalize_tag_set (tag_set);
}
return 1;
}
-DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
+DEFUN ("device-matches-specifier-tag-set-p",
+ Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
Return non-nil if DEVICE matches specifier tag set TAG-SET.
This means that DEVICE matches each tag in the tag set. (Every
tag recognized by XEmacs has a predicate associated with it that
CHECK_LIVE_DEVICE (device);
if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
- signal_simple_error ("Invalid tag set", tag_set);
+ signal_type_error (Qspecifier_argument_error, "Invalid tag set", tag_set);
return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
}
CHECK_SYMBOL (tag);
if (valid_device_class_p (tag) ||
valid_console_type_p (tag))
- signal_simple_error ("Cannot redefine built-in specifier tags", tag);
+ signal_type_error (Qspecifier_change_error,
+ "Cannot redefine built-in specifier tags", tag);
/* Try to prevent common instantiators and locales from being
redefined, to reduce ambiguity */
if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
- signal_simple_error ("Cannot define nil, t, 'all, or 'global",
- tag);
+ signal_type_error (Qspecifier_change_error, "Cannot define nil, t, 'all, or 'global",
+ tag);
assoc = assq_no_quit (tag, Vuser_defined_tags);
if (NILP (assoc))
{
}
}
-DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
+DEFUN ("device-matching-specifier-tag-list",
+ Fdevice_matching_specifier_tag_list,
0, 1, 0, /*
Return a list of all specifier tags matching DEVICE.
DEVICE defaults to the selected device if omitted.
CHECK_SYMBOL (tag);
if (NILP (Fvalid_specifier_tag_p (tag)))
- signal_simple_error ("Invalid specifier tag", tag);
+ signal_type_error (Qspecifier_argument_error, "Invalid specifier tag",
+ tag);
/* Make up some predicates for the built-in types */
if (!CONSP (rest))
{
- maybe_signal_simple_error ("Invalid instantiator list", inst_list,
+ maybe_signal_type_error (Qspecifier_syntax_error,
+ "Invalid instantiator list", inst_list,
Qspecifier, errb);
return Qnil;
}
if (!CONSP (inst_pair = XCAR (rest)))
{
- maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
+ maybe_signal_type_error (Qspecifier_syntax_error,
+ "Invalid instantiator pair", inst_pair,
Qspecifier, errb);
return Qnil;
}
if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
{
- maybe_signal_simple_error ("Invalid specifier tag", tag_set,
+ maybe_signal_type_error (Qspecifier_syntax_error,
+ "Invalid specifier tag", tag_set,
Qspecifier, errb);
return Qnil;
}
Lisp_Object spec, locale;
if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
{
- maybe_signal_simple_error ("Invalid specification list", spec_list,
+ maybe_signal_type_error (Qspecifier_syntax_error,
+ "Invalid specification list", spec_list,
Qspecifier, errb);
return Qnil;
}
if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
{
- maybe_signal_simple_error ("Invalid specifier locale", locale,
+ maybe_signal_type_error (Qspecifier_syntax_error,
+ "Invalid specifier locale", locale,
Qspecifier, errb);
return Qnil;
}
if (EQ (Qremove_all, how_to_add))
return SPEC_REMOVE_ALL;
- signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
+ signal_type_error (Qspecifier_argument_error, "Invalid `how-to-add' flag",
+ how_to_add);
return SPEC_PREPEND; /* not reached */
}
{
if (NILP (Vunlock_ghost_specifiers)
&& GHOST_SPECIFIER_P (XSPECIFIER (spec)))
- signal_simple_error ("Attempt to modify read-only specifier",
+ signal_type_error (Qspecifier_change_error,
+ "Attempt to modify read-only specifier",
list1 (spec));
}
else if (add_meth == SPEC_APPEND)
tem = nconc2 (*orig_inst_list, list_to_build_up);
else
- abort ();
+ {
+ abort ();
+ tem = Qnil;
+ }
*orig_inst_list = tem;
}
}
-DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
+DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2,
+ 2, 0, /*
Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
See `specifier-matching-instance' for a description of matchspecs.
*/
return UNBOUNDP (val) ? default_ : val;
}
-DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
+DEFUN ("specifier-matching-instance-from-inst-list",
+ Fspecifier_matching_instance_from_inst_list,
4, 5, 0, /*
Attempt to convert a particular inst-list into an instance.
This attempts to instantiate INST-LIST in the given DOMAIN
boolean_validate (Lisp_Object instantiator)
{
if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
- signal_simple_error ("Must be t or nil", instantiator);
+ signal_type_error (Qspecifier_argument_error, "Must be t or nil",
+ instantiator);
}
DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
{
lose:
- dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
+ dead_wrong_type_argument
+ (display_table_specifier_methods->predicate_symbol,
instantiator);
}
}
{
INIT_LRECORD_IMPLEMENTATION (specifier);
- defsymbol (&Qspecifierp, "specifierp");
+ DEFSYMBOL (Qspecifierp);
- defsymbol (&Qconsole_type, "console-type");
- defsymbol (&Qdevice_class, "device-class");
+ DEFSYMBOL (Qconsole_type);
+ DEFSYMBOL (Qdevice_class);
- /* Qinteger, Qboolean, Qgeneric defined in general.c */
- defsymbol (&Qnatnum, "natnum");
+ /* specifier types defined in general.c. */
DEFSUBR (Fvalid_specifier_type_p);
DEFSUBR (Fspecifier_type_list);
/* locales are defined in general.c. */
- defsymbol (&Qprepend, "prepend");
- defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
- defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
- defsymbol (&Qremove_locale, "remove-locale");
- defsymbol (&Qremove_locale_type, "remove-locale-type");
- defsymbol (&Qremove_all, "remove-all");
+ /* some how-to-add flags in general.c. */
+ DEFSYMBOL (Qremove_tag_set_prepend);
+ DEFSYMBOL (Qremove_tag_set_append);
+ DEFSYMBOL (Qremove_locale);
+ DEFSYMBOL (Qremove_locale_type);
- defsymbol (&Qfallback, "fallback");
+ DEFERROR_STANDARD (Qspecifier_syntax_error, Qsyntax_error);
+ DEFERROR_STANDARD (Qspecifier_argument_error, Qinvalid_argument);
+ DEFERROR_STANDARD (Qspecifier_change_error, Qinvalid_change);
}
void
SPECIFIER_HAS_METHOD (boolean, validate);
- INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
+ INITIALIZE_SPECIFIER_TYPE (display_table, "display-table",
+ "display-table-p");
SPECIFIER_HAS_METHOD (display_table, validate);
}
name specifier_instance) to avoid creating "external"
specification loops.
- This method must presume that both INSTANTIATOR and MATCSPEC are
+ This method must presume that both INSTANTIATOR and MATCHSPEC are
already validated by the corresponding validate_* methods, and
may abort if they are invalid.
/* Definitions of symbol-value forwarding for XEmacs Lisp interpreter.
Copyright (C) 1985, 1986, 1987, 1992, 1993 Free Software Foundation, Inc.
+ Copyright (C) 2000 Ben Wing.
This file is part of XEmacs.
XRECORD_LHEADER (x)->type <= lrecord_type_max_symbol_value_magic)
#define XSYMBOL_VALUE_MAGIC_TYPE(v) \
(((struct symbol_value_magic *) XPNTR (v))->type)
-#define XSETSYMBOL_VALUE_MAGIC(s, p) XSETOBJ (s, Lisp_Type_Record, p)
+#define XSETSYMBOL_VALUE_MAGIC(s, p) XSETOBJ (s, p)
void print_symbol_value_magic (Lisp_Object, Lisp_Object, int);
/********** The various different symbol-value-magic types ***********/
void defsubr_macro (Lisp_Subr *);
#define DEFSUBR_MACRO(Fname) defsubr_macro (&S##Fname)
+void defsymbol_massage_name (Lisp_Object *location, const char *name);
+void defsymbol_massage_name_nodump (Lisp_Object *location, const char *name);
+void defsymbol_massage_multiword_predicate (Lisp_Object *location,
+ const char *name);
+void defsymbol_massage_multiword_predicate_nodump (Lisp_Object *location,
+ const char *name);
void defsymbol (Lisp_Object *location, const char *name);
void defsymbol_nodump (Lisp_Object *location, const char *name);
+#define DEFSYMBOL(name) defsymbol_massage_name (&name, #name)
+#define DEFSYMBOL_NO_DUMP(name) defsymbol_massage_name_nodump (&name, #name)
+#define DEFSYMBOL_MULTIWORD_PREDICATE(name) \
+ defsymbol_massage_multiword_predicate (&name, #name)
+#define DEFSYMBOL_MULTIWORD_PREDICATE_NO_DUMP(name) \
+ defsymbol_massage_multiword_predicate_nodump (&name, #name)
+
void defkeyword (Lisp_Object *location, const char *name);
+void defkeyword_massage_name (Lisp_Object *location, const char *name);
+#define DEFKEYWORD(name) defkeyword_massage_name (&name, #name)
void deferror (Lisp_Object *symbol, const char *name,
const char *message, Lisp_Object inherits_from);
+void deferror_massage_name (Lisp_Object *symbol, const char *name,
+ const char *message, Lisp_Object inherits_from);
+void deferror_massage_name_and_message (Lisp_Object *symbol, const char *name,
+ Lisp_Object inherits_from);
+#define DEFERROR(name, message, inherits_from) \
+ deferror_massage_name (&name, #name, message, inherits_from)
+/* In this case, the error message is the same as the name, modulo some
+ prettifying */
+#define DEFERROR_STANDARD(name, inherits_from) \
+ deferror_massage_name_and_message (&name, #name, inherits_from)
/* Macros we use to define forwarded Lisp variables.
These are used in the syms_of_FILENAME functions. */
#endif /* TIOCGWINSZ or ISC4_0 */
#endif /* USG */
-#ifdef HAVE_SYS_STROPTS_H
-#include <sys/stropts.h>
-#endif /* HAVE_SYS_STROPTS_H */
-
/* LPASS8 is new in 4.3, and makes cbreak mode provide all 8 bits. */
#ifndef LPASS8
#define LPASS8 0
#if defined (HAVE_FPATHCONF) && defined (_PC_MAX_CANON)
{
int max_canon = fpathconf (fd, _PC_MAX_CANON);
+#ifdef __hpux__
+ /* HP-UX 10.20 fpathconf returns 768, but this results in
+ truncated input lines, while 255 works. */
+ if (max_canon > 255) max_canon = 255;
+#endif
return (max_canon < 0 ? SAFE_MAX_CANON :
max_canon > SAFE_MAX_CANON ? max_canon - MAX_CANON_SLACK :
max_canon);
void
setup_pty (int fd)
{
- /* I'm told that TOICREMOTE does not mean control chars
+ /* I'm told that TIOCREMOTE does not mean control chars
"can't be sent" but rather that they don't have
input-editing or signaling effects.
That should be good, because we have other ways
#ifdef SIGIO_REQUIRES_SEPARATE_PROCESS_GROUP
-static int inherited_pgroup;
-static int inherited_tty_pgroup;
+static pid_t inherited_pgroup;
+static pid_t inherited_tty_pgroup;
#endif
CONSOLE_LIVE_P (XCONSOLE (Vcontrolling_terminal)))
{
int fd = open ("/dev/tty", O_RDWR, 0);
- int me = getpid ();
+ pid_t me = getpid ();
EMACS_BLOCK_SIGNAL (SIGTTOU);
EMACS_SET_TTY_PROCESS_GROUP (fd, &me);
EMACS_UNBLOCK_SIGNAL (SIGTTOU);
/*
* Return the address of the start of the data segment prior to
* doing an unexec. After unexec the return value is undefined.
- * See crt0.c for further information and definition of data_start.
+ * See ecrt0.c for further information and definition of data_start.
*
* Apparently, on BSD systems this is etext at startup. On
* USG systems (swapping) this is highly mmu dependent and
}
#endif /* ENCAPSULATE_FSTAT */
-#ifdef ENCAPSULATE_STAT
int
-sys_stat (const char *path, struct stat *buf)
+xemacs_stat (const char *path, struct stat *buf)
{
PATHNAME_CONVERT_OUT (path);
#ifdef WIN32_NATIVE
return stat (path, buf);
#endif
}
-#endif /* ENCAPSULATE_STAT */
/****************** file-manipulation calls *****************/
int cpid, status, fd;
struct stat statbuf;
- if (stat (dpath, &statbuf) == 0)
+ if (stat (dpath, &statbuf) == 0) /* we do want stat() here */
{
errno = EEXIST; /* Stat worked, so it already exists */
return -1;
int cpid, status, fd;
struct stat statbuf;
- if (stat (dpath, &statbuf) != 0)
+ if (stat (dpath, &statbuf) != 0) /* we do want stat() here */
{
/* Stat just set errno. We don't have to */
return -1;
}
#endif /* USE_DL_STUBS */
-
-\f
-
-#ifndef HAVE_STRCASECMP
-/*
- * From BSD
- */
-static unsigned char charmap[] = {
- '\000', '\001', '\002', '\003', '\004', '\005', '\006', '\007',
- '\010', '\011', '\012', '\013', '\014', '\015', '\016', '\017',
- '\020', '\021', '\022', '\023', '\024', '\025', '\026', '\027',
- '\030', '\031', '\032', '\033', '\034', '\035', '\036', '\037',
- '\040', '\041', '\042', '\043', '\044', '\045', '\046', '\047',
- '\050', '\051', '\052', '\053', '\054', '\055', '\056', '\057',
- '\060', '\061', '\062', '\063', '\064', '\065', '\066', '\067',
- '\070', '\071', '\072', '\073', '\074', '\075', '\076', '\077',
- '\100', '\141', '\142', '\143', '\144', '\145', '\146', '\147',
- '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157',
- '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167',
- '\170', '\171', '\172', '\133', '\134', '\135', '\136', '\137',
- '\140', '\141', '\142', '\143', '\144', '\145', '\146', '\147',
- '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157',
- '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167',
- '\170', '\171', '\172', '\173', '\174', '\175', '\176', '\177',
- '\200', '\201', '\202', '\203', '\204', '\205', '\206', '\207',
- '\210', '\211', '\212', '\213', '\214', '\215', '\216', '\217',
- '\220', '\221', '\222', '\223', '\224', '\225', '\226', '\227',
- '\230', '\231', '\232', '\233', '\234', '\235', '\236', '\237',
- '\240', '\241', '\242', '\243', '\244', '\245', '\246', '\247',
- '\250', '\251', '\252', '\253', '\254', '\255', '\256', '\257',
- '\260', '\261', '\262', '\263', '\264', '\265', '\266', '\267',
- '\270', '\271', '\272', '\273', '\274', '\275', '\276', '\277',
- '\300', '\301', '\302', '\303', '\304', '\305', '\306', '\307',
- '\310', '\311', '\312', '\313', '\314', '\315', '\316', '\317',
- '\320', '\321', '\322', '\323', '\324', '\325', '\326', '\327',
- '\330', '\331', '\332', '\333', '\334', '\335', '\336', '\337',
- '\340', '\341', '\342', '\343', '\344', '\345', '\346', '\347',
- '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357',
- '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367',
- '\370', '\371', '\372', '\373', '\374', '\375', '\376', '\377',
-};
-
-int
-strcasecmp (char *s1, char *s2)
-{
- unsigned char *cm = charmap;
- unsigned char *us1 = (unsigned char *) s1;
- unsigned char *us2 = (unsigned char *)s2;
-
- while (cm[*us1] == cm[*us2++])
- if (*us1++ == '\0')
- return (0);
-
- return (cm[*us1] - cm[*--us2]);
-}
-#endif /* !HAVE_STRCASECMP */
dll_handle
dll_open (const char *fname)
{
- return (dll_handle)dlopen (fname, RTLD_LAZY | RTLD_GLOBAL);
+ return (dll_handle) dlopen (fname, RTLD_LAZY | RTLD_GLOBAL);
}
int
dll_close (dll_handle h)
{
- return dlclose((void *)h);
+ return dlclose ((void *) h);
}
dll_func
#ifdef DLSYM_NEEDS_UNDERSCORE
char *buf = alloca_array (char, strlen (n) + 2);
*buf = '_';
- (void)strcpy(buf + 1, n);
+ strcpy (buf + 1, n);
n = buf;
#endif
- return (dll_func)dlsym ((void *)h, n);
+ return (dll_func) dlsym ((void *) h, n);
}
dll_var
#ifdef DLSYM_NEEDS_UNDERSCORE
char *buf = alloca_array (char, strlen (n) + 2);
*buf = '_';
- (void)strcpy(buf + 1, n);
+ strcpy (buf + 1, n);
n = buf;
#endif
return (dll_var)dlsym ((void *)h, n);
dll_error (dll_handle h)
{
#if defined(HAVE_DLERROR) || defined(dlerror)
- return (const char *)dlerror ();
+ return (const char *) dlerror ();
#elif defined(HAVE__DLERROR)
- return (const char *)_dlerror();
+ return (const char *) _dlerror();
#else
return "Shared library error";
#endif
dll_handle
dll_open (const char *fname)
{
- shl_t h = shl_load (fname, BIND_DEFERRED,0L);
- shl_t *hp = NULL;
+ /* shl_load will hang hard if passed a NULL fname. */
+ if (fname == NULL) return NULL;
- if (h)
- {
- hp = (shl_t *)malloc (sizeof (shl_t));
- if (!hp)
- shl_unload(h);
- else
- *hp = h;
- }
- return (dll_handle)hp;
+ return (dll_handle) shl_load (fname, BIND_DEFERRED,0L);
}
int
dll_close (dll_handle h)
{
- shl_t hp = *((shl_t *)h);
- free (hp);
- return shl_unload(h);
+ return shl_unload ((shl_t) h);
}
dll_func
{
long handle = 0L;
- if (shl_findsym ((shl_t *)h, n, TYPE_PROCEDURE, &handle))
+ if (shl_findsym ((shl_t *) &h, n, TYPE_PROCEDURE, &handle))
return NULL;
- return (dll_func)handle;
+ return (dll_func) handle;
}
dll_var
{
long handle = 0L;
- if (shl_findsym ((shl_t *)h, n, TYPE_DATA, &handle))
+ if (shl_findsym ((shl_t *) &h, n, TYPE_DATA, &handle))
return NULL;
- return (dll_var)handle;
+ return (dll_var) handle;
}
const char *
if (rc)
return NULL;
- return (dll_handle)1;
+ return (dll_handle) 1;
}
int
DLL_FUNC
dll_function (dll_handle h, const char *n)
{
- return dld_get_func(n);
+ return dld_get_func (n);
}
DLL_FUNC
dll_variable (dll_handle h, const char *n)
{
- return dld_get_symbol(n);
+ return dld_get_symbol (n);
}
#elif defined (WIN32_NATIVE)
dll_handle
dll_open (const char *fname)
{
- return (dll_handle)LoadLibrary (fname);
+ return (dll_handle) LoadLibrary (fname);
}
int
dll_func
dll_function (dll_handle h, const char *n)
{
- return (dll_func)GetProcAddress (h,n);
+ return (dll_func) GetProcAddress (h, n);
}
dll_func
dll_variable (dll_handle h, const char *n)
{
- return (dll_func)GetProcAddress (h,n);
+ return (dll_func) GetProcAddress (h, n);
}
const char *
}
#endif
+/* More stand-ins ... */
+
+#define Qdll_filename_encoding Qfile_name
+#define Qdll_function_name_encoding Qnative
+
#endif /* INCLUDED_sysdll_h_ */
#include <sys/stat.h>
#ifndef WIN32_NATIVE
+/* Some configuration files' definitions for the LOAD_AVE_CVT macro
+ (like sparc.h's) use macros like FSCALE, defined here. */
#include <sys/param.h>
#endif
#endif
#if defined (ENCAPSULATE_FSTAT) && !defined (DONT_ENCAPSULATE)
# undef fstat
-/* Need to use arguments to avoid messing with struct stat */
-# define fstat(fd, buf) sys_fstat (fd, buf)
+# define fstat sys_fstat
#endif
#if !defined (ENCAPSULATE_FSTAT) && defined (DONT_ENCAPSULATE)
# define sys_fstat fstat
#endif
-#ifdef ENCAPSULATE_STAT
-int sys_stat (const char *path, struct stat *buf);
-#endif
-#if defined (ENCAPSULATE_STAT) && !defined (DONT_ENCAPSULATE)
-# undef stat
-/* Need to use arguments to avoid messing with struct stat */
-# define stat(path, buf) sys_stat (path, buf)
-#endif
-#if !defined (ENCAPSULATE_STAT) && defined (DONT_ENCAPSULATE)
-# define sys_stat stat
-#endif
+int xemacs_stat (const char *path, struct stat *buf);
/* encapsulations: file-manipulation calls */
#include <sys/select.h>
#endif
+#ifdef HAVE_SYS_STROPTS_H
+#include <sys/stropts.h> /* isastream(), I_PUSH */
+#endif
+
+#ifdef HAVE_SYS_STRTIO_H
+#include <sys/strtio.h> /* TIOCSIGNAL */
+#endif
+
+#ifdef HAVE_PTY_H
+#include <pty.h> /* openpty() on Tru64, Linux */
+#endif
+
+#ifdef HAVE_LIBUTIL_H
+#include <libutil.h> /* openpty() on BSD */
+#endif
+
#ifdef FD_SET
/* We could get this from param.h, but better not to depend on finding that.
/* On bsd, [man says] kill does not accept a negative number to kill a pgrp.
Must do that using the killpg call. */
-#ifdef BSD
-#define EMACS_KILLPG(gid, signo) killpg (gid, signo)
+#ifdef HAVE_KILLPG
+#define EMACS_KILLPG(pid, signo) killpg (pid, signo)
#else
#ifdef WIN32_NATIVE
-#define EMACS_KILLPG(gid, signo) kill (gid, signo)
+#define EMACS_KILLPG(pid, signo) kill (pid, signo)
#else
-#define EMACS_KILLPG(gid, signo) kill (-(gid), signo)
+#define EMACS_KILLPG(pid, signo) kill (-(pid), signo)
#endif
#endif
/* Manipulate a terminal's current (foreground) process group */
/* -------------------------------------------------------------------- */
-/* EMACS_HAVE_TTY_PGRP is true if we can get and set the tty's current
- controlling process group.
+/* EMACS_GET_TTY_PGRP(int FD, pid_t *PGID) sets *PGID to the terminal
+ FD's current foreground process group. Return -1 if there is an error.
- EMACS_GET_TTY_PGRP(int FD, int *PGID) sets *PGID the terminal FD's
- current process group. Return -1 if there is an error.
+ EMACS_SET_TTY_PGRP(int FD, pid_t *PGID) sets the terminal FD's current
+ foreground process group to *PGID. Return -1 if there is an error.
- EMACS_SET_TTY_PGRP(int FD, int *PGID) sets the terminal FD's
- current process group to *PGID. Return -1 if there is an error. */
+ We prefer using the ioctl (BSD) interface instead of its Posix
+ replacement tgetpgrp/tcsetpgrp since that is documented as being
+ restricted to processes sharing the same controlling tty. */
-/* HPUX tty process group stuff doesn't work, says the anonymous voice
- from the past. */
-/* But HPUX people say it does, so I've removed it. --ben */
-# ifdef TIOCGPGRP
-# define EMACS_HAVE_TTY_PGRP
-# else
-# ifdef HAVE_TERMIOS
-# define EMACS_HAVE_TTY_PGRP
-# endif
-# endif
-
-#ifdef EMACS_HAVE_TTY_PGRP
-
-#if defined (HAVE_TERMIOS) && ! defined (BSD_TERMIOS)
+#if defined (TIOCGPGRP)
-/* Resist the urge to insert needless extra parentheses. */
-#define EMACS_GET_TTY_PGRP(fd, pgid) (*(pgid) = tcgetpgrp (fd))
-#define EMACS_SET_TTY_PGRP(fd, pgid) tcsetpgrp (fd, *(pgid))
+#define EMACS_GET_TTY_PROCESS_GROUP(fd, pgid) ioctl (fd, TIOCGPGRP, pgid)
+#define EMACS_SET_TTY_PROCESS_GROUP(fd, pgid) ioctl (fd, TIOCSPGRP, pgid)
-#elif defined (TIOCSPGRP)
+#elif defined (HAVE_TCGETPGRP)
-#define EMACS_GET_TTY_PGRP(fd, pgid) (ioctl ((fd), TIOCGPGRP, (pgid)))
-#define EMACS_SET_TTY_PGRP(fd, pgid) (ioctl ((fd), TIOCSPGRP, (pgid)))
+#define EMACS_GET_TTY_PROCESS_GROUP(fd, pgid) (*(pgid) = tcgetpgrp (fd))
+#define EMACS_SET_TTY_PROCESS_GROUP(fd, pgid) tcsetpgrp (fd, *(pgid))
-#endif
-
-#endif /* EMACS_HAVE_TTY_PGRP */
-
-#ifndef EMACS_GET_TTY_PGRP
+#else
/* Just ignore this for now and hope for the best */
-#define EMACS_GET_TTY_PGRP(fd, pgid) 0
-#define EMACS_SET_TTY_PGRP(fd, pgif) 0
+#define EMACS_GET_TTY_PROCESS_GROUP(fd, pgid) 0
+#define EMACS_SET_TTY_PROCESS_GROUP(fd, pgif) 0
#endif
-/* XEmacs interim backward-compatibility */
-#define EMACS_GET_TTY_PROCESS_GROUP EMACS_GET_TTY_PGRP
-#define EMACS_SET_TTY_PROCESS_GROUP EMACS_SET_TTY_PGRP
-
/* EMACS_GETPGRP (arg) returns the process group of the terminal. */
#ifdef GETPGRP_VOID
const char *term;
int malloc_size = 0;
int c;
- char *tcenv; /* TERMCAP value, if it contais :tc=. */
+ char *tcenv; /* TERMCAP value, if it contains :tc=. */
const char *indirect = 0; /* Terminal type in :tc= in TERMCAP value. */
tem = getenv ("TERMCAP");
return data->help_string;
}
-static void
-print_toolbar_button (Lisp_Object obj, Lisp_Object printcharfun,
- int escapeflag)
-{
- struct toolbar_button *tb = XTOOLBAR_BUTTON (obj);
- char buf[100];
-
- if (print_readably)
- error ("printing unreadable object #<toolbar-button 0x%x>",
- tb->header.uid);
-
- sprintf (buf, "#<toolbar-button 0x%x>", tb->header.uid);
- write_c_string (buf, printcharfun);
-}
-
DEFINE_LRECORD_IMPLEMENTATION ("toolbar-button", toolbar_button,
- mark_toolbar_button, print_toolbar_button,
- 0, 0, 0, 0,
+ mark_toolbar_button, 0, 0, 0, 0, 0,
struct toolbar_button);
DEFUN ("toolbar-button-p", Ftoolbar_button_p, 1, 1, 0, /*
which buffer to check in. #### I think this is a bad thing.
See if we can't get enough information to this function so
that it can check.
-
+
#### Wrong. We shouldn't be checking the value at all here.
The user might set or change the value at any time. */
value = Fsymbol_value (elt[0]);
#include "elhash.h"
#include "process.h"
#include "tooltalk.h"
+#include "syssignal.h"
Lisp_Object Vtooltalk_fd;
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_message_arg_val_set (m, n, value_ext);
}
else if (EQ (attribute, Qtt_status))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
(*fun_str) (m, value_ext);
}
{
const char *vtype_ext;
- TO_EXTERNAL_FORMAT (LISP_STRING, vtype, C_STRING_ALLOCA, vtype_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (vtype, vtype_ext, Qnative);
if (NILP (value))
tt_message_arg_add (m, n, vtype_ext, NULL);
else if (STRINGP (value))
{
const char *value_ext;
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_message_arg_add (m, n, vtype_ext, value_ext);
}
else if (INTP (value))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_file_add (p, value_ext);
}
else if (EQ (attribute, Qtt_object))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_object_add (p, value_ext);
}
else if (EQ (attribute, Qtt_op))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_op_add (p, value_ext);
}
else if (EQ (attribute, Qtt_otype))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_otype_add (p, value_ext);
}
else if (EQ (attribute, Qtt_scope))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_sender_add (p, value_ext);
}
else if (EQ (attribute, Qtt_sender_ptype))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_sender_ptype_add (p, value_ext);
}
else if (EQ (attribute, Qtt_session))
{
const char *value_ext;
CHECK_STRING (value);
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_session_add (p, value_ext);
}
else if (EQ (attribute, Qtt_state))
{
const char *vtype_ext;
- TO_EXTERNAL_FORMAT (LISP_STRING, vtype, C_STRING_ALLOCA, vtype_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (vtype, vtype_ext, Qnative);
if (NILP (value))
tt_pattern_arg_add (p, n, vtype_ext, NULL);
else if (STRINGP (value))
{
const char *value_ext;
- TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
+ LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
tt_pattern_arg_add (p, n, vtype_ext, value_ext);
}
else if (INTP (value))
defsymbol (&Qtt_reply, "reply");
defsymbol (&Qtt_fail, "fail");
- deferror (&Qtooltalk_error, "tooltalk-error", "ToolTalk error", Qio_error);
+ DEFERROR (Qtooltalk_error, "ToolTalk error", Qio_error);
}
void
#include <fcntl.h>
#include <config.h>
#include <string.h>
+
+#define DONT_ENCAPSULATE /* filenames are external in unex*.c */
#include "sysfile.h"
+
#define PERROR(arg) perror(arg);exit(-1)
#ifndef HAVE_A_OUT_H
#include <errno.h>
#include <a.out.h>
+#include "lisp.h"
/*
* Minor modification to enable dumping with shared libraries added by
#ifdef HPUX_USE_SHLIBS
#include <dl.h> /* User-space dynamic loader entry points */
-void Save_Shared_Data(void);
-int run_time_remap();
+static void Save_Shared_Data (void);
+static void Restore_Shared_Data (void);
#endif
-#define min(x,y) ( ((x)<(y))?(x):(y) )
-
void write_header(int file, struct header *hdr, struct som_exec_auxhdr *auxhdr);
void read_header (int file, struct header *hdr, struct som_exec_auxhdr *auxhdr);
void save_data_space (int file, struct header *hdr,
/* Create a new a.out file, same as old but with current data space */
int
-unexec(char new_name[], /* name of the new a.out file to be created */
- char old_name[], /* name of the old a.out file */
- char *new_end_of_text, /* ptr to new edata/etext; NOT USED YET */
- int dummy1, int dummy2) /* not used by emacs */
+unexec (char *new_name, /* name of the new a.out file to be created */
+ char *old_name, /* name of the old a.out file */
+ uintptr_t new_end_of_text, /* ptr to new edata/etext; NOT USED YET */
+ uintptr_t dummy1, uintptr_t dummy2) /* not used by emacs */
{
int old, new;
int old_size, new_size;
for (; size > 0; size -= len)
{
- len = min(size, sizeof(buffer));
- if (read(old, buffer, len) != len)
- { perror("Read failure on a.out file"); exit(1); }
- if (write(new, buffer, len) != len)
- { perror("Write failure in a.out file"); exit(1); }
+ len = size < sizeof (buffer) ? size : sizeof (buffer);
+ if (read (old, buffer, len) != len)
+ {
+ perror ("Read failure on a.out file");
+ exit (1);
+ }
+ if (write (new, buffer, len) != len)
+ {
+ perror ("Write failure in a.out file");
+ exit (1);
+ }
}
}
void *Brk_On_Dump = 0; /* Brk value to restore... stored as a global */
-void Save_Shared_Data () {
- Brk_On_Dump = sbrk( 0 );
-}
-
-void Restore_Shared_Data () {
- brk ( Brk_On_Dump );
+static void
+Save_Shared_Data (void)
+{
+ Brk_On_Dump = sbrk (0);
}
-int run_time_remap (int d) {
- Restore_Shared_Data();
+static void
+Restore_Shared_Data (void)
+{
+ brk (Brk_On_Dump);
}
/* run_time_remap is the magic called by startup code in the dumped executable
- * if RUN_TIME_REMAP is set.
- */
+ if RUN_TIME_REMAP is set. */
+int
+run_time_remap (char *dummy)
+{
+ Restore_Shared_Data ();
+ return 0;
+}
#endif /* HPUX_USE_SHLIBS */
* version of my_ebss in lastfile.c and a new firstfile.c file. jhar */
#include <config.h>
-#include <stdlib.h> /* _fmode */
-#include <stdio.h>
-#include <fcntl.h>
-#include <windows.h>
+#include "lisp.h"
+
+#include "syswindows.h"
#include "nt.h"
#include "ntheap.h"
}
/* Dump out .data and .bss sections into a new executable. */
-void
-unexec (char *new_name, char *old_name, void *start_data, void *start_bss,
- void *entry_address)
+int
+unexec (char *new_name, char *old_name, unsigned int start_data,
+ unsigned int start_bss, unsigned int entry_address)
{
file_data in_file, out_file;
char out_filename[MAX_PATH], in_filename[MAX_PATH];
close_file_data (&in_file);
close_file_data (&out_file);
+
+ return 0;
}
/* Routines to manipulate NT executable file sections. */
if (data_size > five_percent * 15)
{
warnlevel++;
- (*warn_function) ("Warning: past 75% of memory limit");
+ (*save_warn_fun) ("Warning: past 75% of memory limit");
}
break;
if (data_size > five_percent * 17)
{
warnlevel++;
- (*warn_function) ("Warning: past 85% of memory limit");
+ (*save_warn_fun) ("Warning: past 85% of memory limit");
}
break;
if (data_size > five_percent * 19)
{
warnlevel++;
- (*warn_function) ("Warning: past 95% of memory limit");
+ (*save_warn_fun) ("Warning: past 95% of memory limit");
}
break;
default:
- (*warn_function) ("Warning: past acceptable memory limits");
+ (*save_warn_fun) ("Warning: past acceptable memory limits");
break;
}
warn_function = save_warn_fun;
warnlevel = 2;
if (EXCEEDS_LISP_PTR (cp))
- (*warn_function) ("Warning: memory in use exceeds lisp pointer size");
+ {
+ if (warn_function)
+ {
+ /* temporarily reset the warn_function to 0 or we will get infinite
+ looping. */
+ save_warn_fun = warn_function;
+ warn_function = 0;
+ (*save_warn_fun)
+ ("Warning: memory in use exceeds lisp pointer size");
+ warn_function = save_warn_fun;
+ }
+ }
}
/* Cause reinitialization based on job parameters;
/* Divider surface width (not counting 3-d borders) */
Lisp_Object Vvertical_divider_line_width;
-/* Spacing between outer egde of divider border and window edge */
+/* Spacing between outer edge of divider border and window edge */
Lisp_Object Vvertical_divider_spacing;
/* How much to scroll by per-line. */
p->line_start_cache = Dynarr_new (line_start_cache);
p->subwindow_instance_cache = make_lisp_hash_table (30,
HASH_TABLE_KEY_VALUE_WEAK,
- HASH_TABLE_EQUAL);
+ HASH_TABLE_EQ);
p->line_cache_last_updated = Qzero;
INIT_DISP_VARIABLE (last_point_x, 0);
INIT_DISP_VARIABLE (last_point_y, 0);
{
if (!NILP (w->hchild) || !NILP (w->vchild))
return 0;
-
+
#ifdef HAVE_SCROLLBARS
if (!NILP (w->scrollbar_on_top_p))
return window_scrollbar_height (w);
The names are somewhat confusing; here's a table to help out:
- width height
+ width height
-------------------------------------------------------------------------
w/o gutters
(rows/columns) window-width window-text-area-height
}
DEFUN ("modeline-hscroll", Fmodeline_hscroll, 0, 1, 0, /*
-Return the horizontal scrolling ammount of WINDOW's modeline.
+Return the horizontal scrolling amount of WINDOW's modeline.
If the window has no modeline, return nil.
*/
(window))
}
DEFUN ("set-modeline-hscroll", Fset_modeline_hscroll, 2, 2, 0, /*
-Set the horizontal scrolling ammount of WINDOW's modeline to NCOL.
+Set the horizontal scrolling amount of WINDOW's modeline to NCOL.
If NCOL is negative, it will silently be forced to 0.
If the window has no modeline, return nil. Otherwise, return the actual
value that was set.
(window))
{
struct window *w = decode_window (window);
+ struct frame *f = XFRAME (w->frame);
- int left = w->pixel_left;
- int top = w->pixel_top;
+ int left =
+ w->pixel_left - FRAME_LEFT_BORDER_END (f) - FRAME_LEFT_GUTTER_BOUNDS (f);
+ int top =
+ w->pixel_top - FRAME_TOP_BORDER_END (f) - FRAME_TOP_GUTTER_BOUNDS (f);
return list4 (make_int (left),
make_int (top),
DEFUN ("window-point", Fwindow_point, 0, 1, 0, /*
Return current value of point in WINDOW.
-For a nonselected window, this is the value point would have
+For a non-selected window, this is the value point would have
if that window were selected.
Note that, when WINDOW is the selected window and its buffer
ERROR_CHECK_SUBWINDOW_CACHE (p);
}
-static int
-window_unmap_subwindows_cache_mapper (Lisp_Object key, Lisp_Object value,
- void *flag_closure)
-{
- /* value can be nil; we cache failures as well as successes */
- if (!NILP (value))
- {
- struct frame* f = XFRAME (XIMAGE_INSTANCE_FRAME (value));
- unmap_subwindow (value);
- /* In case GC doesn't catch up fast enough, remove from the frame
- cache also. Otherwise code that checks the sanity of the instance
- will fail. */
- XWEAK_LIST_LIST (FRAME_SUBWINDOW_CACHE (f))
- = delq_no_quit (value, XWEAK_LIST_LIST (FRAME_SUBWINDOW_CACHE (f)));
- }
- return 0;
-}
-
static void
window_unmap_subwindows (struct window* w)
{
assert (!NILP (w->subwindow_instance_cache));
- elisp_maphash (window_unmap_subwindows_cache_mapper,
- w->subwindow_instance_cache, 0);
+ elisp_maphash (unmap_subwindow_instance_cache_mapper,
+ w->subwindow_instance_cache, (void*)1);
}
/* we're deleting W; set the structure of W to indicate this. */
\f
DEFUN ("next-window", Fnext_window, 0, 4, 0, /*
-Return next window after WINDOW in canonical ordering of windows.
+Return the next window after WINDOW in the canonical ordering of windows.
If omitted, WINDOW defaults to the selected window.
Optional second arg MINIBUF t means count the minibuffer window even
If ALL-FRAMES is a frame, restrict search to windows on that frame.
Anything else means restrict to WINDOW's frame.
-Optional fourth argument CONSOLE controls which consoles or devices the
+Optional fourth arg CONSOLE controls which consoles or devices the
returned window may be on. If CONSOLE is a console, return windows only
on that console. If CONSOLE is a device, return windows only on that
device. If CONSOLE is a console type, return windows only on consoles
minibuf = (minibuf_level ? minibuf_window : Qlambda);
else if (! EQ (minibuf, Qt))
minibuf = Qlambda;
- /* Now minibuf can be t => count all minibuffer windows,
- lambda => count none of them,
+ /* Now `minibuf' is one of:
+ t => count all minibuffer windows
+ lambda => count none of them
or a specific minibuffer window (the active one) to count. */
/* all_frames == nil doesn't specify which frames to include. */
return frame_first_window (XFRAME (all_frames));
else if (! EQ (all_frames, Qt))
all_frames = Qnil;
- /* Now all_frames is t meaning search all frames,
- nil meaning search just current frame,
- visible meaning search just visible frames,
- 0 meaning search visible and iconified frames,
- or a window, meaning search the frame that window belongs to. */
+ /* Now `all_frames' is one of:
+ t => search all frames
+ nil => search just the current frame
+ visible => search just visible frames
+ 0 => search visible and iconified frames
+ a window => search the frame that window belongs to. */
/* Do this loop at least once, to get the next window, and perhaps
again, if we hit the minibuffer and that is not acceptable. */
if (! NILP (all_frames))
{
- Lisp_Object tem1;
-
- tem1 = tem;
+ Lisp_Object tem1 = tem;
tem = next_frame (tem, all_frames, console);
+
/* In the case where the minibuffer is active,
and we include its frame as well as the selected one,
next_frame may get stuck in that frame.
else break;
}
}
- /* "acceptable" is the correct spelling. */
/* Which windows are acceptable?
Exit the loop and accept this window if
this isn't a minibuffer window,
}
DEFUN ("previous-window", Fprevious_window, 0, 4, 0, /*
-Return the window preceding WINDOW in canonical ordering of windows.
+Return the window preceding WINDOW in the canonical ordering of windows.
If omitted, WINDOW defaults to the selected window.
Optional second arg MINIBUF t means count the minibuffer window even
counts, all windows on all frames that share that minibuffer count
too. Therefore, `previous-window' can be used to iterate through
the set of windows even when the minibuffer is on another frame. If
-the minibuffer does not count, only windows from WINDOW's frame count
+the minibuffer does not count, only windows from WINDOW's frame count.
-If optional third arg ALL-FRAMES t means include windows on all frames.
+Optional third arg ALL-FRAMES t means include windows on all frames.
ALL-FRAMES nil or omitted means cycle within the frames as specified
above. ALL-FRAMES = `visible' means include windows on all visible frames.
ALL-FRAMES = 0 means include windows on all visible and iconified frames.
If ALL-FRAMES is a frame, restrict search to windows on that frame.
Anything else means restrict to WINDOW's frame.
-Optional fourth argument CONSOLE controls which consoles or devices the
+Optional fourth arg CONSOLE controls which consoles or devices the
returned window may be on. If CONSOLE is a console, return windows only
on that console. If CONSOLE is a device, return windows only on that
device. If CONSOLE is a console type, return windows only on consoles
minibuf = (minibuf_level ? minibuf_window : Qlambda);
else if (! EQ (minibuf, Qt))
minibuf = Qlambda;
- /* Now minibuf can be t => count all minibuffer windows,
- lambda => count none of them,
+ /* Now `minibuf' is one of:
+ t => count all minibuffer windows
+ lambda => count none of them
or a specific minibuffer window (the active one) to count. */
/* all_frames == nil doesn't specify which frames to include.
return frame_first_window (XFRAME (all_frames));
else if (! EQ (all_frames, Qt))
all_frames = Qnil;
- /* Now all_frames is t meaning search all frames,
- nil meaning search just current frame,
- visible meaning search just visible frames,
- 0 meaning search visible and iconified frames,
- or a window, meaning search the frame that window belongs to. */
+ /* Now `all_frames' is one of:
+ t => search all frames
+ nil => search just the current frame
+ visible => search just visible frames
+ 0 => search visible and iconified frames
+ a window => search the frame that window belongs to. */
/* Do this loop at least once, to get the next window, and perhaps
again, if we hit the minibuffer and that is not acceptable. */
tem = WINDOW_FRAME (XWINDOW (window));
if (! NILP (all_frames))
- /* It's actually important that we use prev_frame here,
+ /* It's actually important that we use previous_frame here,
rather than next_frame. All the windows acceptable
according to the given parameters should form a ring;
Fnext_window and Fprevious_window should go back and
window_loop assumes that these `ring' requirement are
met. */
{
- Lisp_Object tem1;
-
- tem1 = tem;
- tem = prev_frame (tem, all_frames, console);
+ Lisp_Object tem1 = tem;
+ tem = previous_frame (tem, all_frames, console);
/* In the case where the minibuffer is active,
and we include its frame as well as the selected one,
next_frame may get stuck in that frame.
int lose_lose = 0;
Lisp_Object devcons, concons;
- /* FRAME_ARG is Qlambda to stick to one frame,
- Qvisible to consider all visible frames,
- or Qt otherwise. */
-
/* If we're only looping through windows on a particular frame,
FRAME points to that frame. If we're looping through windows
on all frames, FRAME is 0. */
-
if (FRAMEP (frames))
frame = XFRAME (frames);
else if (NILP (frames))
frame = selected_frame ();
else
frame = 0;
+
+ /* FRAME_ARG is Qlambda to stick to one frame,
+ Qvisible to consider all visible frames,
+ or Qt otherwise. */
if (frame)
frame_arg = Qlambda;
else if (ZEROP (frames))
if (NILP (the_frame))
continue;
- if (!device_matches_console_spec (the_frame, device, console))
+ if (!device_matches_console_spec (device,
+ NILP (console) ?
+ FRAME_CONSOLE (XFRAME (the_frame)) :
+ console))
continue;
/* Pick a window to start with. */
/* Pick the next window now, since some operations will delete
the current window. */
- next_window = Fnext_window (w, mini ? Qt : Qnil, frame_arg, Qt);
+ next_window = Fnext_window (w, mini ? Qt : Qnil, frame_arg, device);
/* #### Still needed ?? */
/* Given the outstanding quality of the rest of this code,
Make WINDOW display BUFFER as its contents.
BUFFER can be a buffer or buffer name.
-With non-nil optional argument `norecord', do not modify the
+With non-nil optional argument NORECORD, do not modify the
global or per-frame buffer ordering.
*/
(window, buffer, norecord))
The main editor command loop selects the buffer of the selected window
before each command.
-With non-nil optional argument `norecord', do not modify the
+With non-nil optional argument NORECORD, do not modify the
global or per-frame buffer ordering.
*/
(window, norecord))
/* we have already caught dead-window errors */
if (!NILP (w->hchild) || !NILP (w->vchild))
error ("Trying to select non-leaf window");
-
+
w->use_time = make_int (++window_select_count);
if (EQ (window, old_selected_window))
p->line_start_cache = Dynarr_new (line_start_cache);
p->face_cachels = Dynarr_new (face_cachel);
p->glyph_cachels = Dynarr_new (glyph_cachel);
- p->subwindow_instance_cache =
+ p->subwindow_instance_cache =
make_lisp_hash_table (30,
HASH_TABLE_KEY_VALUE_WEAK,
- HASH_TABLE_EQUAL);
+ HASH_TABLE_EQ);
/* Put new into window structure in place of window */
replace_window (window, new);
DEFUN ("split-window", Fsplit_window, 0, 3, "", /*
Split WINDOW, putting SIZE lines in the first of the pair.
WINDOW defaults to selected one and SIZE to half its size.
-If optional third arg HOR-FLAG is non-nil, split side by side
+If optional third arg HORFLAG is non-nil, split side by side
and put SIZE columns in the first of the pair.
*/
(window, chsize, horflag))
record_unwind_protect (free_window_configuration, old_window_config);
mark_windows_in_use (f, 1);
-
- /* Force subwindows to be reinstantiated. They are all going
- anyway and if we don't do this GC may not happen between now
- and the next time we check their integrity. */
+#ifdef BROKEN_SUBWINDOW_REDISPLAY
+ /* Force subwindows to be remapped. This is overkill but saves
+ us having to rely on the redisplay code to unmap any extant
+ subwindows.
+
+ #### It does cause some extra flashing though which we could
+ possibly avoid. So consider trying to get redisplay to work
+ correctly.
+
+ Removing the instances from the frame cache is wrong because
+ an instance is only put in the frame cache when it is
+ instantiated. So if we do this there is a chance that stuff
+ will never get put back in the frame cache. */
reset_frame_subwindow_instance_cache (f);
-
+#endif
#if 0
/* JV: This is bogus,
First of all, the units are inconsistent. The frame sizes are measured
in characters but the window sizes are stored in pixels. So if a
font size change happened between saving and restoring, the
frame "sizes" maybe equal but the windows still should be
- resized. This is tickled alot by the new "character size
- stays constant" policy in 21.0. It leads to very wierd
+ resized. This is tickled a lot by the new "character size
+ stays constant" policy in 21.0. It leads to very weird
glitches (and possibly crashes when asserts are tickled).
- Just changing the units doens't help because changing the
+ Just changing the units doesn't help because changing the
toolbar configuration can also change the pixel positions.
Luckily there is a much simpler way of doing this, see below.
*/
w->hscroll = p->hscroll;
w->modeline_hscroll = p->modeline_hscroll;
w->line_cache_last_updated = Qzero;
- /* The subwindow instance cache isn't preserved across
- window configurations, and in fact doing so would be
- wrong. We just reset to zero and then redisplay will fill
- it up as needed. */
- w->subwindow_instance_cache =
- make_lisp_hash_table (30,
- HASH_TABLE_KEY_VALUE_WEAK,
- HASH_TABLE_EQUAL);
+ /* When we restore a window's configuration, the identity of
+ the window hasn't actually changed - so there is no
+ reason why we shouldn't preserve the instance cache for
+ it - unless it was originally deleted. This will often
+ buy us something as we will not have to re-instantiate
+ all the instances. This is because this is an instance
+ cache - not a display cache. Preserving the display cache
+ would definitely be wrong.
+
+ We specifically want to do this for tabs, since for some
+ reason finding a file will cause the configuration to be
+ set. */
+ if (NILP (w->subwindow_instance_cache))
+ w->subwindow_instance_cache =
+ make_lisp_hash_table (30,
+ HASH_TABLE_KEY_VALUE_WEAK,
+ HASH_TABLE_EQ);
SET_LAST_MODIFIED (w, 1);
SET_LAST_FACECHANGE (w);
w->config_mark = 0;
+ /* #### Consider making the instance cache a winslot. */
#define WINDOW_SLOT(slot, compare) w->slot = p->slot
#include "winslots.h"
config->frame_height = FRAME_HEIGHT (f); */
/* When using `push-window-configuration', often the minibuffer ends
up as the selected window because functions run as the result of
- user interaction e.g. hyper-apropros. It seems to me the sensible
+ user interaction e.g. hyper-apropos. It seems to me the sensible
thing to do is not record the minibuffer here. */
if (FRAME_MINIBUF_ONLY_P (f) || minibuf_level)
config->current_window = FRAME_SELECTED_WINDOW (f);
}
else
{
- /* optimised case */
+ /* optimized case */
dl = Dynarr_atp (dla, y);
db = get_display_block_from_line (dl, TEXT);
Used by `with-output-to-temp-buffer'.
If this function is used, then it must do the entire job of showing
the buffer; `temp-buffer-show-hook' is not run unless this function runs it.
+\(`temp-buffer-show-hook' is obsolete. Do not use in new code.)
*/ );
Vtemp_buffer_show_function = Qnil;
WINDOW_SLOT (vertical_divider_shadow_thickness, EQ);
/* Divider surface width (not counting 3-d borders) */
WINDOW_SLOT (vertical_divider_line_width, EQ);
- /* Spacing between outer egde of divider border and window edge */
+ /* Spacing between outer edge of divider border and window edge */
WINDOW_SLOT (vertical_divider_spacing, EQ);
/* Whether vertical dividers are always displayed */
WINDOW_SLOT (vertical_divider_always_visible_p, EQ);
+2000-10-04 Martin Buchholz <martin@xemacs.org>
+
+ * XEmacs 21.2.36 is released.
+
+2000-09-27 Martin Buchholz <martin@xemacs.org>
+
+ * automated/lisp-tests.el: Add `current-time' test.
+
+2000-09-16 Martin Buchholz <martin@xemacs.org>
+
+ * automated/mule-tests.el: Add ucs tests.
+
+ * DLL/dltest.c: Remove reference to obsolete emacsfns.h
+
+2000-08-03 Yoshiki Hayashi <yoshiki@xemacs.org>
+
+ * automated/lisp-test.el: Check matching \\= against string
+ doesn't crash XEmacs.
+ From: Markus Linnala <maage@cs.tut.fi>
+
+2000-07-26 Andy Piper <andy@xemacs.org>
+
+ * glyph-test.el: fix for new glyph instantiation mechanism.
+
+2000-07-31 Martin Buchholz <martin@xemacs.org>
+
+ * automated/hash-table-tests.el:
+ Fix up test suite to comply with new hash table weakness API.
+
2000-07-19 Martin Buchholz <martin@xemacs.org>
* XEmacs 21.2.35 is released.
# include <config.h>
# include "lisp.h"
-# include "emacsfns.h"
Lisp_Object Qdltest_counter;
(dolist (size '(0 1 100))
(dolist (rehash-size '(1.1 9.9))
(dolist (rehash-threshold '(0.2 .9))
- (dolist (weakness '(nil t key value))
+ (dolist (weakness '(nil key value key-or-value key-and-value))
(dolist (data '(() (1 2) (1 2 3 4)))
(let ((ht (make-hash-table
:test test
(Assert (eq weakness (hash-table-weakness ht))))))))))
(loop for (fun weakness) in '((make-hashtable nil)
- (make-weak-hashtable t)
+ (make-weak-hashtable key-and-value)
(make-key-weak-hashtable key)
(make-value-weak-hashtable value))
do (Assert (eq weakness (hash-table-weakness (funcall fun 10)))))
(loop for (type weakness) in '((non-weak nil)
- (weak t)
+ (weak key-and-value)
(key-weak key)
(value-weak value))
do (Assert (equal (make-hash-table :type type)
(Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar")))
(Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")))
+(Assert (not (string-match "\\(\\.\\=\\)" ".")))
+
;;-----------------------------------------------------
;; Test near-text buffer functions.
;;-----------------------------------------------------
(Check-Error 'wrong-type-argument (subseq 3 2))
(Check-Error 'args-out-of-range (subseq [1 2 3] -42))
(Check-Error 'args-out-of-range (subseq [1 2 3] 0 42))
+
+;;-----------------------------------------------------
+;; Time-related tests
+;;-----------------------------------------------------
+(Assert (= (length (current-time-string)) 24))
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq im (make-glyph [xpm :file "xemacs-icon.xpm"])))
+ (setq im (make-glyph [xbm :file "xemacsicon.xbm"])))
(set-extent-begin-glyph
(make-extent (point) (point))
(setq ok-select nil)
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq radio-button1
- (make-glyph
+ (make-glyph
+ (setq radio-button1
[button :face widget
:descriptor ["ok1" (setq ok-select t)
:style radio :selected ok-select]])))
;; button in a group
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq radio-button2
- (make-glyph
-` [button :descriptor ["ok2" (setq ok-select nil) :style radio
+ (make-glyph
+ (setq radio-button2
+ [button :descriptor ["ok2" (setq ok-select nil) :style radio
:selected (not ok-select)]])))
;; toggle button
(set-extent-begin-glyph
:selected (not ok-select)]])))
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq toggle-button
- (make-glyph [button :descriptor ["ok4" :style toggle
- :callback
- (setq ok-select (not ok-select))
- :selected ok-select]])))
+ (make-glyph
+ (setq toggle-button
+ [button :descriptor ["ok4" :style toggle
+ :callback
+ (setq ok-select (not ok-select))
+ :selected ok-select]])))
;; normal pushbutton
(set-extent-begin-glyph
(setq tree (make-glyph
[tree-view :width 10
:descriptor "My Tree"
- :properties (:items (["One" foo]
- (["Two" foo]
- ["Four" foo]
- "Six")
- "Three"))])))
+ :items (["One" foo]
+ (["Two" foo]
+ ["Four" foo]
+ "Six")
+ "Three")])))
;; tab control
(set-extent-begin-glyph
[tab-control :descriptor "My Tab"
:face highlight
:orientation right
- :properties (:items (["One" foo :selected t]
- ["Two" fee :selected nil]
- ["Three" foo :selected nil]))])))
+ :items (["One" foo :selected t]
+ ["Two" fee :selected nil]
+ ["Three" foo :selected nil])])))
;; progress gauge
(set-extent-begin-glyph
(make-extent (point) (point))
(setq pgauge (make-glyph
- [progress-gauge :width 10 :height 2
+ [progress-gauge :width 10 :height 2 :value 0
:descriptor "ok"])))
;; progress the progress ...
(let ((x 0))
(while (<= x 100)
- (set-image-instance-property (glyph-image-instance pgauge) :value x)
+ (set-glyph-image pgauge `[progress-gauge :width 10 :height 2
+ :descriptor "ok" :value ,x])
(setq x (+ x 5))
(sit-for 0.1)))
;; progress the progress ...
(let ((x 0))
(while (<= x 100)
- (set-image-instance-property (glyph-image-instance pg) :value x)
+ (set-glyph-image pg
+ `[progress-gauge :width 5 :pixel-height 16
+ :descriptor "ok" :value ,x])
(setq x (+ x 5))
(sit-for 0.1)))
;; edit box
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq edit-field (make-glyph [edit-field :pixel-width 50 :pixel-height 30
+ (make-glyph (setq edit-field [edit-field :pixel-width 50 :pixel-height 30
:face bold-italic
:descriptor ["Hello"]])))
;; combo box
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq combo-box (make-glyph
- [combo-box :width 10 :descriptor ["Hello"]
- :properties (:items ("One" "Two" "Three"))])))
+ (make-glyph (setq combo-box
+ [combo-box :width 10 :descriptor ["Hello"]
+ :items ("One" "Two" "Three")])))
;; label
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq label (make-glyph [label :pixel-width 150 :descriptor "Hello"])))
+ (make-glyph (setq label [label :pixel-width 150 :descriptor "Hello"])))
;; string
(set-extent-begin-glyph
(make-extent (point) (point))
- (setq str (make-glyph [string :data "Hello There"])))
+ (make-glyph
+ (setq str
+ [string :data "Hello There"])))
;; scrollbar
;(set-extent-begin-glyph
;; layout
(setq layout
(make-glyph
- [layout :descriptor "The Layout"
- :orientation vertical
- :justify left
- :border [string :data "Hello There Mrs"]
- :items ([native-layout :orientation horizontal
- :items (radio-button1 radio-button2)]
- edit-field toggle-button label str)]))
-(set-glyph-face layout 'gui-element)
+ `[layout :descriptor "The Layout"
+ :orientation vertical
+ :justify left
+ :border [string :data "Hello There Mrs"]
+ :items ([layout :orientation horizontal
+ :items (,radio-button1 ,radio-button2)]
+ ,edit-field ,toggle-button ,label ,str)]))
+;(set-glyph-face layout 'gui-element)
(set-extent-begin-glyph
(make-extent (point) (point)) layout)
+;; another test layout
+(set-extent-begin-glyph
+ (make-extent (point) (point))
+ (setq layout-2
+ (make-glyph `[layout :descriptor "The Layout"
+ :orientation vertical
+ :items ([progress-gauge :value 0 :width 10 :height 2
+ :descriptor "ok"])])))
+
+(set-glyph-image layout-2 `[layout :descriptor "The Layout"
+ :orientation vertical
+ :items ([progress-gauge :value 4 :width 10 :height 2
+ :descriptor "ok"])])
(setq test-toggle-widget nil)
(defun test-toggle (widget)
emacs_is_beta=t
emacs_major_version=21
emacs_minor_version=2
-emacs_beta_version=35
-xemacs_codename="Nike"
+emacs_beta_version=36
+xemacs_codename="Notus"
infodock_major_version=4
infodock_minor_version=0
infodock_build_version=8
projects / chise / xemacs-chise.git.1 / commitdiff