From: kazuhiko Date: Thu, 5 Oct 2000 05:07:19 +0000 (+0000) Subject: This commit was generated by cvs2svn to compensate for changes in r1705, X-Git-Tag: r21-2-37~3^2~1 X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=commitdiff_plain;h=34360e98c9689b0a7eedab93e14df13281141bbd;hp=a7e8bc18e77000b9fe8999f723a8e741f189f147 This commit was generated by cvs2svn to compensate for changes in r1705, which included commits to RCS files with non-trunk default branches. --- diff --git a/PROBLEMS b/PROBLEMS index 0000084..0648a24 100644 --- a/PROBLEMS +++ b/PROBLEMS @@ -523,7 +523,7 @@ correctly if you are using ash instead of bash (see below). 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. @@ -1045,7 +1045,7 @@ it only if it is undefined. 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 @@ -1427,7 +1427,7 @@ Richard Cognot writes: 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 diff --git a/aclocal.m4 b/aclocal.m4 index 1cfb91f..9dd7ecf 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -173,7 +173,7 @@ fi 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" @@ -200,13 +200,13 @@ dnl Now comes the LD trickery. We do things differently to libtool here. 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 @@ -219,7 +219,7 @@ dnl version of XEmacs. With the libtool way, it picks up the linker that 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 @@ -231,7 +231,7 @@ dnl If we are not using gcc, but the system C compiler can produce 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 @@ -513,7 +513,7 @@ dnl 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 diff --git a/configure.usage b/configure.usage index a3ec3a3..d7e9f6c 100644 --- a/configure.usage +++ b/configure.usage @@ -252,9 +252,6 @@ Other options: --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, diff --git a/dynodump/dynodump.c b/dynodump/dynodump.c index ff4477d..b39f93b 100644 --- a/dynodump/dynodump.c +++ b/dynodump/dynodump.c @@ -68,12 +68,12 @@ * 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 @@ -301,7 +301,7 @@ dynodump(const char * file) * 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 diff --git a/etc/CHARSETS b/etc/CHARSETS index dd2d083..d71e593 100644 --- a/etc/CHARSETS +++ b/etc/CHARSETS @@ -16,7 +16,7 @@ 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 diff --git a/etc/Emacs.ad b/etc/Emacs.ad index 65773f1..2dda0f9 100644 --- a/etc/Emacs.ad +++ b/etc/Emacs.ad @@ -17,9 +17,6 @@ ! ! 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. @@ -188,6 +185,14 @@ ! 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-* diff --git a/etc/NEWS b/etc/NEWS index 39d5e6d..856fc15 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -187,8 +187,8 @@ clipboard can be made; the kill-ring and friends will be updated as 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, @@ -252,12 +252,12 @@ menus. ** 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 @@ -380,7 +380,7 @@ to (concat "~" init-file-user). This turned out to be too complicated 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 @@ -509,7 +509,7 @@ interned in the global obarray. For example: (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. diff --git a/etc/OONEWS b/etc/OONEWS index 5ed4498..3c2f4d3 100644 --- a/etc/OONEWS +++ b/etc/OONEWS @@ -801,7 +801,7 @@ as a set of built-in Lisp function in C) by a flexible and 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 diff --git a/etc/gnuserv.1 b/etc/gnuserv.1 index 781d24e..09f213b 100644 --- a/etc/gnuserv.1 +++ b/etc/gnuserv.1 @@ -24,7 +24,7 @@ One typical use for this is with a dialup connection to a machine on 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 diff --git a/etc/xemacs-fe.sh b/etc/xemacs-fe.sh index 881ad07..3b61e27 100755 --- a/etc/xemacs-fe.sh +++ b/etc/xemacs-fe.sh @@ -109,7 +109,7 @@ esac # # 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 diff --git a/etc/xemacs.1 b/etc/xemacs.1 index c912a1c..7e99828 100644 --- a/etc/xemacs.1 +++ b/etc/xemacs.1 @@ -1,4 +1,4 @@ -.TH XEMACS 1 "1998 January 13" +.TH XEMACS 1 "2000-09-20" .UC 4 .SH NAME xemacs \- Emacs: The Next Generation @@ -151,7 +151,7 @@ Load no extra files at startup. Equivalent to the combination of , .B \-no-site-file , and -.B \-no-packages +.B \-no-early-packages \. .TP .BI \-u " user, " \-user " user" @@ -197,16 +197,13 @@ Exit (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: @@ -223,9 +220,11 @@ for a 24bit TrueColor visual) See 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; @@ -318,7 +317,7 @@ this option. .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 @@ -439,7 +438,7 @@ If set to .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. @@ -462,7 +461,7 @@ Sets the default visual 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 @@ -511,7 +510,7 @@ means no horizontal scrollbars. 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. @@ -642,9 +641,6 @@ is included in a convenient tree structured form. /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; @@ -661,19 +657,7 @@ contains the documentation strings for the Lisp primitives and 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 diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog index 7abe91d..cf05b9a 100644 --- a/lib-src/ChangeLog +++ b/lib-src/ChangeLog @@ -1,3 +1,34 @@ +2000-10-04 Martin Buchholz + + * XEmacs 21.2.36 is released. + +2000-09-30 Martin Buchholz + + * gnuserv.c (main): Warning removal. + +2000-09-27 Martin Buchholz + + * 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 + + * *: Spelling mega-patch + +2000-09-12 Martin Buchholz + + * gnuclient.c (main): + * hexl.c (usage): + Use `Usage', not `usage', in Usage messages. + +2000-07-15 Ben Wing + + * 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 * XEmacs 21.2.35 is released. diff --git a/lib-src/cvtmail.c b/lib-src/cvtmail.c index 15099ce..a34434c 100644 --- a/lib-src/cvtmail.c +++ b/lib-src/cvtmail.c @@ -24,13 +24,13 @@ Boston, MA 02111-1307, USA. */ * 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 */ @@ -106,7 +106,7 @@ main (int argc, char *argv[]) fclose (cff); } fclose (mddf); - fclose (mfilef); + fclose (mfilef); return 0; } diff --git a/lib-src/ellcc.c b/lib-src/ellcc.c index 54a2c8b..53bd780 100644 --- a/lib-src/ellcc.c +++ b/lib-src/ellcc.c @@ -61,6 +61,7 @@ See the samples for more details. #include #include #include +#include #include #include #include @@ -120,16 +121,19 @@ static void do_init_mode (void); #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 diff --git a/lib-src/etags.c b/lib-src/etags.c index d3cff3f..ce7d1c2 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -4840,6 +4840,10 @@ add_regex (regexp_pattern, ignore_case, lang) 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) { diff --git a/lib-src/fakemail.c b/lib-src/fakemail.c index 0bf4ca4..a074fa8 100644 --- a/lib-src/fakemail.c +++ b/lib-src/fakemail.c @@ -302,7 +302,7 @@ static line_list make_file_preface (void) { char *the_string, *temp; - long idiotic_interface; + time_t idiotic_interface; long prefix_length; long user_length; long date_length; @@ -313,7 +313,8 @@ make_file_preface (void) 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 diff --git a/lib-src/gnuclient.c b/lib-src/gnuclient.c index 0f57c85..58588f6 100644 --- a/lib-src/gnuclient.c +++ b/lib-src/gnuclient.c @@ -225,7 +225,7 @@ filename_expand (char *fullpath, char *filename) /* 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); @@ -461,11 +461,11 @@ main (int argc, char *argv[]) { 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); @@ -573,7 +573,7 @@ main (int argc, char *argv[]) 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) diff --git a/lib-src/gnuserv.c b/lib-src/gnuserv.c index f792f74..419baa8 100644 --- a/lib-src/gnuserv.c +++ b/lib-src/gnuserv.c @@ -889,7 +889,7 @@ main (int argc, char *argv[]) { perror(progname); fprintf(stderr,"%s: unable to select\n",progname); - exit(1); + return 1; } /* if */ #ifdef UNIX_DOMAIN_SOCKETS @@ -905,9 +905,7 @@ main (int argc, char *argv[]) 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 */ diff --git a/lib-src/hexl.c b/lib-src/hexl.c index b254d85..2389bad 100644 --- a/lib-src/hexl.c +++ b/lib-src/hexl.c @@ -149,7 +149,7 @@ main (int argc, char *argv[]) #endif for (;;) { - register int i, c, d; + register int i, c = 0, d; #define hexchar(x) (isdigit (x) ? x - '0' : x - 'a' + 10) @@ -195,7 +195,7 @@ main (int argc, char *argv[]) string[17] = '\0'; for (;;) { - register int i, c; + register int i, c = 0; for (i=0; i < 16; ++i) { @@ -246,6 +246,6 @@ main (int argc, char *argv[]) void usage (void) { - (void) fprintf (stderr, "usage: %s [-de] [-iso]\n", progname); + fprintf (stderr, "Usage: %s [-de] [-iso]\n", progname); exit (1); } diff --git a/lib-src/make-msgfile.c b/lib-src/make-msgfile.c index 31b9379..ed02e6e 100644 --- a/lib-src/make-msgfile.c +++ b/lib-src/make-msgfile.c @@ -1,10 +1,10 @@ -/* - - +/* + + 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. @@ -54,11 +54,11 @@ 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 @@ -66,36 +66,36 @@ 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" ... ) @@ -106,20 +106,20 @@ (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 @@ -128,8 +128,8 @@ "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. @@ -139,7 +139,7 @@ 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 @@ -174,12 +174,12 @@ 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. @@ -306,7 +306,7 @@ void scan_file (char *filename) else process_Lisp_file (); fputc ('\n', outfile); - + fclose (infile); } diff --git a/lisp/ChangeLog.1 b/lisp/ChangeLog.1 index df5627e..3ad71dd 100644 --- a/lisp/ChangeLog.1 +++ b/lisp/ChangeLog.1 @@ -101,7 +101,7 @@ 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. @@ -998,7 +998,7 @@ Sun Nov 01 12:00:00 1997 Jonathan Harris * 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 diff --git a/lisp/autoload.el b/lisp/autoload.el index 965d550..f1ee483 100644 --- a/lisp/autoload.el +++ b/lisp/autoload.el @@ -2,7 +2,7 @@ ;; 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 ;; Keywords: maint @@ -121,7 +121,7 @@ the section of autoloads for a file.") (directory-file-name (file-name-directory file)))) "\\\\" "/")) - + ;;;###autoload (defun generate-file-autoloads (file &optional funlist) "Insert at point a loaddefs autoload section for FILE. @@ -360,8 +360,8 @@ generally the file named `autoload-file-name' in the directory being 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) @@ -542,10 +542,13 @@ on the command line." (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 () @@ -576,7 +579,7 @@ be used only with -batch." (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 () diff --git a/lisp/build-report.el b/lisp/build-report.el index 26b63bd..b3797f3 100644 --- a/lisp/build-report.el +++ b/lisp/build-report.el @@ -3,8 +3,8 @@ ;; Copyright (C) 1997 Adrian Aichner ;; Author: Adrian Aichner -;; 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. @@ -48,90 +48,168 @@ ;;; 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 Beta List ")) + "*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 @@ -151,45 +229,113 @@ available." (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)))) @@ -197,48 +343,69 @@ make output and errors and leaves point at the beginning of the mail text. "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) @@ -247,50 +414,116 @@ created by the XEmacs Beta configure process." (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 diff --git a/lisp/byte-optimize.el b/lisp/byte-optimize.el index 2ab79db..b18664b 100644 --- a/lisp/byte-optimize.el +++ b/lisp/byte-optimize.el @@ -1228,9 +1228,7 @@ ;; 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)) @@ -1464,9 +1462,10 @@ (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 @@ -1912,28 +1911,29 @@ ;; 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) @@ -1969,6 +1969,21 @@ (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) diff --git a/lisp/cl-macs.el b/lisp/cl-macs.el index 9a9d3a0..3299793 100644 --- a/lisp/cl-macs.el +++ b/lisp/cl-macs.el @@ -1413,10 +1413,10 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)." (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)) @@ -1769,6 +1769,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." (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 diff --git a/lisp/cl-seq.el b/lisp/cl-seq.el index 3f0ed88..c97378f 100644 --- a/lisp/cl-seq.el +++ b/lisp/cl-seq.el @@ -355,7 +355,7 @@ Also see: `remove*', `delete', `delete*'" (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*'." diff --git a/lisp/cl.el b/lisp/cl.el index e2ec4c5..03cfdf1 100644 --- a/lisp/cl.el +++ b/lisp/cl.el @@ -269,7 +269,7 @@ If FORM is not a macro call, it is returned unchanged. 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)) diff --git a/lisp/cmdloop.el b/lisp/cmdloop.el index 215fc8d..17989d0 100644 --- a/lisp/cmdloop.el +++ b/lisp/cmdloop.el @@ -462,9 +462,28 @@ and can edit it until it has been confirmed." (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))) + (defun read-char () diff --git a/lisp/code-files.el b/lisp/code-files.el index d854348..f3d138a 100644 --- a/lisp/code-files.el +++ b/lisp/code-files.el @@ -551,9 +551,4 @@ See also `write-region-pre-hook' and `write-region-post-hook'." 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 diff --git a/lisp/code-process.el b/lisp/code-process.el index a60b620..1b248dc 100644 --- a/lisp/code-process.el +++ b/lisp/code-process.el @@ -211,7 +211,7 @@ Fifth argument PROTOCOL is a network protocol. Currently 'tcp (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' diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el index fb14885..98c8048 100644 --- a/lisp/cus-dep.el +++ b/lisp/cus-dep.el @@ -31,7 +31,8 @@ ;;; 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 @@ -91,21 +92,7 @@ ;; 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) @@ -182,6 +169,31 @@ Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS" (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 diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 681f8bc..1d528c7 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -3344,6 +3344,7 @@ Leave point at the location of the call, or after the last expression." (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) @@ -3367,7 +3368,8 @@ Leave point at the location of the call, or after the last expression." (setq ignored-special special) (mapatoms mapper) (when started-writing - (princ ")\n"))))) + (princ ")\n")))) + ) (defun custom-save-loaded-themes () diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 36e2d32..656f710 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -309,7 +309,7 @@ FACE. Nil otherwise." (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 @@ -324,7 +324,7 @@ This means reset face to its value in to-theme." ;;;###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)) diff --git a/lisp/custom.el b/lisp/custom.el index 29486f5..20f02ab 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -185,7 +185,7 @@ The following KEYWORD's are defined: 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 @@ -395,7 +395,7 @@ LOAD should be either a library file name, or a feature name." "(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 @@ -535,7 +535,7 @@ See `custom-set-variables' for a description of the arguments ARGS." (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) @@ -565,7 +565,7 @@ BODY is as with custom-theme-load-themes." (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))))) @@ -614,7 +614,7 @@ VARIABLE. Nil otherwise." (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 @@ -629,7 +629,7 @@ This means reset variable to its value in to-theme." (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)) diff --git a/lisp/dialog.el b/lisp/dialog.el index bd94eaa..cdfbe55 100644 --- a/lisp/dialog.el +++ b/lisp/dialog.el @@ -1,6 +1,7 @@ ;;; 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 @@ -42,53 +43,16 @@ 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. @@ -110,21 +74,20 @@ on the left of the dialog box and all following items on the right." (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. @@ -144,8 +107,8 @@ minibuffer contents show." 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'. @@ -155,63 +118,582 @@ minibuffer contents show." (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 ] + [ \"name\" callback \"suffix\" ] + [ \"name\" callback : : ... ] + + 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 diff --git a/lisp/dragdrop.el b/lisp/dragdrop.el index 9c46f55..1250482 100644 --- a/lisp/dragdrop.el +++ b/lisp/dragdrop.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1998 Oliver Graf ;; Maintainer: XEmacs Development Team, Oliver Graf -;; Keywords: drag, drop, dumped +;; Keywords: mouse, gui, dumped ;; This file is part of XEmacs. @@ -244,8 +244,8 @@ Finds files and URLs. Returns nil if object does not contain URL data." ;; 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) diff --git a/lisp/easymenu.el b/lisp/easymenu.el index 8059470..6673789 100644 --- a/lisp/easymenu.el +++ b/lisp/easymenu.el @@ -24,7 +24,7 @@ ;; 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 ;; Commentary: @@ -33,30 +33,30 @@ ;; 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 ] @@ -105,7 +105,7 @@ or a list to evaluate when the item is chosen. 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 ] ... ] @@ -125,13 +125,13 @@ whenever this expression's value is non-nil. 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 @@ -153,15 +153,14 @@ is a list of menu items, as above." (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) @@ -174,42 +173,48 @@ is a list of menu items, as above." (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) @@ -217,14 +222,14 @@ is a list of menu items, as above." 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 @@ -232,26 +237,30 @@ submenu is then traversed recursively with the remaining elements of PATH. 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)))) + diff --git a/lisp/extents.el b/lisp/extents.el index 37f0752..4647b44 100644 --- a/lisp/extents.el +++ b/lisp/extents.el @@ -1,6 +1,7 @@ ;;; 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 @@ -25,7 +26,10 @@ ;;; 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: @@ -53,7 +57,7 @@ PREDICATE or FUNCTION. See also `map-extents'." 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 @@ -65,11 +69,28 @@ are included in the list. FROM and TO default to the beginning and 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." diff --git a/lisp/faces.el b/lisp/faces.el index 156de24..eff6c16 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -117,19 +117,20 @@ The return value will be a list of instantiators (e.g. strings 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." @@ -304,7 +305,7 @@ The following symbols have predefined meanings: 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. @@ -794,7 +795,8 @@ See `face-property-instance' for the semantics of the DOMAIN argument." ;; 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 @@ -813,13 +815,19 @@ until a non-nil result is found (if there is no such result, the 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 ... @@ -852,10 +860,15 @@ substituted for the specification." ;; 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 @@ -866,7 +879,7 @@ substituted for the specification." (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. @@ -895,14 +908,14 @@ substituted for the specification." (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 @@ -930,7 +943,7 @@ substituted for the specification." (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) @@ -946,7 +959,7 @@ substituted for the specification." (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 @@ -979,11 +992,13 @@ circumstances." (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) @@ -992,10 +1007,10 @@ circumstances." (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 @@ -1006,9 +1021,11 @@ for more specifics on exactly how this function works." (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]) @@ -1017,10 +1034,10 @@ for more specifics on exactly how this function works." (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 @@ -1032,9 +1049,11 @@ for more specifics on exactly how this function works." (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]) @@ -1043,10 +1062,10 @@ for more specifics on exactly how this function works." (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 @@ -1057,9 +1076,11 @@ for more specifics on exactly how this function works." (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]) @@ -1068,10 +1089,10 @@ for more specifics on exactly how this function works." (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 @@ -1082,9 +1103,11 @@ for more specifics on exactly how this function works." (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) @@ -1103,9 +1126,11 @@ because they don't make sense in this context." (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. @@ -1113,9 +1138,11 @@ See `make-face-smaller' for the semantics of the LOCALE argument." (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." @@ -1248,7 +1275,7 @@ See `defface' for information about SPEC." (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.") diff --git a/lisp/find-paths.el b/lisp/find-paths.el index fdd3cc2..cc16201 100644 --- a/lisp/find-paths.el +++ b/lisp/find-paths.el @@ -280,7 +280,7 @@ If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." (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)) diff --git a/lisp/finder.el b/lisp/finder.el index 6967e45..cbed603 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -78,41 +78,48 @@ directories to view or extract information from package source code.") `( (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) @@ -286,6 +293,7 @@ arguments compiles from `load-path'." (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'." @@ -397,7 +405,7 @@ FILE should be in a form suitable for passing to `locate-library'." "\\\\[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) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 297f15d..ee880bb 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -2,7 +2,7 @@ ;; 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 , for the LISPM Preservation Society. ;; Minimally merged with FSF 19.34 by Barry Warsaw @@ -893,9 +893,10 @@ See the variable `font-lock-keywords' for customization." ((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)) @@ -1060,8 +1061,8 @@ This can take a while for large buffers." (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 () @@ -1100,7 +1101,8 @@ This can take a while for large buffers." (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) @@ -1347,8 +1349,9 @@ START should be at the beginning of a line." 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))) @@ -1560,8 +1563,9 @@ START should be at the beginning of a line." (+ (/ (* (- (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'. @@ -1578,7 +1582,9 @@ START should be at the beginning of a line." (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))))) ;; Various functions. @@ -1881,30 +1887,39 @@ START should be at the beginning of a line." ;; ;; 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 C-r \\\\| 3* \" 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. @@ -2336,19 +2351,19 @@ This adds highlighting of Java documentation tags, such as @see.") "\\|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\\|" diff --git a/lisp/glyphs.el b/lisp/glyphs.el index dc3b882..4e31321 100644 --- a/lisp/glyphs.el +++ b/lisp/glyphs.el @@ -543,6 +543,14 @@ Normally DOMAIN will be a window or nil (meaning the selected window), 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. @@ -746,7 +754,7 @@ Once you have created a glyph, you specify where it will be used as follows: `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'.) diff --git a/lisp/help.el b/lisp/help.el index 901724b..ab95b37 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -240,10 +240,8 @@ If the optional argument BURY is non-nil, the help buffer is buried, 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 @@ -480,6 +478,21 @@ You should never set this directory, only let-bind it.") ;; 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'." @@ -492,19 +505,28 @@ 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)) @@ -745,16 +767,15 @@ of the key sequence that ran this command." (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 () @@ -922,6 +943,21 @@ list containing point. If that doesn't give a function, return nil." (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 @@ -1065,6 +1101,119 @@ part of the documentation of internal subroutines." (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'." @@ -1161,7 +1310,13 @@ part of the documentation of internal subroutines." (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))))))))) @@ -1175,7 +1330,6 @@ part of the documentation of internal subroutines." (message nil) (message (function-arglist function))) - (defun variable-at-point () (ignore-errors (with-syntax-table emacs-lisp-mode-syntax-table @@ -1188,6 +1342,21 @@ part of the documentation of internal subroutines." (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)))) @@ -1316,7 +1485,13 @@ part of the documentation of internal subroutines." (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))) @@ -1449,5 +1624,4 @@ after the listing is made.)" (with-displaying-help-buffer (insert string))))) - ;;; help.el ends here diff --git a/lisp/info.el b/lisp/info.el index b9d4aaf..b2e266e 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -494,10 +494,12 @@ or nil if current info file is not split into subfiles.") (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.") @@ -651,7 +653,8 @@ further (recursive) error recovery. TRYFILE is ??" ;; 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) @@ -660,7 +663,7 @@ further (recursive) error recovery. TRYFILE is ??" (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 "") @@ -704,16 +707,20 @@ further (recursive) error recovery. TRYFILE is ??" (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)))) @@ -730,18 +737,21 @@ further (recursive) error recovery. TRYFILE is ??" ;; 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. @@ -1311,30 +1321,30 @@ For example, invoke \"xemacs -batch -f Info-batch-rebuild-dir /usr/local/info\"" (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) @@ -1568,14 +1578,15 @@ annotation for any node of any file. (See `a' and `x' commands.)" (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) @@ -1626,26 +1637,27 @@ annotation for any node of any file. (See `a' and `x' commands.)" (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))) @@ -2814,6 +2826,9 @@ e Edit the contents of the current node." (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) @@ -2879,7 +2894,7 @@ Allowed only if variable `Info-enable-edit' is non-nil." (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) diff --git a/lisp/isearch-mode.el b/lisp/isearch-mode.el index f42dc35..492bacd 100644 --- a/lisp/isearch-mode.el +++ b/lisp/isearch-mode.el @@ -1210,7 +1210,8 @@ Obsolete." (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 diff --git a/lisp/keydefs.el b/lisp/keydefs.el index 765ee58..17f2e66 100644 --- a/lisp/keydefs.el +++ b/lisp/keydefs.el @@ -272,6 +272,10 @@ Keymap for characters following C-c.") (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) diff --git a/lisp/ldap.el b/lisp/ldap.el index c27747a..4f5e9a9 100644 --- a/lisp/ldap.el +++ b/lisp/ldap.el @@ -5,7 +5,7 @@ ;; Author: Oscar Figueiredo ;; Maintainer: Oscar Figueiredo ;; Created: Jan 1998 -;; Version: $Revision: 1.7.2.7 $ +;; Version: $Revision: 1.7.2.8 $ ;; Keywords: help comm ;; This file is part of XEmacs @@ -444,7 +444,19 @@ and the corresponding decoder is then retrieved from (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) @@ -490,10 +502,7 @@ entry according to the value of WITHDN." (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. diff --git a/lisp/lisp-mode.el b/lisp/lisp-mode.el index 502a93c..d0278b1 100644 --- a/lisp/lisp-mode.el +++ b/lisp/lisp-mode.el @@ -43,59 +43,91 @@ (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)) @@ -667,8 +699,16 @@ of the start of the containing expression." (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) @@ -749,6 +789,7 @@ of the start of the containing expression." (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) diff --git a/lisp/menubar-items.el b/lisp/menubar-items.el index c61764c..11f695f 100644 --- a/lisp/menubar-items.el +++ b/lisp/menubar-items.el @@ -54,14 +54,6 @@ ;;; 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 @@ -147,12 +139,13 @@ which will not be used as accelerators." ["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) "")] "-----" @@ -194,15 +187,12 @@ which will not be used as accelerators." :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\")" @@ -363,13 +353,20 @@ which will not be used as accelerators." :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)] @@ -393,6 +390,25 @@ which will not be used as accelerators." ) ("%_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)] @@ -631,38 +647,10 @@ which will not be used as accelerators." ["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 @@ -677,38 +665,20 @@ which will not be used as accelerators." (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] "---" @@ -726,43 +696,46 @@ which will not be used as accelerators." ["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 @@ -967,46 +940,113 @@ which will not be used as accelerators." (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) @@ -1025,6 +1065,34 @@ which will not be used as accelerators." (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 @@ -1045,23 +1113,28 @@ which will not be used as accelerators." :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)] "-----" @@ -1077,7 +1150,8 @@ which will not be used as accelerators." :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)] @@ -1159,64 +1233,6 @@ which will not be used as accelerators." :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 @@ -1232,6 +1248,13 @@ which will not be used as accelerators." :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) @@ -1253,7 +1276,7 @@ which will not be used as accelerators." :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)) @@ -1265,12 +1288,12 @@ which will not be used as accelerators." (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) @@ -1280,10 +1303,10 @@ which will not be used as accelerators." (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) @@ -1296,7 +1319,7 @@ which will not be used as accelerators." :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) @@ -1312,7 +1335,19 @@ which will not be used as accelerators." (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) @@ -1337,46 +1372,18 @@ which will not be used as accelerators." :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" @@ -1407,9 +1414,9 @@ which will not be used as accelerators." ("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" @@ -1477,15 +1484,17 @@ Adds `Load .emacs' button to menubar when starting up with -q." ;;; 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)] @@ -1500,9 +1509,10 @@ Adds `Load .emacs' button to menubar when starting up with -q." ,(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] "---" @@ -1517,7 +1527,7 @@ Adds `Load .emacs' button to menubar when starting up with -q." "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. @@ -1806,6 +1816,7 @@ items by redefining the function `format-buffers-menu-line'." (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)) @@ -1847,35 +1858,37 @@ If this is a relative filename, it is put into the same directory as your ;;; 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))))) - (set-menubar default-menubar) @@ -1903,133 +1916,12 @@ If this is a relative filename, it is put into the same directory as your ["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" -;; )) + +;; misc (defun xemacs-splash-buffer () "Redisplay XEmacs splash screen in a buffer." diff --git a/lisp/menubar.el b/lisp/menubar.el index cdf247b..de084e1 100644 --- a/lisp/menubar.el +++ b/lisp/menubar.el @@ -461,6 +461,199 @@ menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." (enable-menu-item-1 path t nil)) + +;;;;;;; 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 diff --git a/lisp/minibuf.el b/lisp/minibuf.el index 6343c2d..34d2ddb 100644 --- a/lisp/minibuf.el +++ b/lisp/minibuf.el @@ -52,7 +52,7 @@ (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) @@ -1329,6 +1329,15 @@ If N is negative, find the previous or Nth previous match." 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" @@ -1342,7 +1351,7 @@ If N is negative, find the previous or Nth previous match." (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))) @@ -1660,9 +1669,29 @@ If DEFAULT-VALUE is non-nil, return that if user enters an empty 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 () @@ -1946,13 +1975,8 @@ whether it is a file(/result) or a directory (/result/)." ;; 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 diff --git a/lisp/modeline.el b/lisp/modeline.el index 18baacd..c6e6a09 100644 --- a/lisp/modeline.el +++ b/lisp/modeline.el @@ -39,6 +39,23 @@ "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 diff --git a/lisp/mouse.el b/lisp/mouse.el index 9cdab7b..3fdc75a 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -2,7 +2,7 @@ ;; 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 @@ -30,6 +30,15 @@ ;; 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) @@ -39,16 +48,7 @@ (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." @@ -185,7 +185,6 @@ location." (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 @@ -206,7 +205,6 @@ Return nil otherwise." "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)) @@ -214,35 +212,27 @@ Return nil otherwise." (>= (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 - (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 @@ -257,7 +247,6 @@ click, but to the current window and the current position of point. Thus, 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 @@ -503,6 +492,36 @@ A value of nil disables the timeout feature." :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 @@ -539,6 +558,15 @@ produce a number.") '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 @@ -585,9 +613,9 @@ produce a number.") ) (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 @@ -1110,9 +1138,26 @@ at the initial click position." (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) @@ -1133,7 +1178,8 @@ at the initial click position." (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 @@ -1153,13 +1199,16 @@ at the initial click position." (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) @@ -1210,15 +1259,45 @@ at the initial click position." 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) @@ -1471,7 +1550,7 @@ and `mode-motion-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") diff --git a/lisp/mule/mule-ccl.el b/lisp/mule/mule-ccl.el index ae0a188..1f24a55 100644 --- a/lisp/mule/mule-ccl.el +++ b/lisp/mule/mule-ccl.el @@ -952,10 +952,7 @@ ;; (setq args (cdr args))))) -;;; CCL dump staffs - -;; To avoid byte-compiler warning. -(defvar ccl-code) +;;; CCL dump stuff ;;;###autoload (defun ccl-dump (ccl-code) @@ -983,6 +980,7 @@ ;; 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)))) diff --git a/lisp/package-admin.el b/lisp/package-admin.el index 5b732c5..333d303 100644 --- a/lisp/package-admin.el +++ b/lisp/package-admin.el @@ -441,7 +441,8 @@ PACKAGE is a symbol, not a string." ;; 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 diff --git a/lisp/package-get.el b/lisp/package-get.el index bbb1886..b837861 100644 --- a/lisp/package-get.el +++ b/lisp/package-get.el @@ -639,7 +639,6 @@ required by PACKAGES." (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)) diff --git a/lisp/package-ui.el b/lisp/package-ui.el index 32dce7b..806bcf0 100644 --- a/lisp/package-ui.el +++ b/lisp/package-ui.el @@ -521,17 +521,6 @@ Designed to be called interactively (from a keypress)." (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) "..."))] @@ -547,6 +536,16 @@ Designed to be called interactively (from a keypress)." ["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: diff --git a/lisp/paths.el b/lisp/paths.el index 094087b..1636a56 100644 --- a/lisp/paths.el +++ b/lisp/paths.el @@ -85,16 +85,6 @@ ;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.") @@ -104,10 +94,6 @@ The `ORGANIZATION' environment variable is used instead if defined.") (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.") diff --git a/lisp/process.el b/lisp/process.el index 4605e98..e078009 100644 --- a/lisp/process.el +++ b/lisp/process.el @@ -421,7 +421,7 @@ Fifth argument PROTOCOL is a network protocol. Currently 'tcp (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' @@ -432,13 +432,20 @@ lost packets." (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) diff --git a/lisp/replace.el b/lisp/replace.el index 71b8054..990625b 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -604,7 +604,7 @@ The valid answers include `act', `skip', `act-and-show', ;; XEmacs (defun perform-replace-next-event (event) - (if isearch-highlight + (if search-highlight (let ((aborted t)) (unwind-protect (progn diff --git a/lisp/select.el b/lisp/select.el index 1a9a20a..479e548 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -87,7 +87,7 @@ This will do nothing under anything other than X.") 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. @@ -116,7 +116,7 @@ and DATA specifies the contents. DATA may be any lisp data type 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: @@ -131,7 +131,7 @@ The selection may also be a cons of two markers pointing to the same buffer, 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. @@ -364,7 +364,7 @@ any more, because just about anything could be a valid selection now." ;;; 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 @@ -383,6 +383,15 @@ representation otherwise." (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) @@ -410,13 +419,17 @@ representation otherwise." (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))) @@ -585,7 +598,7 @@ representation otherwise." (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. @@ -694,13 +707,18 @@ representation otherwise." ;;; 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) @@ -708,9 +726,16 @@ representation otherwise." ((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) @@ -758,6 +783,22 @@ representation otherwise." (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) diff --git a/lisp/simple.el b/lisp/simple.el index f198f8e..c8d5e1f 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2393,67 +2393,86 @@ With argument 0, interchanges line point is in with line mark is in." (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)))))) + (defcustom comment-column 32 "*Column to indent right-margin comments to. @@ -3373,7 +3392,6 @@ when it is off screen." ;Turned off because it makes dbx bomb out. (setq blink-paren-function 'blink-matching-open) -(eval-when-compile (defvar myhelp)) ; suppress compiler warning ;; XEmacs: Some functions moved to cmdloop.el: ;; keyboard-quit @@ -3557,8 +3575,6 @@ it were the arg to `interactive' (which see) to interactively read the value." (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*" @@ -3573,7 +3589,9 @@ it were the arg to `interactive' (which see) to interactively read the value." (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 @@ -4359,17 +4377,10 @@ The C code calls this periodically, right before redisplay." (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))) @@ -4383,5 +4394,10 @@ The C code calls this periodically, right before redisplay." (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 diff --git a/lisp/subr.el b/lisp/subr.el index fa38653..fd65346 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -351,6 +351,15 @@ SYMBOL's value, function, and property lists." (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 @@ -358,48 +367,31 @@ SYMBOL's value, function, and property lists." "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. @@ -596,25 +588,126 @@ Analogous to (setq LAX-PLIST (lax-plist-remprop LAX-PLIST PROP))." ;;; 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. @@ -646,6 +739,10 @@ yourself.]" (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. diff --git a/lisp/toolbar-items.el b/lisp/toolbar-items.el index 171141b..afe876a 100644 --- a/lisp/toolbar-items.el +++ b/lisp/toolbar-items.el @@ -297,23 +297,22 @@ Mail readers known by default are vm, gnus, rmail, mh, pine, elm, (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)))) ;; diff --git a/lisp/userlock.el b/lisp/userlock.el index 446c326..ff7f344 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -132,31 +132,38 @@ to get the latest version of the file, then make the change again.") ;;; 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 @@ -164,20 +171,21 @@ to get the latest version of the file, then make the change again.") (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))) @@ -195,6 +203,10 @@ Do you really want to edit the buffer? " fn) ((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 @@ -214,10 +226,7 @@ This function has a choice of three things to do: 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))) @@ -231,10 +240,7 @@ in which case the proposed buffer modification will not be made. 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))) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 4507542..b84901d 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1986,8 +1986,8 @@ If END is omitted, it defaults to the length of LIST." (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. diff --git a/lisp/window-xemacs.el b/lisp/window-xemacs.el index 554ec53..3418047 100644 --- a/lisp/window-xemacs.el +++ b/lisp/window-xemacs.el @@ -191,6 +191,29 @@ Each frame has its own window-config and \"unpop\" stack." ;;;;;;;;;;;;; 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'.") diff --git a/lisp/window.el b/lisp/window.el index 8c4bba4..4687c8a 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -120,13 +120,19 @@ Otherwise, include frames only on the selected device." (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)) + (defun count-windows (&optional minibuf) "Return the number of visible windows. @@ -286,8 +292,7 @@ or if the window is the only window of its frame." (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 @@ -297,7 +302,6 @@ or if the window is the only window of its frame." ;; 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. diff --git a/lisp/x-faces.el b/lisp/x-faces.el index c3e35d7..5dddded 100644 --- a/lisp/x-faces.el +++ b/lisp/x-faces.el @@ -203,7 +203,7 @@ If it fails, it returns nil." "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 diff --git a/lisp/x-font-menu.el b/lisp/x-font-menu.el index 54f4c66..03b4092 100644 --- a/lisp/x-font-menu.el +++ b/lisp/x-font-menu.el @@ -185,6 +185,8 @@ or if you change your font path, you can call this to re-initialize the menus." ;; 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) diff --git a/lisp/x-init.el b/lisp/x-init.el index cfeaf46..0d642cc 100644 --- a/lisp/x-init.el +++ b/lisp/x-init.el @@ -55,7 +55,7 @@ (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 @@ -68,8 +68,8 @@ (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) @@ -311,7 +311,7 @@ (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) diff --git a/lwlib/ChangeLog b/lwlib/ChangeLog index 8731e47..c530488 100644 --- a/lwlib/ChangeLog +++ b/lwlib/ChangeLog @@ -1,3 +1,38 @@ +2000-10-04 Martin Buchholz + + * XEmacs 21.2.36 is released. + +2000-09-19 Martin Buchholz + + * *: Spelling mega-patch + +2000-09-16 Martin Buchholz + + * 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 + + * 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 + + * 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 + + * xlwradioP.h: + Remove duplicate definition of streq(). + 2000-07-19 Martin Buchholz * XEmacs 21.2.35 is released. diff --git a/lwlib/lwlib-Xaw.c b/lwlib/lwlib-Xaw.c index ff8771a..5544c24 100644 --- a/lwlib/lwlib-Xaw.c +++ b/lwlib/lwlib-Xaw.c @@ -179,6 +179,7 @@ xaw_update_one_widget (widget_instance *instance, Widget widget, } #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. */ diff --git a/lwlib/lwlib-Xm.c b/lwlib/lwlib-Xm.c index 410af34..c3580e7 100644 --- a/lwlib/lwlib-Xm.c +++ b/lwlib/lwlib-Xm.c @@ -255,18 +255,18 @@ xm_update_label (widget_instance* instance, Widget widget, widget_value* val) { 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); } } @@ -927,7 +927,7 @@ xm_update_one_value (widget_instance* instance, Widget widget, val->edited = True; } } - else if (class == xmListWidgetClass + else if (class == xmListWidgetClass #if defined (LWLIB_WIDGETS_MOTIF) && XmVERSION > 1 || class == xmComboBoxWidgetClass #endif @@ -1140,7 +1140,7 @@ make_dialog (char* name, Widget parent, Boolean pop_up_p, n_children++; } - /* invisible seperator button */ + /* invisible separator button */ ac = 0; XtSetArg (al[ac], XmNmappedWhenManaged, FALSE); ac++; children [n_children] = XmCreateLabel (row, "separator_button", @@ -1256,7 +1256,7 @@ make_dialog (char* name, Widget parent, Boolean pop_up_p, 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); } diff --git a/lwlib/lwlib-internal.h b/lwlib/lwlib-internal.h index 5ec3bc9..85dff5a 100644 --- a/lwlib/lwlib-internal.h +++ b/lwlib/lwlib-internal.h @@ -44,7 +44,7 @@ typedef struct _widget_creation_entry } 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); diff --git a/lwlib/lwlib.c b/lwlib/lwlib.c index bf9bd3a..bd6e900 100644 --- a/lwlib/lwlib.c +++ b/lwlib/lwlib.c @@ -272,7 +272,7 @@ merge_widget_value_args (widget_value *old, widget_value *new) /* 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; @@ -824,13 +824,28 @@ initialize_widget_instance (widget_instance *instance) 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; } @@ -1431,3 +1446,24 @@ void lw_copy_widget_value_args (widget_value* val, widget_value* copy) } } +/* 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'; +} diff --git a/lwlib/lwlib.h b/lwlib/lwlib.h index 458e499..76d3241 100644 --- a/lwlib/lwlib.h +++ b/lwlib/lwlib.h @@ -212,6 +212,7 @@ void lw_pop_down_all_widgets (LWLIB_ID id); 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 *); @@ -226,4 +227,6 @@ void lw_set_keyboard_focus (Widget parent, Widget w); /* 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_ */ diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index b903917..5fadadf 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -51,7 +51,7 @@ Boston, MA 02111-1307, USA. */ #include #endif -/* simple, naieve integer maximum */ +/* simple, naive integer maximum */ #ifndef max #define max(a,b) ((a)>(b)?(a):(b)) #endif @@ -88,6 +88,8 @@ xlwMenuResources[] = {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 @@ -688,7 +690,7 @@ resource_widget_value (XlwMenuWidget mw, widget_value *val) /* 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, @@ -1519,7 +1521,7 @@ menu_item_type (widget_value *val) else return TEXT_TYPE; #else - else + else abort(); return UNSPECIFIED_TYPE; /* Not reached */ #endif @@ -2491,7 +2493,7 @@ remap_menubar (XlwMenuWidget mw) 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, @@ -3017,10 +3019,12 @@ XlwMenuInitialize (Widget request, Widget new, ArgList args, 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!!! diff --git a/man/ChangeLog b/man/ChangeLog index 8e69333..959ddd5 100644 --- a/man/ChangeLog +++ b/man/ChangeLog @@ -1,3 +1,61 @@ +2000-10-04 Martin Buchholz + + * XEmacs 21.2.36 is released. + +2000-09-27 Martin Buchholz + + * lispref/processes.texi (Signals to Processes): Many corrections. + +2000-09-20 Martin Buchholz + + * xemacs/startup.texi (Startup Paths): Minor fixes. + +2000-09-19 Martin Buchholz + + * *: Spelling mega-patch + +2000-09-16 Martin Buchholz + + * internals/internals.texi (Low-Level Modules): + Correct the list of source files. + +2000-08-24 Adrian Aichner + + * emodules.texi (Introduction): Trivial typo fix. + +2000-08-24 Martin Buchholz + + * emodules.texi (Initialization Mode): Spell-Check. + +2000-08-24 Martin Buchholz + + * lispref/databases.texi (Connecting to a Database): + s/berkeley_db/berkeley-db/. Too much C programming. + +2000-08-02 Stephen J. Turnbull + + * xemacs/custom.texi (Menubar Resources): Document FontSet resource. + +2000-07-30 Ben Wing + + * 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 + + * lispref\searching.texi (Syntax of Regexps): + Document ??, which we've supported since 20.4. + +2000-07-31 Sandra Wambold + + * xemacs-faq.texi: Minor updates in first two sections + +2000-07-27 Andy Piper + + * lispref/hash-tables.texi: add new hash table type. + 2000-07-19 Martin Buchholz * XEmacs 21.2.35 is released. @@ -846,7 +904,7 @@ * 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. diff --git a/man/emodules.texi b/man/emodules.texi index 5ca73df..415caee 100644 --- a/man/emodules.texi +++ b/man/emodules.texi @@ -117,7 +117,7 @@ This Info file contains v1.0 of the @value{emacs} dynamic loadable module 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 @@ -125,12 +125,12 @@ support documentation. --- The Detailed Node Listing --- -Annatomy of a Module +Anatomy of a Module * Required Header File:: Always include * 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} @@ -148,7 +148,7 @@ Defining Functions @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 @@ -161,12 +161,12 @@ ways than you can imagine, it does have its short-comings. 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. @@ -175,8 +175,8 @@ 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}. @@ -199,7 +199,7 @@ specific characteristics from the developer. This program is called to 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}. @@ -207,13 +207,13 @@ 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 @@ -245,17 +245,17 @@ should be considered the final authority. It will also help a great 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. @@ -264,10 +264,10 @@ sample. The source for this sample can be found in the file * Required Header File:: Always include * 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 @@ -275,7 +275,7 @@ sample. The source for this sample can be found in the file @cindex emodules.h @cindex config.h Every module must include the file @file{}. 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 @@ -283,20 +283,20 @@ modules will probably require some pre-processor conditionals based on 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 }, you will get a few of the most important +you @code{#include }, 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. @@ -317,15 +317,15 @@ Provides the required structure, macro and function definitions for 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. @@ -339,7 +339,7 @@ place-holder, not an actual function name. @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. @@ -355,7 +355,7 @@ all internal @value{emacs} source code. @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. @@ -368,7 +368,7 @@ initialization code is produced. It is required to document all 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 @@ -376,7 +376,7 @@ functions and variables declared in your module. 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 @@ -388,7 +388,7 @@ This is a variable of type @code{long}, and is used to indicate the 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 @@ -397,11 +397,11 @@ changes in the module loading technology, not versions of @value{emacs}. @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. @@ -423,9 +423,9 @@ and does not affect the loading of the module. The value is set by the @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 @@ -433,7 +433,7 @@ During the loading of a module, it is the responsibility of the function @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 @@ -444,18 +444,18 @@ int emodules_load (const char *module, @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. @@ -465,13 +465,13 @@ to load, and is compared to the target module's 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 @@ -494,7 +494,7 @@ variable @code{CC} to @code{ellcc} and your code will be compiled as 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 @@ -513,7 +513,7 @@ debugging messages to be displayed on the standard output. @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}. @@ -526,7 +526,7 @@ then invoke the C compiler to compile your module, and will return the 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 @@ -554,14 +554,14 @@ functions. Rather than have the documentation for compiled functions 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}. @@ -569,8 +569,8 @@ 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}. @@ -602,8 +602,8 @@ This string should be brief, as it has to be formatted to fit the 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. @@ -656,17 +656,17 @@ way as the main module directory. Each sub-directory within it is 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. @@ -686,7 +686,7 @@ sure you invoke it correctly in the @file{Makefile}. See the sample 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. @@ -700,16 +700,16 @@ Enabled link edit mode. Use this to create the final module. @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. @@ -729,7 +729,7 @@ created to @var{FILENAME}. During link mode, it sets the name of the 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. @@ -737,11 +737,11 @@ 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 @@ -751,10 +751,10 @@ were compiled. 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 @@ -802,17 +802,17 @@ Used during the compile phase of @value{emacs} itself. 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 @@ -826,7 +826,7 @@ macro @code{CDOCSUBR} is used for, and this is used extensively during 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}. @@ -843,7 +843,7 @@ for this to happen. It is all taken care of in the @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 @@ -854,7 +854,7 @@ example: 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)) @{ @@ -871,9 +871,9 @@ The specified FILE is frobricated before it is fnozzled. @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 @@ -891,7 +891,7 @@ function argument names, if any. @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 @@ -933,25 +933,25 @@ internals manual for more details. 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 diff --git a/man/info.texi b/man/info.texi index bd827ee..6a12f76 100644 --- a/man/info.texi +++ b/man/info.texi @@ -3,7 +3,7 @@ @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 @@ -853,7 +853,7 @@ node of the file with Emacs Info mode. @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 diff --git a/man/internals/internals.texi b/man/internals/internals.texi index 499bc58..5b8d38e 100644 --- a/man/internals/internals.texi +++ b/man/internals/internals.texi @@ -1218,7 +1218,7 @@ name as the value of the Lisp variable @code{top-level}. 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. @@ -2910,7 +2910,7 @@ chosen by @file{configure}. @example -crt0.c +ecrt0.c lastfile.c pre-crt0.c @end example @@ -3045,14 +3045,6 @@ provided by the @samp{--error-check-*} configuration options. @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 @@ -3064,7 +3056,6 @@ This is not currently used. @section Basic Lisp Modules @example -emacsfns.h lisp-disunion.h lisp-union.h lisp.h @@ -3410,8 +3401,12 @@ Most of this could be implemented in Lisp. @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 @@ -3466,10 +3461,10 @@ relevant keymaps.) @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}. @@ -3507,13 +3502,31 @@ code is loaded). @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 @@ -3534,10 +3547,9 @@ subtypes (X, TTY, NeXTstep, Microsoft Windows, etc.) as devices do. @example -frame-ns.h +frame-msw.c frame-tty.c frame-x.c -frame-x.h frame.c frame.h @end example @@ -3589,7 +3601,10 @@ faces.h @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 @@ -3599,7 +3614,8 @@ glyphs.h @example -objects-ns.h +objects-msw.c +objects-msw.h objects-tty.c objects-tty.h objects-x.c @@ -3611,13 +3627,18 @@ objects.h @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 @@ -3627,6 +3648,7 @@ scrollbar.h @example +toolbar-msw.c toolbar-x.c toolbar.c toolbar.h @@ -3653,6 +3675,7 @@ gifalloc.c @end example These modules decode GIF-format image files, for use with glyphs. +These files were removed due to Unisys patent infringement concerns. @@ -3661,6 +3684,7 @@ These modules decode GIF-format image files, for use with glyphs. @example redisplay-output.c +redisplay-msw.c redisplay-tty.c redisplay-x.c redisplay.c @@ -3755,7 +3779,7 @@ streams and C++ I/O streams. 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}. @@ -4220,16 +4244,6 @@ AIX prior to 4.1. -@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 @@ -4297,7 +4311,10 @@ needs to be rewritten. @example -xselect.c +select-msw.c +select-x.c +select.c +select.h @end example @cindex selections @@ -4380,8 +4397,8 @@ mule-canna.c 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 @@ -4393,13 +4410,13 @@ actually provides a general interface for all sorts of languages, not 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, @@ -5355,6 +5372,15 @@ included by @file{inline.c}. 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 @@ -8748,7 +8774,7 @@ from its corresponding widget_instance by walking the widget_instance 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 diff --git a/man/lispref/buffers.texi b/man/lispref/buffers.texi index 24008a5..cc95f52 100644 --- a/man/lispref/buffers.texi +++ b/man/lispref/buffers.texi @@ -46,7 +46,7 @@ not be displayed in any windows. 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}. diff --git a/man/lispref/consoles-devices.texi b/man/lispref/consoles-devices.texi index def33d0..67f5f07 100644 --- a/man/lispref/consoles-devices.texi +++ b/man/lispref/consoles-devices.texi @@ -152,12 +152,12 @@ is a symbol whose name is one of the device classes mentioned above. @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 diff --git a/man/lispref/databases.texi b/man/lispref/databases.texi index fdc5c74..b3106e3 100644 --- a/man/lispref/databases.texi +++ b/man/lispref/databases.texi @@ -26,16 +26,16 @@ This function opens database @var{file}, using database method 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 diff --git a/man/lispref/hash-tables.texi b/man/lispref/hash-tables.texi index 6d0b646..5702072 100644 --- a/man/lispref/hash-tables.texi +++ b/man/lispref/hash-tables.texi @@ -89,15 +89,17 @@ the factor by which to increase the size of the hash table when enlarging. 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 @@ -110,6 +112,12 @@ that a key-value pair will be removed only if the value remains 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 @@ -204,18 +212,22 @@ remaining around forever, long past their actual period of use. (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}. diff --git a/man/lispref/loading.texi b/man/lispref/loading.texi index 18bc574..e533588 100644 --- a/man/lispref/loading.texi +++ b/man/lispref/loading.texi @@ -673,7 +673,7 @@ reclaim memory for other Lisp objects. To do this, use the function 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.) diff --git a/man/lispref/minibuf.texi b/man/lispref/minibuf.texi index 23508f7..ac8b10d 100644 --- a/man/lispref/minibuf.texi +++ b/man/lispref/minibuf.texi @@ -852,7 +852,7 @@ Buffer name? (default foo) @point{} @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 diff --git a/man/lispref/mule.texi b/man/lispref/mule.texi index d46ab25..d227bcc 100644 --- a/man/lispref/mule.texi +++ b/man/lispref/mule.texi @@ -192,7 +192,7 @@ encoded by doing the same but also prefixing the character with the 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 diff --git a/man/lispref/processes.texi b/man/lispref/processes.texi index fbc71b6..f664474 100644 --- a/man/lispref/processes.texi +++ b/man/lispref/processes.texi @@ -1,6 +1,6 @@ @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 @@ -92,7 +92,7 @@ intermixed randomly. 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 @@ -106,7 +106,7 @@ must use @var{args} to provide those. 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 @@ -296,8 +296,8 @@ inputinput@point{} @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}.} @@ -704,25 +704,26 @@ defined. XEmacs can send signals only to its own subprocesses. 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 @@ -730,30 +731,39 @@ support the distinction in the case of pipes. For the same reason, 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. @@ -763,17 +773,16 @@ non-@code{nil}, you can think of this function as ``typing @kbd{C-z}'' 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 @@ -1096,7 +1105,7 @@ of event. The string describing the event looks like one of the following: @itemize @bullet -@item +@item @code{"finished\n"}. @item diff --git a/man/lispref/searching.texi b/man/lispref/searching.texi index db7eadc..2436514 100644 --- a/man/lispref/searching.texi +++ b/man/lispref/searching.texi @@ -273,17 +273,21 @@ 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 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. @@ -293,6 +297,9 @@ 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 @@ -462,8 +469,9 @@ is called a @dfn{shy} grouping operator, and it is used just like 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, @@ -472,7 +480,7 @@ 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'. ... 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. diff --git a/man/lispref/windows.texi b/man/lispref/windows.texi index 45ca496..287184b 100644 --- a/man/lispref/windows.texi +++ b/man/lispref/windows.texi @@ -1041,7 +1041,7 @@ position of point in that buffer. @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 diff --git a/man/xemacs-faq.texi b/man/xemacs-faq.texi index 5c9cd6f..7014895 100644 --- a/man/xemacs-faq.texi +++ b/man/xemacs-faq.texi @@ -7,7 +7,7 @@ @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 @author Ben Wing @@ -32,23 +32,17 @@ 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 @@ -104,7 +98,7 @@ Introduction, Policy, Credits * 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)? @@ -124,12 +118,12 @@ Credits: * 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: @@ -351,7 +345,7 @@ Emacs Lisp Programming Techniques: * 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! @@ -452,7 +446,7 @@ Introduction: * 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)? @@ -472,12 +466,12 @@ Credits: * 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: @@ -503,10 +497,10 @@ track changes to GNU Emacs while also working to add new features. @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. @@ -631,7 +625,7 @@ xemacs-request address. Send a message with a subject of @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} @@ -722,8 +716,7 @@ Pre-printed manuals are not available. If you are familiar with 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 @@ -738,12 +731,11 @@ maintainers}. 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? @@ -913,80 +905,16 @@ crash some time ago. @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 @@ -1005,7 +933,7 @@ See question 3.5.7 (@pxref{Q3.5.7}) in part 3 of this FAQ. 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 @@ -1018,7 +946,7 @@ The name of the resource is derived from the non-localized entry by 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: @@ -1069,7 +997,7 @@ it will be continued. @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: @@ -1315,8 +1243,8 @@ Trouble Shooting: @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 @@ -1337,98 +1265,13 @@ This will let you run XEmacs without massive copying. @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 @@ -1436,81 +1279,24 @@ you don't use. @emph{Nothing bad will happen if you delete a 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. @@ -1567,9 +1353,8 @@ bad pointer, perhaps to a CD-ROM that is not inserted. @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? @@ -4871,7 +4656,7 @@ Emacs Lisp Programming Techniques: * 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! @@ -5521,7 +5306,7 @@ While compiling toplevel forms: @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: diff --git a/man/xemacs/custom.texi b/man/xemacs/custom.texi index 71d0aa5..5be3610 100644 --- a/man/xemacs/custom.texi +++ b/man/xemacs/custom.texi @@ -749,7 +749,7 @@ long file that contains no page markers and has no local variables list. 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. @@ -2493,13 +2493,27 @@ proper, it does not use the face mechanism for specifying fonts and 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 diff --git a/man/xemacs/glossary.texi b/man/xemacs/glossary.texi index cc748b6..83281b3 100644 --- a/man/xemacs/glossary.texi +++ b/man/xemacs/glossary.texi @@ -261,7 +261,7 @@ echo area, accompanied by a beep. 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 @@ -621,7 +621,7 @@ Emacs, you have to save it. @xref{Saving}. @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 @@ -682,7 +682,7 @@ definitions in one or more other files. @xref{Tags}. 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 @@ -749,7 +749,7 @@ display the contents of one buffer (q.v.@:) at any time. @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'. diff --git a/man/xemacs/help.texi b/man/xemacs/help.texi index 3d6f187..a6c62f6 100644 --- a/man/xemacs/help.texi +++ b/man/xemacs/help.texi @@ -441,7 +441,7 @@ full details on the complete absence of warranty for XEmacs. @kbd{C-h 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 diff --git a/man/xemacs/mule.texi b/man/xemacs/mule.texi index 66cb453..1eaa18b 100644 --- a/man/xemacs/mule.texi +++ b/man/xemacs/mule.texi @@ -19,7 +19,7 @@ world scripts, including Latin script, as well as Arabic script, 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''). diff --git a/man/xemacs/search.texi b/man/xemacs/search.texi index ab72126..ea892d0 100644 --- a/man/xemacs/search.texi +++ b/man/xemacs/search.texi @@ -77,7 +77,7 @@ only if the next command you want to type is a printing character, 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}. @@ -330,12 +330,30 @@ is the traditional Emacs sequence of keys for word search. @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} @@ -344,7 +362,7 @@ incrementally just like @kbd{C-s}, but it treats the search string as a 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. @@ -358,151 +376,227 @@ incremental regexp and non-regexp searches have independent defaults. @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} @@ -515,6 +609,9 @@ surrounding @samp{\( @dots{} \)} grouping can limit the grouping power of 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 @@ -523,78 +620,126 @@ To enclose a set of @samp{\|} alternatives for other operations. 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 diff --git a/man/xemacs/startup.texi b/man/xemacs/startup.texi index 65bc279..f7bd171 100644 --- a/man/xemacs/startup.texi +++ b/man/xemacs/startup.texi @@ -39,7 +39,7 @@ hierarchy is called a @dfn{root}. @cindex root of a hierarchy Whenever this section refers to a directory using the shorthand @code{}, 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 @@ -85,12 +85,12 @@ It is possible to specify at configure-time the location of the various 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 diff --git a/modules/sample/sample.c b/modules/sample/sample.c index 1f519fc..1c43811 100644 --- a/modules/sample/sample.c +++ b/modules/sample/sample.c @@ -31,9 +31,9 @@ version of Emacs. /* * 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. * @@ -60,8 +60,8 @@ modules_of_sample() { /* * 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"); */ } diff --git a/nt/ChangeLog b/nt/ChangeLog index 0d92960..d91476c 100644 --- a/nt/ChangeLog +++ b/nt/ChangeLog @@ -1,3 +1,52 @@ +2000-10-04 Martin Buchholz + + * XEmacs 21.2.36 is released. + +2000-09-30 Martin Buchholz + + * config.h (HAVE_STRCASECMP): Remove. + +2000-09-07 Jonathan Harris + + * 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 + + * xemacs.mak: add getloadavg.c. + +2000-07-30 Ben Wing + + * README (NOTE): + Improve X documentation. + Document nascent Mule support. + Document current MS Windows contributors. + +2000-07-15 Ben Wing + + * 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 + + * xemacs.mak ($(PROGNAME)): Do check error code from temacs during + dumping. + 2000-07-19 Martin Buchholz * XEmacs 21.2.35 is released. diff --git a/nt/PROBLEMS b/nt/PROBLEMS index 899d0e3..6a345fb 100644 --- a/nt/PROBLEMS +++ b/nt/PROBLEMS @@ -99,11 +99,11 @@ example, to bind C-z to undo: 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. diff --git a/nt/README b/nt/README index 62ad352..dba6c22 100644 --- a/nt/README +++ b/nt/README @@ -1,13 +1,17 @@ -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 ============================ @@ -20,31 +24,42 @@ of GNU Emacs, see http://www.cs.washington.edu/homes/voelker/ntemacs.html. 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". @@ -56,12 +71,34 @@ of GNU Emacs, see http://www.cs.washington.edu/homes/voelker/ntemacs.html. ** 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 @@ -121,6 +158,15 @@ If you want support for X you will also need: 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: @@ -182,7 +228,7 @@ If you want support for X you will also need: (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 @@ -198,14 +244,15 @@ If you want support for X you will also need: 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: @@ -255,10 +302,17 @@ assistance we can: 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. diff --git a/nt/config.h b/nt/config.h index 718e0c7..34ac06b 100644 --- a/nt/config.h +++ b/nt/config.h @@ -257,7 +257,6 @@ Boston, MA 02111-1307, USA. */ #undef HAVE_SIGHOLD #undef HAVE_SIGPROCMASK #undef HAVE_SIGSETJMP -#undef HAVE_STRCASECMP #define HAVE_STRERROR #undef HAVE_TZSET #undef HAVE_UTIMES @@ -499,7 +498,7 @@ Boston, MA 02111-1307, USA. */ /* 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 diff --git a/nt/xemacs.mak b/nt/xemacs.mak index bc7c917..b0ffd19 100644 --- a/nt/xemacs.mak +++ b/nt/xemacs.mak @@ -1,6 +1,6 @@ # 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. # @@ -300,7 +300,7 @@ DEPEND=0 # #### 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] @@ -630,7 +630,6 @@ DOC=$(LIB_SRC)\DOC DOC_SRC1=\ $(SRC)\abbrev.c \ $(SRC)\alloc.c \ - $(SRC)\alloca.c \ $(SRC)\blocktype.c \ $(SRC)\buffer.c \ $(SRC)\bytecode.c \ @@ -668,6 +667,7 @@ DOC_SRC3=\ $(SRC)\font-lock.c \ $(SRC)\frame.c \ $(SRC)\general.c \ + $(SRC)\getloadavg.c \ $(SRC)\glyphs.c \ $(SRC)\glyphs-eimage.c \ $(SRC)\glyphs-widget.c \ @@ -717,6 +717,7 @@ DOC_SRC5=\ $(SRC)\tparam.c \ $(SRC)\undo.c \ $(SRC)\window.c \ + $(SRC)\win32.c \ $(SRC)\widget.c !if $(HAVE_X_WINDOWS) @@ -917,7 +918,6 @@ TEMACS_OBJS= \ $(TEMACS_DUMP_OBJS)\ $(OUTDIR)\abbrev.obj \ $(OUTDIR)\alloc.obj \ - $(OUTDIR)\alloca.obj \ $(OUTDIR)\blocktype.obj \ $(OUTDIR)\buffer.obj \ $(OUTDIR)\bytecode.obj \ @@ -953,6 +953,7 @@ TEMACS_OBJS= \ $(OUTDIR)\font-lock.obj \ $(OUTDIR)\frame.obj \ $(OUTDIR)\general.obj \ + $(OUTDIR)\getloadavg.obj \ $(OUTDIR)\glyphs.obj \ $(OUTDIR)\glyphs-eimage.obj \ $(OUTDIR)\glyphs-widget.obj \ @@ -999,7 +1000,8 @@ TEMACS_OBJS= \ $(OUTDIR)\tparam.obj \ $(OUTDIR)\undo.obj \ $(OUTDIR)\widget.obj \ - $(OUTDIR)\window.obj + $(OUTDIR)\window.obj \ + $(OUTDIR)\win32.obj # Rules @@ -1290,11 +1292,11 @@ makeinfo-test: 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 < * 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 @@ -3555,7 +3555,7 @@ Tue Feb 17 12:50:37 1998 Andy Piper * 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 @@ -3842,7 +3842,7 @@ Wed Jan 28 13:41:22 1998 Andy Piper 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. @@ -4456,7 +4456,7 @@ Thu Jan 08 09:42:36 1998 Andy Piper * 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. @@ -7648,7 +7648,7 @@ Fri Mar 21 18:54:04 1997 David Moore (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 @@ -7907,7 +7907,7 @@ Sun Feb 16 14:53:58 1997 Steven L Baur * 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 diff --git a/src/Makefile.in.in b/src/Makefile.in.in index ef3d9da..f6e2be0 100644 --- a/src/Makefile.in.in +++ b/src/Makefile.in.in @@ -124,7 +124,7 @@ lwlib_deps = $(lwlib_libs) $(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 @@ -134,12 +134,12 @@ LIBI18N = -li18n 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 @@ -193,9 +193,9 @@ objs=\ 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) @@ -346,7 +346,7 @@ ${DUMP_TARGET}: ${EXE_TARGET} ${libsrc}DOC $(mo_file) ${other_files} update-elc. ./${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) $@ @@ -513,7 +513,7 @@ PURIFY_FLAGS =\ -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) @@ -555,6 +555,10 @@ TransientEmacsShell.c.rtl : ${srcdir}/EmacsShell-sub.c TopLevelEmacsShell.o conf $(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 @@ -703,7 +707,7 @@ xemacs_res.o: ${srcdir}/../nt/xemacs.rc .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 @@ -714,7 +718,7 @@ distclean: clean 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/\#* diff --git a/src/alloca.c b/src/alloca.c index bbbcae6..c1eecff 100644 --- a/src/alloca.c +++ b/src/alloca.c @@ -23,7 +23,7 @@ /* Synched up with: FSF 19.30. */ -/* Authorsip: +/* Authorship: FSF: A long time ago. Very few changes for XEmacs. @@ -193,7 +193,7 @@ alloca (size) 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. */ @@ -204,13 +204,13 @@ alloca (size) 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. */ @@ -228,7 +228,7 @@ alloca (size) /* 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; diff --git a/src/bytecode.c b/src/bytecode.c index b31bc4c..5bbb326 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -471,7 +471,6 @@ Lisp_Object 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); @@ -486,24 +485,26 @@ funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) 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; @@ -2410,8 +2411,7 @@ syms_of_bytecode (void) { 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"); diff --git a/src/callproc.c b/src/callproc.c index 59baf47..b908a3a 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -361,10 +361,12 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you 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)); } @@ -427,8 +429,10 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you #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 @@ -865,6 +869,7 @@ When invoked interactively, prints the value in the echo area. char * egetenv (const char *var) { + /* This cannot GC -- 7-28-00 ben */ Bufbyte *value; Bytecount valuelen; diff --git a/src/console-msw.c b/src/console-msw.c index 3cd13ac..0207561 100644 --- a/src/console-msw.c +++ b/src/console-msw.c @@ -182,17 +182,15 @@ mswindows_hide_console (void) 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; @@ -237,6 +235,37 @@ mswindows_windows9x_p (void) 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 @@ -446,10 +475,7 @@ no effect. */ Extbyte *titleout = 0; UINT sty = 0; - if (noninteractive) - return Qcancel; - - if (!CONSP (flags)) + if (!LISTP (flags)) { CHECK_SYMBOL (flags); flags = list1 (flags); @@ -547,6 +573,35 @@ mswindows_output_last_error (char *frob) 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); +} + /************************************************************************/ /* initialization */ @@ -555,6 +610,8 @@ mswindows_output_last_error (char *frob) void syms_of_console_mswindows (void) { + DEFSUBR (Fmswindows_debugging_output); + defsymbol (&Qabortretryignore, "abortretryignore"); defsymbol (&Qapplmodal, "applmodal"); defsymbol (&Qdefault_desktop_only, "default-desktop-only"); @@ -609,6 +666,8 @@ console_type_create_mswindows (void) /* 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 diff --git a/src/console-msw.h b/src/console-msw.h index a2eaca5..ad6cca5 100644 --- a/src/console-msw.h +++ b/src/console-msw.h @@ -65,12 +65,12 @@ DECLARE_CONSOLE_TYPE (msprinter); 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 @@ -101,7 +101,7 @@ struct mswindows_device 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 */ }; @@ -178,6 +178,9 @@ struct mswindows_frame /* 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 @@ -210,9 +213,10 @@ struct mswindows_frame 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; }; @@ -236,6 +240,7 @@ struct mswindows_frame #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)) @@ -255,7 +260,7 @@ struct msprinter_frame { 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; @@ -296,11 +301,12 @@ LRESULT WINAPI mswindows_control_wnd_proc (HWND hwnd, 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" @@ -364,7 +370,36 @@ Lisp_Object mswindows_handle_gui_wm_command (struct frame* f, 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_ */ diff --git a/src/console-tty.c b/src/console-tty.c index 34bd768..56cd325 100644 --- a/src/console-tty.c +++ b/src/console-tty.c @@ -130,8 +130,8 @@ tty_init_console (struct console *con, Lisp_Object props) 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 diff --git a/src/console-x.c b/src/console-x.c index 7a45d9d..dcc7407 100644 --- a/src/console-x.c +++ b/src/console-x.c @@ -20,6 +20,8 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ +/* This file Mule-ized by Ben Wing, 7-10-00. */ + /* Authorship: Ben Wing: January 1996, for 19.14. @@ -29,6 +31,7 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "console-x.h" +#include "buffer.h" #include "process.h" /* canonicalize_host_name */ #include "redisplay.h" /* for display_arg */ @@ -44,7 +47,7 @@ static void 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) @@ -54,12 +57,11 @@ split_up_display_spec (Lisp_Object display, int *hostname_length, } 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; } @@ -102,7 +104,7 @@ x_device_to_console_connection (Lisp_Object connection, Error_behavior errb) 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 @@ -114,7 +116,7 @@ get_display_arg_connection (void) { int elt; int argc; - char **argv; + Extbyte **argv; Lisp_Object conn; make_argc_argv (Vx_initial_argv_list, &argc, &argv); @@ -127,7 +129,8 @@ get_display_arg_connection (void) 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 { @@ -140,12 +143,12 @@ get_display_arg_connection (void) /* 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 @@ -181,8 +184,7 @@ x_semi_canonicalize_console_connection (Lisp_Object connection, /* 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)); @@ -260,7 +262,7 @@ x_canonicalize_device_connection (Lisp_Object connection, Error_behavior errb) 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); diff --git a/src/device-msw.c b/src/device-msw.c index 2d822a6..6e63f9a 100644 --- a/src/device-msw.c +++ b/src/device-msw.c @@ -40,12 +40,10 @@ Boston, MA 02111-1307, USA. */ #include "frame.h" #include "sysdep.h" -/* #### Andy, these includes might break cygwin compilation - kkm*/ #include -#include #if !(defined (CYGWIN) || defined(MINGW)) -# include /* For CoInitialize */ +#include /* For CoInitialize */ #endif /* win32 DDE management library globals */ @@ -60,7 +58,7 @@ HSZ mswindows_dde_item_open; 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; @@ -137,7 +135,7 @@ mswindows_init_device (struct device *d, Lisp_Object props) 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 @@ -146,9 +144,16 @@ mswindows_init_device (struct device *d, Lisp_Object props) 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); @@ -157,7 +162,10 @@ mswindows_init_device (struct device *d, Lisp_Object props) 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) @@ -180,7 +188,7 @@ mswindows_finish_init_device (struct device *d, Lisp_Object props) 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, @@ -258,7 +266,7 @@ mswindows_device_system_metrics (struct device *d, #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); @@ -340,7 +348,7 @@ mswindows_device_implementation_flags (void) 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)); } @@ -385,12 +393,31 @@ msprinter_delete_device_internal (struct device *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); +} + /************************************************************************/ /* printer methods */ @@ -421,9 +448,9 @@ msprinter_init_device (struct device *d, Lisp_Object props) 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); @@ -435,7 +462,7 @@ msprinter_init_device (struct device *d, Lisp_Object props) assert (DEVMODE_SIZE (pdm) <= dm_size); - DEVICE_MSPRINTER_DEVMODE(d) = + DEVICE_MSPRINTER_DEVMODE(d) = allocate_devmode (pdm, 0, printer_name, d); } @@ -483,7 +510,7 @@ msprinter_device_system_metrics (struct device *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; @@ -584,7 +611,7 @@ sync_printer_with_devmode (struct device* d, DEVMODE* devmode_in, DEVICE_MSPRINTER_HDC (d) = CreateDC ("WINSPOOL", DEVICE_MSPRINTER_NAME(d), NULL, devmode_out); } - + return 1; } @@ -628,8 +655,8 @@ ensure_not_printing (struct device *d) { 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); } } @@ -640,12 +667,8 @@ decode_devmode (Lisp_Object dev) 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))); } } @@ -707,77 +730,74 @@ print_dialog_worker (Lisp_Object dev, int print_p) } } -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); } @@ -789,70 +809,78 @@ plist_set_margin (Lisp_Object plist, Lisp_Object prop, int margin, int mm_p) 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; + } } } @@ -882,7 +910,7 @@ A settings object can be selected to no more than one printer at a time. 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. */ @@ -900,8 +928,8 @@ 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 @@ -914,15 +942,15 @@ Return value is the previously selected settings object. 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)) @@ -968,7 +996,7 @@ Return value is the currently selected settings object. /* 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 @@ -984,7 +1012,7 @@ Return value is the currently selected settings object. 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); @@ -1033,9 +1061,9 @@ finalize_devmode (void *header, int for_disksave) { 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)); @@ -1131,8 +1159,8 @@ Erase printer-specific settings from a printer 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); dm = ldm->devmode; @@ -1148,6 +1176,90 @@ Erase printer-specific settings from a printer settings object. 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); +} + /************************************************************************/ /* initialization */ @@ -1158,14 +1270,13 @@ syms_of_device_mswindows (void) { 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"); diff --git a/src/device-x.c b/src/device-x.c index cd6c425..a0586b6 100644 --- a/src/device-x.c +++ b/src/device-x.c @@ -21,6 +21,8 @@ Boston, MA 02111-1307, USA. */ /* 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. */ @@ -246,11 +248,11 @@ x_init_device_class (struct device *d) * 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])))) @@ -459,7 +461,7 @@ x_init_device (struct device *d, Lisp_Object props) Display *dpy; Widget app_shell; int argc; - char **argv; + Extbyte **argv; const char *app_class; const char *app_name; const char *disp_name; @@ -549,9 +551,7 @@ x_init_device (struct device *d, Lisp_Object props) 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 @@ -573,9 +573,7 @@ x_init_device (struct device *d, Lisp_Object props) 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) && @@ -595,7 +593,7 @@ x_init_device (struct device *d, Lisp_Object props) 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); @@ -617,9 +615,7 @@ x_init_device (struct device *d, Lisp_Object props) 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)) @@ -627,9 +623,7 @@ x_init_device (struct device *d, Lisp_Object props) } 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)) @@ -785,9 +779,10 @@ x_init_device (struct device *d, Lisp_Object props) #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 */ @@ -1259,6 +1254,22 @@ construct_name_list (Display *display, Widget widget, char *fake_name, #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; @@ -1485,13 +1496,13 @@ mean ``unspecified''. 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, @@ -1687,9 +1698,7 @@ Valid keysyms are listed in the files /usr/include/X11/keysymdef.h and in 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; } @@ -1935,9 +1944,7 @@ See also `x-get-font-path'. 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); diff --git a/src/device.c b/src/device.c index b98df4c..b02ecc3 100644 --- a/src/device.c +++ b/src/device.c @@ -986,7 +986,7 @@ size-icon Icon dimensions. 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. diff --git a/src/device.h b/src/device.h index 2055be8..3395e05 100644 --- a/src/device.h +++ b/src/device.h @@ -220,6 +220,7 @@ struct device 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) diff --git a/src/dialog-msw.c b/src/dialog-msw.c index ff83db4..27fbad7 100644 --- a/src/dialog-msw.c +++ b/src/dialog-msw.c @@ -1,5 +1,6 @@ /* Implements elisp-programmable dialog boxes -- MS Windows interface. Copyright (C) 1998 Kirill M. Katsnelson + Copyright (C) 2000 Ben Wing. This file is part of XEmacs. @@ -33,11 +34,31 @@ Boston, MA 02111-1307, USA. */ #include "gui.h" #include "opaque.h" +#include +#include + +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 @@ -110,6 +131,51 @@ static Lisp_Object Vdialog_data_list; #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) @@ -131,14 +197,27 @@ 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); } @@ -211,13 +290,130 @@ free_dynarr_opaque_ptr (Lisp_Object arg) 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, @@ -226,31 +422,56 @@ mswindows_popup_dialog_box (struct frame* f, Lisp_Object desc) 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) { @@ -280,17 +501,17 @@ mswindows_popup_dialog_box (struct frame* f, Lisp_Object desc) /* 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; @@ -324,9 +545,12 @@ mswindows_popup_dialog_box (struct frame* f, Lisp_Object desc) /* 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); @@ -348,7 +572,7 @@ mswindows_popup_dialog_box (struct frame* f, Lisp_Object desc) 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); @@ -406,45 +630,103 @@ mswindows_popup_dialog_box (struct frame* f, Lisp_Object desc) /* 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 ("*.*"))); } diff --git a/src/dialog-x.c b/src/dialog-x.c index 3d1acc3..3985761 100644 --- a/src/dialog-x.c +++ b/src/dialog-x.c @@ -1,6 +1,7 @@ /* 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. @@ -21,6 +22,8 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ +/* This file Mule-ized by Ben Wing, 7-8-00. */ + #include #include "lisp.h" @@ -40,7 +43,6 @@ Boston, MA 02111-1307, USA. */ 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 (); @@ -49,7 +51,7 @@ maybe_run_dbox_text_callback (LWLIB_ID id) 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) @@ -57,13 +59,14 @@ maybe_run_dbox_text_callback (LWLIB_ID id) 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); } @@ -92,6 +95,9 @@ dbox_selection_callback (Widget widget, LWLIB_ID id, XtPointer client_data) 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 @@ -106,19 +112,14 @@ dbox_selection_callback (Widget widget, LWLIB_ID id, XtPointer client_data) 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; @@ -127,13 +128,33 @@ dbox_descriptor_to_widget_value (Lisp_Object desc) 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 @@ -151,62 +172,69 @@ dbox_descriptor_to_widget_value (Lisp_Object desc) 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 (); @@ -220,14 +248,18 @@ dbox_descriptor_to_widget_value (Lisp_Object desc) } } -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); @@ -257,6 +289,10 @@ x_popup_dialog_box (struct frame* f, Lisp_Object dbox_desc) 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 @@ -267,7 +303,7 @@ syms_of_dialog_x (void) void console_type_create_dialog_x (void) { - CONSOLE_HAS_METHOD (x, popup_dialog_box); + CONSOLE_HAS_METHOD (x, make_dialog_box_internal); } void diff --git a/src/dialog.c b/src/dialog.c index 4ce48a6..b067dcc 100644 --- a/src/dialog.c +++ b/src/dialog.c @@ -1,6 +1,7 @@ /* 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. @@ -23,72 +24,49 @@ Boston, MA 02111-1307, USA. */ #include #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 ] - [ "name" callback "suffix" ] - [ "name" callback : : ... ] - -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; } diff --git a/src/dired-msw.c b/src/dired-msw.c index 1b20fc6..9e4b2b5 100644 --- a/src/dired-msw.c +++ b/src/dired-msw.c @@ -208,9 +208,9 @@ mswindows_get_files (char *dirfile, int nowild, Lisp_Object pattern, /* * 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; diff --git a/src/dired.c b/src/dired.c index 3b2d7ff..474c828 100644 --- a/src/dired.c +++ b/src/dired.c @@ -146,7 +146,7 @@ If FILES-ONLY is the symbol t, then only the "files" in the directory 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; @@ -260,9 +260,9 @@ file_name_completion_stat (Lisp_Object directory, DIRENTRY *dp, 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; } @@ -507,7 +507,8 @@ file_name_completion (Lisp_Object file, Lisp_Object directory, int all_flag, -/* 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, @@ -843,7 +844,7 @@ If file does not exist, returns nil. { 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; diff --git a/src/editfns.c b/src/editfns.c index ca3d41e..1129eb1 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -600,6 +600,12 @@ If BUFFER is nil, the current buffer is assumed. return make_char (BUF_FETCH_CHAR (b, n)); } +#if !defined(WINDOWSNT) && !defined(MSDOS) +#include +#include +#include +#include +#endif DEFUN ("temp-directory", Ftemp_directory, 0, 0, 0, /* Return the pathname to the directory to use for temporary files. @@ -619,7 +625,47 @@ On Unix it is obtained from TMPDIR, with /tmp as the default #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/ 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); @@ -1220,17 +1266,19 @@ and from `file-attributes'. (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 @@ -2513,6 +2561,8 @@ zmacs-activate-region. Setting this to true lets a command be non-intrusive. 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; diff --git a/src/eldap.c b/src/eldap.c index 68b63e7..c26272d 100644 --- a/src/eldap.c +++ b/src/eldap.c @@ -218,77 +218,73 @@ the LDAP library XEmacs was compiled with: `simple', `krbv41' and `krbv42'. 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) { @@ -297,7 +293,7 @@ the LDAP library XEmacs was compiled with: `simple', `krbv41' and `krbv42'. /* 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 ) @@ -477,9 +473,7 @@ entry according to the value of WITHDN. { 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; @@ -638,9 +632,7 @@ containing attribute/value string pairs. 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)) @@ -746,9 +738,7 @@ or `replace'. ATTR is the LDAP attribute type to modify. 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); diff --git a/src/elhash.c b/src/elhash.c index 5e7bd46..36b51de 100644 --- a/src/elhash.c +++ b/src/elhash.c @@ -29,13 +29,13 @@ Boston, MA 02111-1307, USA. */ 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 @@ -277,7 +277,7 @@ hash_table_hash (Lisp_Object hash_table, int depth) `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 @@ -352,10 +352,10 @@ print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 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); } @@ -541,18 +541,19 @@ static int 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); @@ -562,18 +563,19 @@ hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value, 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 */ @@ -806,15 +808,16 @@ the factor by which to increase the size of the hash table when enlarging. 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 @@ -828,7 +831,7 @@ 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-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 @@ -1122,17 +1125,17 @@ beyond which the HASH-TABLE is enlarged by rehashing. 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; } } @@ -1145,11 +1148,11 @@ This can be one of `non-weak', `weak', `key-weak' or `value-weak'. { 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; } } @@ -1484,13 +1487,14 @@ syms_of_elhash (void) 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 */ diff --git a/src/emodules.c b/src/emodules.c index bcd8f01..eb03bc8 100644 --- a/src/emodules.c +++ b/src/emodules.c @@ -73,7 +73,7 @@ modules have been loaded as dynamic shared objects by examining the 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 @@ -114,7 +114,7 @@ Unload a module previously loaded with load-module. 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. */ @@ -209,7 +209,7 @@ find_make_module (const char *mod, const char *name, const char *ver, int mof) 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) @@ -278,7 +278,7 @@ module_load_unwind (Lisp_Object upto) * 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 @@ -288,17 +288,17 @@ module_load_unwind (Lisp_Object upto) * * 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. @@ -386,7 +386,7 @@ emodules_load(const char *module, const char *modname, const char *modver) 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. */ @@ -418,7 +418,7 @@ emodules_load(const char *module, const char *modname, const char *modver) * 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]; @@ -543,7 +543,7 @@ Emacs dynamic loading mechanism version, as a string. 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. */ ); @@ -564,7 +564,7 @@ called by a Lisp function. 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 @@ -573,8 +573,8 @@ value for this variable by looking around in the file-system near the 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. diff --git a/src/emodules.h b/src/emodules.h index 71d5726..15d06e8 100644 --- a/src/emodules.h +++ b/src/emodules.h @@ -60,7 +60,7 @@ extern Lisp_Object Vemacs_minor_version; * 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. */ @@ -69,7 +69,7 @@ extern void emodules_load (const char *module, const char *name, const char *ver /* * 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 diff --git a/src/eval.c b/src/eval.c index ec6a270..d34ba2e 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1,6 +1,7 @@ /* 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. @@ -561,10 +562,13 @@ signal_call_debugger (Lisp_Object conditions, 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; } @@ -593,10 +597,13 @@ signal_call_debugger (Lisp_Object conditions, 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; } @@ -637,7 +644,7 @@ If all args return nil, return nil. (args)) { /* This function can GC */ - REGISTER Lisp_Object arg, val; + REGISTER Lisp_Object val; LIST_LOOP_2 (arg, args) { @@ -656,7 +663,7 @@ If no arg yields nil, return the last arg's value. (args)) { /* This function can GC */ - REGISTER Lisp_Object arg, val = Qt; + REGISTER Lisp_Object val = Qt; LIST_LOOP_2 (arg, args) { @@ -732,7 +739,7 @@ CONDITION's value if non-nil is returned from the cond-form. (args)) { /* This function can GC */ - REGISTER Lisp_Object val, clause; + REGISTER Lisp_Object val; LIST_LOOP_2 (clause, args) { @@ -758,7 +765,7 @@ DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* { /* 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); @@ -784,7 +791,7 @@ whose values are discarded. (args)) { /* This function can GC */ - REGISTER Lisp_Object val, form; + REGISTER Lisp_Object val; struct gcpro gcpro1; val = Feval (XCAR (args)); @@ -809,7 +816,7 @@ whose values are discarded. (args)) { /* This function can GC */ - REGISTER Lisp_Object val, form, tail; + REGISTER Lisp_Object val; struct gcpro gcpro1; Feval (XCAR (args)); @@ -819,8 +826,10 @@ whose values are discarded. GCPRO1 (val); - LIST_LOOP_3 (form, args, tail) - Feval (form); + { + LIST_LOOP_2 (form, args) + Feval (form); + } UNGCPRO; return val; @@ -836,7 +845,6 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST. (args)) { /* This function can GC */ - Lisp_Object var, tail; Lisp_Object varlist = XCAR (args); Lisp_Object body = XCDR (args); int speccount = specpdl_depth(); @@ -877,7 +885,6 @@ All the VALUEFORMs are evalled before any symbols are bound. (args)) { /* This function can GC */ - Lisp_Object var, tail; Lisp_Object varlist = XCAR (args); Lisp_Object body = XCDR (args); int speccount = specpdl_depth(); @@ -897,36 +904,40 @@ All the VALUEFORMs are evalled before any symbols are bound. 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; @@ -1175,10 +1186,10 @@ If FORM is not a macro call, it is returned unchanged. 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. */ @@ -1199,7 +1210,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. { QUIT; sym = def; - tem = Fassq (sym, env); + tem = Fassq (sym, environment); if (NILP (tem)) { def = XSYMBOL (sym)->function; @@ -1208,11 +1219,11 @@ definitions to shadow the loaded ones for use in file byte-compilation. } 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)) @@ -1689,8 +1700,6 @@ Lisp_Object 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)) @@ -1703,7 +1712,6 @@ condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) ; else { - Lisp_Object condition; EXTERNAL_LIST_LOOP_2 (condition, conditions) if (!SYMBOLP (condition)) goto invalid_condition_handler; @@ -2247,6 +2255,267 @@ maybe_signal_continuable_error (Lisp_Object sig, Lisp_Object data, /****************** 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); +} + + +/****************** 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); +} + + +/****************** 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); +} + + +/****************** 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); +} + + +/****************** 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. */ @@ -2322,9 +2591,9 @@ maybe_continuable_error (Lisp_Object class, Error_behavior errb, } -/****************** 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). */ @@ -2365,9 +2634,9 @@ maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob, } -/****************** 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. @@ -2445,9 +2714,9 @@ maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class, } -/****************** 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. */ @@ -2552,6 +2821,55 @@ signal_circular_property_list_error (Lisp_Object list) { 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); +} + /************************************************************************/ /* User commands */ @@ -2996,7 +3314,6 @@ Evaluate FORM and return its value. gcpro1.nvars = 0; { - REGISTER Lisp_Object arg; LIST_LOOP_2 (arg, original_args) { *p++ = Feval (arg); @@ -3026,7 +3343,6 @@ Evaluate FORM and return its value. gcpro1.nvars = 0; { - REGISTER Lisp_Object arg; LIST_LOOP_2 (arg, original_args) { *p++ = Feval (arg); @@ -3058,7 +3374,6 @@ Evaluate FORM and return its value. gcpro1.nvars = 0; { - REGISTER Lisp_Object arg; LIST_LOOP_2 (arg, original_args) { *p++ = Feval (arg); @@ -3103,7 +3418,6 @@ Evaluate FORM and return its value. gcpro1.nvars = 0; { - REGISTER Lisp_Object arg; LIST_LOOP_2 (arg, original_args) { *p++ = Feval (arg); @@ -3336,7 +3650,12 @@ function_argcount (Lisp_Object function, int function_min_args_p) } 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)) @@ -3351,12 +3670,11 @@ function_argcount (Lisp_Object function, int function_min_args_p) 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) { @@ -3495,7 +3813,7 @@ static Lisp_Object 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; @@ -3510,7 +3828,7 @@ funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) { int optional = 0, rest = 0; - EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail) + EXTERNAL_LIST_LOOP_2 (symbol, arglist) { if (!SYMBOLP (symbol)) goto invalid_function; @@ -5097,7 +5415,7 @@ reinit_vars_of_eval (void) 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 diff --git a/src/event-Xt.c b/src/event-Xt.c index b9e83bd..d597719 100644 --- a/src/event-Xt.c +++ b/src/event-Xt.c @@ -87,7 +87,7 @@ XtAppContext Xt_app_con; int x_allow_sendevents; #ifdef DEBUG_XEMACS -int x_debug_events; +int debug_x_events; #endif static int process_events_occurred; @@ -944,7 +944,11 @@ x_to_emacs_keysym (XKeyPressedEvent *event, int simple_p) #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; @@ -982,7 +986,7 @@ x_to_emacs_keysym (XKeyPressedEvent *event, int simple_p) #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) @@ -1143,6 +1147,25 @@ x_event_to_emacs_event (XEvent *x_event, Lisp_Event *emacs_event) 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 @@ -1277,6 +1300,11 @@ x_event_to_emacs_event (XEvent *x_event, Lisp_Event *emacs_event) 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; @@ -1319,6 +1347,11 @@ x_event_to_emacs_event (XEvent *x_event, Lisp_Event *emacs_event) 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; @@ -1507,7 +1540,7 @@ handle_focus_event_1 (struct frame *f, int in_p) 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 @@ -2402,7 +2435,7 @@ describe_event (XEvent *event) break; case Expose: - if (x_debug_events > 1) + if (debug_x_events > 1) { XExposeEvent *ev = &event->xexpose; describe_event_window (ev->window, ev->display); @@ -2415,7 +2448,7 @@ describe_event (XEvent *event) break; case GraphicsExpose: - if (x_debug_events > 1) + if (debug_x_events > 1) { XGraphicsExposeEvent *ev = &event->xgraphicsexpose; describe_event_window (ev->drawable, ev->display); @@ -2432,7 +2465,7 @@ describe_event (XEvent *event) 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); @@ -2453,7 +2486,7 @@ describe_event (XEvent *event) break; case ConfigureNotify: - if (x_debug_events > 1) + if (debug_x_events > 1) { XConfigureEvent *ev = &event->xconfigure; describe_event_window (ev->window, ev->display); @@ -2467,7 +2500,7 @@ describe_event (XEvent *event) break; case VisibilityNotify: - if (x_debug_events > 1) + if (debug_x_events > 1) { XVisibilityEvent *ev = &event->xvisibility; describe_event_window (ev->window, ev->display); @@ -2630,7 +2663,7 @@ emacs_Xt_event_handler (Widget wid /* unused */, Lisp_Object emacs_event = Fmake_event (Qnil, Qnil); #ifdef DEBUG_XEMACS - if (x_debug_events > 0) + if (debug_x_events > 0) { describe_event (event); } @@ -2914,6 +2947,21 @@ emacs_Xt_event_pending_p (int user_p) 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); + } +} + /************************************************************************/ /* replacement for standard string-to-pixel converter */ @@ -3011,9 +3059,9 @@ Boolean EmacsXtCvtStringToPixel ( 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 { @@ -3139,6 +3187,8 @@ reinit_vars_of_event_Xt (void) 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); @@ -3165,14 +3215,14 @@ Beware: allowing emacs to process SendEvents opens a big security hole. 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 } @@ -3215,7 +3265,7 @@ init_event_Xt_late (void) /* called when already initialized */ 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); diff --git a/src/event-msw.c b/src/event-msw.c index 8f8ecf6..2dfb2fe 100644 --- a/src/event-msw.c +++ b/src/event-msw.c @@ -96,7 +96,8 @@ static Lisp_Object mswindows_find_frame (HWND hwnd); 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); @@ -151,7 +152,7 @@ int mswindows_mouse_button_max_skew_y; 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. @@ -161,6 +162,8 @@ static int mswindows_in_modal_loop; /* Count of wound timers */ static int mswindows_pending_timers_count; + +static DWORD mswindows_last_mouse_button_state; /************************************************************************/ /* Pipe instream - reads process output */ @@ -600,7 +603,8 @@ ntpipe_shove_writer (Lstream *stream, const unsigned char *data, size_t size) 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; } @@ -959,7 +963,7 @@ mswindows_enqueue_process_event (Lisp_Process* p) 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); @@ -979,7 +983,7 @@ mswindows_enqueue_mouse_button_event (HWND hwnd, UINT msg, POINTS where, ((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) { @@ -1270,6 +1274,14 @@ mswindows_drain_windows_queue (void) 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 @@ -1279,7 +1291,7 @@ mswindows_drain_windows_queue (void) /* 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) { @@ -1289,7 +1301,7 @@ mswindows_drain_windows_queue (void) 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); @@ -1400,7 +1412,7 @@ mswindows_need_event (int badly_p) { mswindows_drain_windows_queue (); } - else + else { #ifdef HAVE_TTY /* Look for a TTY event */ @@ -1414,7 +1426,7 @@ mswindows_need_event (int badly_p) 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)) { @@ -1433,7 +1445,7 @@ mswindows_need_event (int badly_p) { Lisp_Process *p = get_process_from_usid (FD_TO_USID(i)); - + mswindows_enqueue_process_event (p); } else @@ -1709,7 +1721,7 @@ mswindows_handle_paint (struct frame *frame) } /* - * 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 @@ -1993,7 +2005,7 @@ output_alt_keyboard_state (void) /* asyncstate[2] & 0x1 ? 1 : 0); */ } -#endif /* DEBUG_XEMACS */ +#endif /* DEBUG_XEMACS */ /* @@ -2011,6 +2023,11 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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_) { @@ -2045,14 +2062,14 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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) @@ -2074,7 +2091,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) SetKeyboardState (keymap); } - + if (key_needs_default_processing_p (wParam)) goto defproc; else @@ -2084,7 +2101,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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, @@ -2102,14 +2119,14 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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)); @@ -2130,7 +2147,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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, @@ -2148,7 +2165,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) MSG msg, tranmsg; int potential_accelerator = 0; int got_accelerator = 0; - + msg.hwnd = hwnd; msg.message = message_; msg.wParam = wParam; @@ -2229,7 +2246,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) /* 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); @@ -2251,7 +2268,9 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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: @@ -2269,7 +2288,11 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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 { @@ -2277,10 +2300,14 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) { 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; @@ -2299,7 +2326,11 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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 { @@ -2307,10 +2338,14 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) { 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; @@ -2322,18 +2357,28 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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 @@ -2341,6 +2386,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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; @@ -2353,18 +2399,28 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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 @@ -2372,6 +2428,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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; @@ -2386,13 +2443,19 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) { 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 @@ -2423,7 +2486,8 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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); } @@ -2459,9 +2523,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) { /* 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 } @@ -2493,7 +2555,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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))); @@ -2821,7 +2883,8 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) 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; @@ -2846,7 +2909,7 @@ mswindows_wnd_proc (HWND hwnd, UINT message_, WPARAM wParam, LPARAM lParam) if (CoCreateInstance (&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, &IID_IShellLink, &psl) == S_OK) - { + { IPersistFile* ppf; if (psl->lpVtbl->QueryInterface (psl, &IID_IPersistFile, @@ -2947,8 +3010,10 @@ mswindows_current_layout_has_AltGr (void) 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; @@ -2968,11 +3033,20 @@ mswindows_current_layout_has_AltGr (void) /* 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; @@ -2980,6 +3054,8 @@ mswindows_modifier_state (BYTE* keymap, int has_AltGr) 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; @@ -2991,7 +3067,11 @@ mswindows_modifier_state (BYTE* keymap, int has_AltGr) 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; } @@ -3000,7 +3080,6 @@ mswindows_modifier_state (BYTE* keymap, int has_AltGr) * 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) @@ -3009,6 +3088,7 @@ Lisp_Object mswindows_key_to_emacs_keysym (int mswindows_key, int mods, { 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"); @@ -3020,6 +3100,11 @@ Lisp_Object mswindows_key_to_emacs_keysym (int mswindows_key, int mods, 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 @@ -3031,6 +3116,7 @@ Lisp_Object mswindows_key_to_emacs_keysym (int mswindows_key, int mods, 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"); @@ -3048,11 +3134,6 @@ Lisp_Object mswindows_key_to_emacs_keysym (int mswindows_key, int mods, 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"); @@ -3365,7 +3446,7 @@ emacs_mswindows_quit_p (void) { 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; @@ -3479,6 +3560,12 @@ emacs_mswindows_delete_stream_pair (Lisp_Object instream, : 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. @@ -3533,6 +3620,8 @@ reinit_vars_of_event_mswindows (void) 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 @@ -3555,7 +3644,7 @@ vars_of_event_mswindows (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: @@ -3564,7 +3653,7 @@ 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", diff --git a/src/event-stream.c b/src/event-stream.c index a4d216c..0d09051 100644 --- a/src/event-stream.c +++ b/src/event-stream.c @@ -610,6 +610,14 @@ event_stream_quit_p (void) 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; +} /**********************************************************************/ @@ -767,6 +775,17 @@ maybe_kbd_translate (Lisp_Object event) 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 @@ -2037,7 +2056,12 @@ The next available event will be -- 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. @@ -2352,7 +2376,7 @@ This function is useful for forcing the redisplay of native 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. */ ()) { @@ -2875,10 +2899,8 @@ If sit-for is called from within a process filter function or timer 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) { @@ -4416,6 +4438,23 @@ If FILE is nil, close any open dribble file. } + +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); +} + + /************************************************************************/ /* initialization */ /************************************************************************/ @@ -4429,8 +4468,7 @@ syms_of_event_stream (void) 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); @@ -4453,6 +4491,7 @@ syms_of_event_stream (void) 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"); @@ -4550,7 +4589,7 @@ Normal hook run when XEmacs it about to be idle. 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; @@ -4736,6 +4775,10 @@ Each key-press event is looked up in this table as follows: 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 @@ -4744,6 +4787,16 @@ Each key-press event is looked up in this table as follows: -- 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", diff --git a/src/events-mod.h b/src/events-mod.h index 76644e1..a7e2d6b 100644 --- a/src/events-mod.h +++ b/src/events-mod.h @@ -6,3 +6,8 @@ #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) diff --git a/src/events.c b/src/events.c index e74f3ce..1e5f9db 100644 --- a/src/events.c +++ b/src/events.c @@ -418,7 +418,6 @@ WARNING: the event object returned may be a reused one; see the function */ (type, plist)) { - Lisp_Object tail, keyword, value; Lisp_Object event = Qnil; Lisp_Event *e; EMACS_INT coord_x = 0, coord_y = 0; @@ -449,7 +448,7 @@ WARNING: the event object returned may be a reused one; see the function (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; } @@ -472,7 +471,7 @@ WARNING: the event object returned may be a reused one; see the function 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; @@ -480,164 +479,169 @@ WARNING: the event object returned may be a reused one; see the function 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))) @@ -680,19 +684,25 @@ WARNING: the event object returned may be a reused one; see the function { 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; @@ -1278,6 +1288,7 @@ format_event_object (char *buf, Lisp_Event *event, int brief) 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) @@ -1441,6 +1452,10 @@ empty The event has been allocated but not assigned. 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)) { @@ -1452,6 +1467,28 @@ Return the timestamp of the event object 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)) \ @@ -1509,9 +1546,9 @@ Return the button-number of the given button-press or button-release event. } 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)) { @@ -1535,21 +1572,67 @@ See also the function event-modifiers. } 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 @@ -1584,7 +1667,7 @@ event_x_y_pixel_internal (Lisp_Object event, int *x, int *y, int relative) 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; @@ -2191,6 +2274,7 @@ syms_of_events (void) DEFSUBR (Fevent_properties); DEFSUBR (Fevent_timestamp); + DEFSUBR (Fevent_timestamp_lessp); DEFSUBR (Fevent_key); DEFSUBR (Fevent_button); DEFSUBR (Fevent_modifier_bits); diff --git a/src/events.h b/src/events.h index 7088301..e8fa7f8 100644 --- a/src/events.h +++ b/src/events.h @@ -130,10 +130,9 @@ Boston, MA 02111-1307, USA. */ 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: @@ -176,6 +175,7 @@ Boston, MA 02111-1307, USA. */ 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. @@ -183,12 +183,12 @@ Boston, MA 02111-1307, USA. */ 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 @@ -336,6 +336,7 @@ struct event_stream 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 */ diff --git a/src/extents.c b/src/extents.c index 5fd8ad5..910c0aa 100644 --- a/src/extents.c +++ b/src/extents.c @@ -1,6 +1,6 @@ /* 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. @@ -1599,8 +1599,8 @@ extent_changed_for_redisplay (EXTENT extent, int descendants_too, 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 @@ -1609,7 +1609,7 @@ extent_changed_for_redisplay (EXTENT extent, int descendants_too, 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 @@ -1860,7 +1860,7 @@ extent_in_region_p (EXTENT extent, Bytind from, Bytind to, 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, @@ -1895,7 +1895,7 @@ extent_in_region_p (EXTENT extent, Bytind from, Bytind to, retval = (start <= exs && exs <= end) || (start <= exe && exe <= end); break; default: - abort(); break; + abort(); return 0; } return flags & ME_NEGATE_IN_REGION ? !retval : retval; } @@ -3245,8 +3245,8 @@ decode_extent (Lisp_Object extent_obj, unsigned int flags) 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; @@ -3536,7 +3536,9 @@ See `extent-parent'. 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); @@ -3899,7 +3901,7 @@ decode_map_extents_flags (Lisp_Object flags) 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); } @@ -4237,11 +4239,12 @@ Thus, this function may be used to walk a tree of extents in a buffer: 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 @@ -4262,7 +4265,7 @@ decode_extent_at_flag (Lisp_Object 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 */ } @@ -4284,13 +4287,15 @@ extent_at_mapper (EXTENT e, void *arg) 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 -- @@ -4303,20 +4308,27 @@ extent_at_mapper (EXTENT e, void *arg) 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 @@ -4334,20 +4346,21 @@ extent_at_bytind (Bytind position, Lisp_Object object, Lisp_Object property, : 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, /* @@ -4391,10 +4404,60 @@ you should use `map-extents', which gives you more control. 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); } /* ------------------------------- */ @@ -4999,7 +5062,7 @@ symbol_to_glyph_layout (Lisp_Object layout_obj) 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 */ } @@ -5965,14 +6028,14 @@ get_text_property_bytind (Bytind position, Lisp_Object prop, /* 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))) @@ -6504,7 +6567,8 @@ Used as the `paste-function' property of `text-prop' extents. 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 @@ -6512,8 +6576,9 @@ Used as the `paste-function' property of `text-prop' extents. ** 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! */ @@ -6757,6 +6822,7 @@ syms_of_extents (void) DEFSUBR (Fmap_extents); DEFSUBR (Fmap_extent_children); DEFSUBR (Fextent_at); + DEFSUBR (Fextents_at); DEFSUBR (Fset_extent_initial_redisplay_function); DEFSUBR (Fextent_face); diff --git a/src/fileio.c b/src/fileio.c index e8f7549..49f9262 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -400,7 +400,7 @@ Given a Unix syntax file name, returns a string ending in slash. */ (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; @@ -459,7 +459,7 @@ or the entire name if it contains no slash. */ (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; @@ -495,7 +495,7 @@ get a current directory to run processes in. */ (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, @@ -512,6 +512,7 @@ get a current directory to run processes in. static char * file_name_as_directory (char *out, char *in) { + /* This function cannot GC */ int size = strlen (in); if (size == 0) @@ -544,7 +545,7 @@ except for (file-name-as-directory \"\") => \"./\". */ (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; @@ -571,6 +572,7 @@ except for (file-name-as-directory \"\") => \"./\". 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 "". */ @@ -594,7 +596,7 @@ In Unix-syntax, this function just removes the final slash. */ (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; @@ -706,7 +708,7 @@ be an absolute file name. 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) @@ -740,7 +742,7 @@ See also the function `substitute-in-file-name'. */ (name, default_directory)) { - /* This function can GC */ + /* This function can GC. GC-checked 2000-07-11 ben */ Bufbyte *nm; Bufbyte *newdir, *p, *o; @@ -757,6 +759,10 @@ See also the function `substitute-in-file-name'. #ifdef CYGWIN char *user; #endif + struct gcpro gcpro1, gcpro2; + + /* both of these get set below */ + GCPRO2 (name, default_directory); CHECK_STRING (name); @@ -764,8 +770,11 @@ See also the function `substitute-in-file-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)) @@ -777,7 +786,10 @@ See also the function `substitute-in-file-name'. { 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); @@ -809,13 +821,8 @@ See also the function `substitute-in-file-name'. && ! (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); @@ -918,11 +925,11 @@ See also the function `substitute-in-file-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 */ } } @@ -1236,7 +1243,7 @@ See also the function `substitute-in-file-name'. 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, /* @@ -1249,7 +1256,7 @@ No component of the resulting pathname will be a symbolic link, as */ (filename, default_)) { - /* This function can GC. */ + /* This function can GC. GC checked 2000-07-28 ben. */ Lisp_Object expanded_name; struct gcpro gcpro1; @@ -1257,11 +1264,11 @@ No component of the resulting pathname will be a symbolic link, as 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); @@ -1389,7 +1396,7 @@ If `/~' appears, all of FILENAME through that `/' is discarded. */ (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; @@ -1565,12 +1572,13 @@ If `/~' appears, all of FILENAME through that `/' is discarded. 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 */ @@ -1582,7 +1590,7 @@ If `/~' appears, all of FILENAME through that `/' is discarded. 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; @@ -1611,12 +1619,12 @@ static void 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; @@ -1665,7 +1673,7 @@ A prefix arg makes KEEP-TIME non-nil. */ (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; @@ -1707,8 +1715,10 @@ A prefix arg makes KEEP-TIME non-nil. 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; @@ -1718,7 +1728,7 @@ A prefix arg makes KEEP-TIME non-nil. || 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); @@ -1781,19 +1791,19 @@ A prefix arg makes KEEP-TIME non-nil. 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; @@ -2130,8 +2140,8 @@ Open a network connection to PATH using LOGIN as the login string. /* 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); @@ -2164,17 +2174,17 @@ check_executable (char *filename) { #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 */ } @@ -2185,14 +2195,14 @@ static int 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 } @@ -2202,7 +2212,7 @@ See also `file-readable-p' and `file-attributes'. */ (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; @@ -2219,7 +2229,7 @@ See also `file-readable-p' and `file-attributes'. 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, /* @@ -2229,7 +2239,7 @@ For a directory, this means you can access files in that directory. (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; @@ -2312,7 +2322,7 @@ Return t if file FILENAME can be written or created by you. 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); @@ -2405,7 +2415,7 @@ if the directory so specified exists and really is a directory. 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; } @@ -2478,7 +2488,7 @@ This is the sort of file that holds an ordinary stream of data bytes. 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; } @@ -2507,7 +2517,7 @@ Return mode bits of FILE, as an integer. 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 @@ -2629,12 +2639,12 @@ otherwise, if FILE2 does not exist, the answer is t. 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; @@ -2724,7 +2734,7 @@ positions), even in Mule. (Fixing this is very difficult.) 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: @@ -3111,12 +3121,12 @@ to the value of CODESYS. If this is nil, no code conversion occurs. */ (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); @@ -3125,28 +3135,37 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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); @@ -3154,11 +3173,11 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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); @@ -3177,21 +3196,15 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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. */ @@ -3237,9 +3250,9 @@ to the value of CODESYS. If this is nil, no code conversion occurs. { 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); @@ -3297,7 +3310,6 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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). @@ -3317,7 +3329,7 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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) @@ -3331,9 +3343,11 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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) @@ -3347,9 +3361,10 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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) { @@ -3360,6 +3375,8 @@ to the value of CODESYS. If this is nil, no code conversion occurs. } else if (quietly) { + NUNGCPRO; + UNGCPRO; return Qnil; } @@ -3369,19 +3386,21 @@ to the value of CODESYS. If this is nil, no code conversion occurs. 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; } @@ -3633,7 +3652,7 @@ This means that the file has not been changed since it was visited or saved. */ (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; @@ -3651,7 +3670,7 @@ This means that the file has not been changed since it was visited or saved. 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. */ @@ -3723,7 +3742,7 @@ An argument specifies the modification time value to use 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; } @@ -3764,7 +3783,7 @@ auto_save_1 (Lisp_Object ignored) /* 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 @@ -4149,9 +4168,8 @@ syms_of_fileio (void) 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); diff --git a/src/filelock.c b/src/filelock.c index 44df999..7a645c2 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -123,6 +123,7 @@ fill_in_lock_file_name (Bufbyte *lockfile, Lisp_Object fn) static int lock_file_1 (char *lfname, int force) { + /* Does not GC. */ int err; char *lock_info_str; char *host_name; @@ -160,6 +161,7 @@ lock_file_1 (char *lfname, int force) static int current_lock_owner (lock_info_type *owner, char *lfname) { + /* Does not GC. */ int len, ret; int local_owner = 0; char *at, *dot; @@ -257,6 +259,7 @@ current_lock_owner (lock_info_type *owner, char *lfname) static int lock_if_free (lock_info_type *clasher, char *lfname) { + /* Does not GC. */ if (lock_file_1 (lfname, 0) == 0) { int locker; @@ -298,7 +301,7 @@ lock_if_free (lock_info_type *clasher, char *lfname) 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. */ @@ -325,7 +328,7 @@ lock_file (Lisp_Object fn) 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); } @@ -358,6 +361,7 @@ lock_file (Lisp_Object fn) void unlock_file (Lisp_Object fn) { + /* This can GC */ register char *lfname; struct gcpro gcpro1; diff --git a/src/frame-msw.c b/src/frame-msw.c index 11809e0..9ea792d 100644 --- a/src/frame-msw.c +++ b/src/frame-msw.c @@ -110,7 +110,7 @@ mswindows_init_frame_1 (struct frame *f, Lisp_Object props) /* 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); @@ -136,23 +136,23 @@ mswindows_init_frame_1 (struct frame *f, Lisp_Object props) 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 */ @@ -188,6 +188,7 @@ mswindows_init_frame_1 (struct frame *f, Lisp_Object props) 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); @@ -199,8 +200,8 @@ mswindows_init_frame_1 (struct frame *f, Lisp_Object props) 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, @@ -210,13 +211,19 @@ mswindows_init_frame_1 (struct frame *f, Lisp_Object props) 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 @@ -228,7 +235,7 @@ mswindows_init_frame_2 (struct frame *f, Lisp_Object props) 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); } @@ -240,7 +247,7 @@ mswindows_init_frame_3 (struct frame *f) { /* 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); @@ -254,7 +261,7 @@ mswindows_after_init_frame (struct frame *f, int first_on_device, 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 @@ -287,6 +294,9 @@ mswindows_delete_frame (struct frame *f) { 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); @@ -310,7 +320,7 @@ mswindows_set_frame_size (struct frame *f, int width, int height) 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); } @@ -318,13 +328,13 @@ mswindows_set_frame_size (struct frame *f, int width, int height) 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); @@ -335,7 +345,7 @@ mswindows_make_frame_visible (struct frame *f) } static void -mswindows_make_frame_invisible (struct frame *f) +mswindows_make_frame_invisible (struct frame *f) { if (!FRAME_VISIBLE_P(f)) return; @@ -361,7 +371,7 @@ mswindows_frame_totally_visible_p (struct frame *f) 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)) @@ -404,11 +414,11 @@ mswindows_set_frame_icon (struct frame *f) { 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)); } } @@ -494,7 +504,19 @@ mswindows_lower_frame (struct frame *f) } 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)) @@ -565,7 +587,7 @@ mswindows_set_frame_properties (struct frame *f, Lisp_Object plist) if (STRINGP (val)) { Lisp_Object frm, font_spec; - + XSETFRAME (frm, f); font_spec = Fget (Fget_face (Qdefault), Qfont, Qnil); @@ -602,9 +624,9 @@ mswindows_set_frame_properties (struct frame *f, Lisp_Object plist) /* 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 @@ -628,7 +650,7 @@ void mswindows_size_frame_internal (struct frame* f, XEMACS_RECT_WH* dest) 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) @@ -639,7 +661,7 @@ void mswindows_size_frame_internal (struct frame* f, XEMACS_RECT_WH* dest) 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; @@ -690,11 +712,11 @@ void mswindows_size_frame_internal (struct frame* f, XEMACS_RECT_WH* dest) 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) @@ -734,7 +756,7 @@ mswindows_frame_size_fixed_p (struct frame *f) /*---------------------------------------------------------------------*/ /* - * 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. */ @@ -763,8 +785,8 @@ error_frame_unsizable (struct frame *f) { 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 @@ -780,8 +802,8 @@ msprinter_init_frame_1 (struct frame *f, Lisp_Object props) /* 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); @@ -812,16 +834,16 @@ msprinter_init_frame_3 (struct frame *f) 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 @@ -837,11 +859,11 @@ msprinter_init_frame_3 (struct frame *f) 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 @@ -850,13 +872,16 @@ msprinter_init_frame_3 (struct frame *f) /* 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 */ { @@ -880,7 +905,8 @@ msprinter_init_frame_3 (struct frame *f) 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); @@ -1031,7 +1057,7 @@ console_type_create_frame_mswindows (void) { /* 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); @@ -1041,6 +1067,8 @@ console_type_create_frame_mswindows (void) 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); @@ -1055,8 +1083,8 @@ console_type_create_frame_mswindows (void) 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); @@ -1093,11 +1121,11 @@ vars_of_frame_mswindows (void) 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 @@ -1155,7 +1183,7 @@ set at any time, except as otherwise noted): 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 diff --git a/src/frame-tty.c b/src/frame-tty.c index 6815605..d96d844 100644 --- a/src/frame-tty.c +++ b/src/frame-tty.c @@ -124,7 +124,6 @@ tty_frame_visible_p (struct frame *f) 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); diff --git a/src/frame-x.c b/src/frame-x.c index 9396eee..dbd70cb 100644 --- a/src/frame-x.c +++ b/src/frame-x.c @@ -23,6 +23,8 @@ Boston, MA 02111-1307, USA. */ /* Substantially rewritten for XEmacs. */ +/* 7-8-00 !!#### This file needs definite Mule review. */ + #include #include "lisp.h" @@ -114,7 +116,7 @@ x_any_window_to_frame (struct device *d, Window wdesc) /* 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) */ @@ -662,9 +664,7 @@ x_set_frame_text_value (struct frame *f, Bufbyte *value, { 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; } @@ -766,9 +766,7 @@ x_set_frame_properties (struct frame *f, Lisp_Object plist) 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; @@ -1876,9 +1874,7 @@ x_create_widgets (struct frame *f, Lisp_Object lisp_window_id, #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"; @@ -2490,6 +2486,18 @@ x_lower_frame (struct frame *f) } } +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) @@ -2793,6 +2801,8 @@ console_type_create_frame_x (void) 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); diff --git a/src/frame.h b/src/frame.h index ceae5b0..4ce3d15 100644 --- a/src/frame.h +++ b/src/frame.h @@ -142,6 +142,9 @@ Value : Emacs meaning :f-v-p : X meaning /* 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; @@ -242,6 +245,7 @@ extern Lisp_Object Vmouse_motion_handler; 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) @@ -770,8 +774,8 @@ extern int frame_changed; 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, @@ -807,8 +811,7 @@ void delete_frame_internal (struct frame *f, int force, 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); diff --git a/src/general.c b/src/general.c index a695b7f..3af3fcc 100644 --- a/src/general.c +++ b/src/general.c @@ -1,6 +1,6 @@ /* 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. @@ -21,353 +21,32 @@ Boston, MA 02111-1307, USA. */ /* 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 #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 } diff --git a/src/getloadavg.c b/src/getloadavg.c index 721f32b..4a41be8 100644 --- a/src/getloadavg.c +++ b/src/getloadavg.c @@ -51,7 +51,8 @@ Boston, MA 02111-1307, USA. */ 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. @@ -71,27 +72,6 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "sysfile.h" /* for encapsulated open, close, read, write */ -#ifndef WIN32_NATIVE -#ifndef CYGWIN - -#include - -/* 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 -#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 - #ifndef HAVE_GETLOADAVG /* The existing Emacs configuration files define a macro called @@ -457,11 +437,6 @@ Boston, MA 02111-1307, USA. */ #include #endif /* HAVE_SYS_PSTAT_H (on HPUX) */ -#if defined(HAVE_FCNTL_H) || defined(_POSIX_VERSION) -#include -#else -#include -#endif /* Avoid static vars inside a function since in HPUX they dump as pure. */ @@ -506,6 +481,8 @@ static kvm_t *kd; 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) { @@ -773,7 +750,7 @@ 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. */ @@ -781,7 +758,7 @@ getloadavg (double loadavg[], int nelem) { loadavg[elem] = 0.0; } -#endif /* WIN32_NATIVE */ +#endif /* WIN32_NATIVE or CYGWIN */ #if !defined (LDAV_DONE) && defined (OSF_ALPHA) #define LDAV_DONE @@ -954,22 +931,3 @@ main (int argc, char **argv) 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 */ diff --git a/src/glyphs-msw.c b/src/glyphs-msw.c index 56c6b65..4d4a5f1 100644 --- a/src/glyphs-msw.c +++ b/src/glyphs-msw.c @@ -134,7 +134,7 @@ get_device_compdc (struct device *d) 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); @@ -154,7 +154,7 @@ static void init_image_instance_geometry (Lisp_Image_Instance *ii) 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))) @@ -686,7 +686,7 @@ mswindows_create_resized_mask (Lisp_Image_Instance* ii, } #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, @@ -1019,7 +1019,8 @@ bmp_validate (Lisp_Object instantiator) } 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); } @@ -1086,7 +1087,8 @@ mswindows_resource_validate (Lisp_Object instantiator) } 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; @@ -1315,12 +1317,32 @@ mswindows_resource_instantiate (Lisp_Object image_instance, Lisp_Object instanti 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) @@ -2143,11 +2165,13 @@ mswindows_widget_hfont (Lisp_Image_Instance *p, 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 @@ -2155,6 +2179,7 @@ mswindows_unmap_subwindow (Lisp_Image_Instance *p) { 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; @@ -2175,6 +2200,13 @@ mswindows_unmap_subwindow (Lisp_Image_Instance *p) 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))); } @@ -2186,9 +2218,11 @@ static void 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, @@ -2202,24 +2236,36 @@ mswindows_map_subwindow (Lisp_Image_Instance *p, int x, int y, 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 */ @@ -2237,7 +2283,7 @@ mswindows_resize_subwindow (Lisp_Image_Instance* ii, int w, int h) /* 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), @@ -2247,7 +2293,7 @@ mswindows_update_subwindow (Lisp_Image_Instance *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)) @@ -2265,7 +2311,7 @@ mswindows_update_widget (Lisp_Image_Instance *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)); } @@ -2282,7 +2328,7 @@ mswindows_update_widget (Lisp_Image_Instance *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 @@ -2512,6 +2558,11 @@ mswindows_widget_instantiate (Lisp_Object image_instance, Lisp_Object instantiat 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. */ @@ -2524,15 +2575,15 @@ mswindows_native_layout_instantiate (Lisp_Object image_instance, 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); } @@ -2611,7 +2662,7 @@ mswindows_button_instantiate (Lisp_Object image_instance, Lisp_Object instantiat /* 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); @@ -2645,6 +2696,7 @@ mswindows_progress_gauge_instantiate (Lisp_Object image_instance, Lisp_Object in { 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); @@ -2666,6 +2718,10 @@ mswindows_progress_gauge_instantiate (Lisp_Object image_instance, Lisp_Object in (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 */ @@ -2755,12 +2811,47 @@ mswindows_tree_view_instantiate (Lisp_Object image_instance, Lisp_Object instant } } +/* 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; @@ -2783,8 +2874,8 @@ static TC_ITEM* add_tab_item (Lisp_Object image_instance, 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; @@ -2820,7 +2911,8 @@ mswindows_tab_control_instantiate (Lisp_Object image_instance, Lisp_Object insta /* 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++; @@ -2828,32 +2920,78 @@ mswindows_tab_control_instantiate (Lisp_Object image_instance, Lisp_Object insta 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); } } @@ -2888,8 +3026,7 @@ mswindows_combo_box_instantiate (Lisp_Object image_instance, Lisp_Object instant 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 @@ -2903,7 +3040,7 @@ mswindows_combo_box_instantiate (Lisp_Object image_instance, Lisp_Object instant /* 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; @@ -2919,12 +3056,14 @@ mswindows_combo_box_instantiate (Lisp_Object image_instance, Lisp_Object instant 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), @@ -2988,12 +3127,12 @@ mswindows_combo_box_property (Lisp_Object image_instance, Lisp_Object prop) 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; @@ -3001,10 +3140,10 @@ mswindows_progress_gauge_update (Lisp_Object image_instance) 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), @@ -3054,9 +3193,9 @@ console_type_create_glyphs_mswindows (void) 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); @@ -3118,7 +3257,7 @@ image_instantiator_format_create_glyphs_mswindows (void) 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); @@ -3137,16 +3276,16 @@ image_instantiator_format_create_glyphs_mswindows (void) 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"); diff --git a/src/glyphs-widget.c b/src/glyphs-widget.c index bc3e829..fbba67f 100644 --- a/src/glyphs-widget.c +++ b/src/glyphs-widget.c @@ -58,10 +58,8 @@ Lisp_Object Qlayout; 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; @@ -85,16 +83,14 @@ widget_possible_dest_types (void) } 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 @@ -103,7 +99,7 @@ check_valid_orientation (Lisp_Object data) if (!EQ (data, Qhorizontal) && !EQ (data, Qvertical)) - signal_simple_error ("unknown orientation for layout", data); + invalid_argument ("unknown orientation for layout", data); } static void @@ -116,14 +112,14 @@ check_valid_tab_orientation (Lisp_Object data) !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 @@ -132,7 +128,7 @@ check_valid_border (Lisp_Object data) 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 @@ -147,7 +143,7 @@ check_valid_callback (Lisp_Object data) && !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); } } @@ -155,7 +151,7 @@ static void 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 @@ -168,11 +164,11 @@ 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; @@ -184,32 +180,21 @@ check_valid_item_list_1 (Lisp_Object items) 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)); } } @@ -219,26 +204,26 @@ glyph_instantiator_to_glyph (Lisp_Object sym) /* 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; @@ -264,24 +249,24 @@ substitute_keyword_value (Lisp_Object inst, Lisp_Object key, Lisp_Object val) 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)); @@ -289,58 +274,62 @@ widget_property (Lisp_Object image_instance, Lisp_Object 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; @@ -350,17 +339,19 @@ update_widget (Lisp_Object widget) || 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)) @@ -373,8 +364,8 @@ update_widget (Lisp_Object widget) /* 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) { @@ -386,32 +377,32 @@ widget_query_geometry (Lisp_Object image_instance, /* 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), @@ -440,28 +431,31 @@ widget_query_geometry (Lisp_Object image_instance, } } -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; } @@ -472,38 +466,41 @@ widget_validate (Lisp_Object instantiator) 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)); @@ -541,6 +538,9 @@ widget_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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); @@ -549,62 +549,52 @@ widget_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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 @@ -662,9 +652,9 @@ widget_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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; } @@ -673,6 +663,8 @@ widget_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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 @@ -697,7 +689,7 @@ widget_post_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, /* 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) { @@ -723,14 +715,14 @@ button_query_geometry (Lisp_Object image_instance, /* 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. */ @@ -750,14 +742,14 @@ tree_view_query_geometry (Lisp_Object image_instance, /* 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) { @@ -784,48 +776,83 @@ tab_control_query_geometry (Lisp_Object image_instance, } } -/* 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)); @@ -833,44 +860,147 @@ progress_gauge_set_property (Lisp_Object image_instance, 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; } /***************************************************************************** * 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 @@ -880,8 +1010,10 @@ layout_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, { 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); @@ -890,60 +1022,17 @@ layout_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, { 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 @@ -956,30 +1045,30 @@ layout_post_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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 @@ -1011,7 +1100,7 @@ layout_query_geometry (Lisp_Object image_instance, int* width, /* 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) && @@ -1021,19 +1110,20 @@ layout_query_geometry (Lisp_Object image_instance, int* width, /* 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); @@ -1050,7 +1140,7 @@ layout_query_geometry (Lisp_Object image_instance, int* width, 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); @@ -1059,14 +1149,14 @@ layout_query_geometry (Lisp_Object image_instance, int* 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); @@ -1081,8 +1171,9 @@ layout_query_geometry (Lisp_Object image_instance, int* width, } 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; @@ -1100,26 +1191,25 @@ layout_layout (Lisp_Object image_instance, { 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); @@ -1138,12 +1228,12 @@ layout_layout (Lisp_Object image_instance, 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 @@ -1151,13 +1241,13 @@ layout_layout (Lisp_Object image_instance, 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); @@ -1170,33 +1260,33 @@ layout_layout (Lisp_Object image_instance, { 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); @@ -1205,31 +1295,53 @@ layout_layout (Lisp_Object image_instance, { 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)) { @@ -1239,7 +1351,7 @@ native_layout_layout (Lisp_Object image_instance, 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); } @@ -1254,47 +1366,38 @@ native_layout_layout (Lisp_Object image_instance, 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) @@ -1302,7 +1405,7 @@ static void image_instantiator_widget (void) { /* 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); } @@ -1318,7 +1421,7 @@ static void image_instantiator_buttons (void) 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); } @@ -1346,9 +1449,10 @@ static void image_instantiator_combo_box (void) 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) @@ -1361,8 +1465,10 @@ 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); } @@ -1374,9 +1480,11 @@ static void image_instantiator_progress_guage (void) 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) @@ -1387,10 +1495,11 @@ 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) @@ -1402,11 +1511,12 @@ 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) @@ -1420,14 +1530,14 @@ 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) { @@ -1439,6 +1549,8 @@ 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); @@ -1455,6 +1567,7 @@ static void image_instantiator_native_layout (void) 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); diff --git a/src/glyphs-x.c b/src/glyphs-x.c index af515d8..9ce627b 100644 --- a/src/glyphs-x.c +++ b/src/glyphs-x.c @@ -17,7 +17,6 @@ XEmacs 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. 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, @@ -25,6 +24,8 @@ Boston, MA 02111-1307, USA. */ /* 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 @@ -397,7 +398,7 @@ x_finalize_image_instance (Lisp_Image_Instance *p) 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) ; @@ -1163,9 +1164,7 @@ xbm_instantiate_1 (Lisp_Object image_instance, Lisp_Object instantiator, { 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))), @@ -1189,9 +1188,7 @@ x_xbm_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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)), @@ -1677,9 +1674,7 @@ x_xface_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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, ':'))) { @@ -1743,7 +1738,8 @@ autodetect_validate (Lisp_Object instantiator) 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; @@ -1851,9 +1847,7 @@ autodetect_instantiate (Lisp_Object image_instance, 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); @@ -2053,9 +2047,7 @@ cursor_font_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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); @@ -2155,8 +2147,9 @@ x_map_subwindow (Lisp_Image_Instance *p, int x, int y, 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 */ { @@ -2166,14 +2159,15 @@ x_map_subwindow (Lisp_Image_Instance *p, int x, int y, 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)) @@ -2188,7 +2182,7 @@ x_update_subwindow (Lisp_Image_Instance *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 @@ -2203,19 +2197,23 @@ x_update_widget (Lisp_Image_Instance *p) 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) @@ -2232,9 +2230,7 @@ x_update_widget (Lisp_Image_Instance *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; } @@ -2264,7 +2260,8 @@ x_update_widget (Lisp_Image_Instance *p) /* now modify the widget */ lw_modify_all_widgets (IMAGE_INSTANCE_X_WIDGET_LWID (p), - wv, False); + wv, True); + free_widget_value_tree (wv); #endif } @@ -2394,6 +2391,11 @@ update_widget_face (widget_value* wv, Lisp_Image_Instance *ii, (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 @@ -2410,9 +2412,12 @@ update_tab_widget_face (widget_value* wv, Lisp_Image_Instance *ii, 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); @@ -2449,9 +2454,7 @@ x_widget_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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); @@ -2566,7 +2569,7 @@ x_button_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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)) { @@ -2603,13 +2606,13 @@ x_button_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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), @@ -2643,15 +2646,15 @@ x_progress_gauge_instantiate (Lisp_Object image_instance, Lisp_Object instantiat { 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); @@ -2676,7 +2679,7 @@ x_edit_field_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, { 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); @@ -2697,7 +2700,7 @@ x_combo_box_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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); @@ -2712,21 +2715,76 @@ x_tab_control_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 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) || @@ -2734,16 +2792,21 @@ x_tab_control_update (Lisp_Object image_instance) || 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); } } @@ -2755,7 +2818,7 @@ x_label_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, { 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); @@ -2789,8 +2852,8 @@ console_type_create_glyphs_x (void) 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 @@ -2832,13 +2895,13 @@ image_instantiator_format_create_glyphs_x (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); @@ -2847,12 +2910,12 @@ image_instantiator_format_create_glyphs_x (void) /* 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); diff --git a/src/glyphs-x.h b/src/glyphs-x.h index 791926b..f904a4d 100644 --- a/src/glyphs-x.h +++ b/src/glyphs-x.h @@ -32,6 +32,7 @@ Boston, MA 02111-1307, USA. */ #include "xintrinsic.h" #include "../lwlib/lwlib.h" +#include "../lwlib/lwlib-utils.h" /**************************************************************************** * Image-Instance Object * diff --git a/src/glyphs.h b/src/glyphs.h index a3a9405..e1867af 100644 --- a/src/glyphs.h +++ b/src/glyphs.h @@ -95,6 +95,7 @@ enum image_instance_geometry }; #define IMAGE_UNSPECIFIED_GEOMETRY -1 +#define IMAGE_UNCHANGED_GEOMETRY -2 #define WIDGET_BORDER_HEIGHT 4 #define WIDGET_BORDER_WIDTH 4 @@ -128,7 +129,8 @@ struct image_instantiator_methods 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. */ @@ -163,7 +165,9 @@ struct image_instantiator_methods 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 @@ -176,7 +180,8 @@ struct image_instantiator_methods /* 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 *****/ @@ -269,7 +274,7 @@ IIFORMAT_VALID_GENERIC_KEYWORD(format, keyw, validate_fun, 1, 0) #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) \ @@ -348,7 +353,7 @@ void check_valid_string (Lisp_Object data); 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, @@ -363,10 +368,10 @@ void image_instance_query_geometry (Lisp_Object image_instance, 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); @@ -528,6 +533,8 @@ struct Lisp_Image_Instance /* 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; @@ -537,9 +544,10 @@ struct Lisp_Image_Instance 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 { @@ -565,10 +573,10 @@ struct Lisp_Image_Instance 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 @@ -579,7 +587,7 @@ struct Lisp_Image_Instance 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; @@ -592,6 +600,7 @@ struct Lisp_Image_Instance /* Change flags to augment dirty. */ unsigned int face_changed : 1; unsigned int items_changed : 1; + unsigned int action_occurred : 1; } subwindow; } u; @@ -616,6 +625,7 @@ struct Lisp_Image_Instance #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) @@ -636,6 +646,7 @@ struct Lisp_Image_Instance #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) @@ -644,6 +655,8 @@ struct Lisp_Image_Instance ((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) @@ -694,6 +707,8 @@ struct Lisp_Image_Instance ((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) \ @@ -737,6 +752,8 @@ XCAR (IMAGE_INSTANCE_WIDGET_ITEMS (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) \ @@ -822,6 +839,8 @@ XCAR (IMAGE_INSTANCE_WIDGET_ITEMS (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)) @@ -844,6 +863,8 @@ XCAR (IMAGE_INSTANCE_WIDGET_ITEMS (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); @@ -975,12 +996,22 @@ Lisp_Object alist_to_tagged_vector (Lisp_Object tag, Lisp_Object alist); 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); @@ -1093,13 +1124,15 @@ void unmap_subwindow (Lisp_Object subwindow); 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 { diff --git a/src/gpmevent.c b/src/gpmevent.c index 4c8b809..a3c3d46 100644 --- a/src/gpmevent.c +++ b/src/gpmevent.c @@ -570,7 +570,7 @@ Toggle accepting of GPM mouse events. conn.maxMod = ((1<