diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/.gdbinit | 15 | ||||
-rw-r--r-- | src/ChangeLog.13 | 2 | ||||
-rw-r--r-- | src/ChangeLog.3 | 2 | ||||
-rw-r--r-- | src/Makefile.in | 92 | ||||
-rw-r--r-- | src/alloc.c | 580 | ||||
-rw-r--r-- | src/bidi.c | 10 | ||||
-rw-r--r-- | src/buffer.c | 308 | ||||
-rw-r--r-- | src/buffer.h | 27 | ||||
-rw-r--r-- | src/bytecode.c | 1007 | ||||
-rw-r--r-- | src/callproc.c | 102 | ||||
-rw-r--r-- | src/casefiddle.c | 68 | ||||
-rw-r--r-- | src/ccl.c | 5 | ||||
-rw-r--r-- | src/character.c | 21 | ||||
-rw-r--r-- | src/character.h | 20 | ||||
-rw-r--r-- | src/charset.c | 26 | ||||
-rw-r--r-- | src/chartab.c | 2 | ||||
-rw-r--r-- | src/cm.c | 2 | ||||
-rw-r--r-- | src/coding.c | 187 | ||||
-rw-r--r-- | src/coding.h | 2 | ||||
-rw-r--r-- | src/composite.c | 13 | ||||
-rw-r--r-- | src/conf_post.h | 117 | ||||
-rw-r--r-- | src/cygw32.c | 4 | ||||
-rw-r--r-- | src/data.c | 483 | ||||
-rw-r--r-- | src/dbusbind.c | 126 | ||||
-rw-r--r-- | src/decompress.c | 6 | ||||
-rw-r--r-- | src/dired.c | 33 | ||||
-rw-r--r-- | src/dispextern.h | 70 | ||||
-rw-r--r-- | src/dispnew.c | 13 | ||||
-rw-r--r-- | src/doc.c | 289 | ||||
-rw-r--r-- | src/doprnt.c | 26 | ||||
-rw-r--r-- | src/dynlib.c | 1 | ||||
-rw-r--r-- | src/editfns.c | 258 | ||||
-rw-r--r-- | src/emacs-module.c | 208 | ||||
-rw-r--r-- | src/emacs-module.h | 9 | ||||
-rw-r--r-- | src/emacs.c | 604 | ||||
-rw-r--r-- | src/emacsgtkfixed.c | 2 | ||||
-rw-r--r-- | src/eval.c | 893 | ||||
-rw-r--r-- | src/fileio.c | 303 | ||||
-rw-r--r-- | src/filelock.c | 29 | ||||
-rw-r--r-- | src/firstfile.c | 4 | ||||
-rw-r--r-- | src/fns.c | 290 | ||||
-rw-r--r-- | src/font.c | 64 | ||||
-rw-r--r-- | src/font.h | 52 | ||||
-rw-r--r-- | src/fontset.c | 90 | ||||
-rw-r--r-- | src/frame.c | 329 | ||||
-rw-r--r-- | src/frame.h | 109 | ||||
-rw-r--r-- | src/fringe.c | 7 | ||||
-rw-r--r-- | src/ftcrfont.c | 49 | ||||
-rw-r--r-- | src/ftfont.c | 150 | ||||
-rw-r--r-- | src/ftxfont.c | 73 | ||||
-rw-r--r-- | src/gfilenotify.c | 22 | ||||
-rw-r--r-- | src/gmalloc.c | 234 | ||||
-rw-r--r-- | src/gnutls.c | 518 | ||||
-rw-r--r-- | src/gnutls.h | 9 | ||||
-rw-r--r-- | src/gtkutil.c | 170 | ||||
-rw-r--r-- | src/image.c | 496 | ||||
-rw-r--r-- | src/indent.c | 65 | ||||
-rw-r--r-- | src/inotify.c | 2 | ||||
-rw-r--r-- | src/insdel.c | 137 | ||||
-rw-r--r-- | src/intervals.c | 13 | ||||
-rw-r--r-- | src/intervals.h | 17 | ||||
-rw-r--r-- | src/keyboard.c | 170 | ||||
-rw-r--r-- | src/keyboard.h | 5 | ||||
-rw-r--r-- | src/keymap.c | 17 | ||||
-rw-r--r-- | src/kqueue.c | 26 | ||||
-rw-r--r-- | src/lastfile.c | 7 | ||||
-rw-r--r-- | src/lisp.h | 1259 | ||||
-rw-r--r-- | src/lread.c | 369 | ||||
-rw-r--r-- | src/macfont.m | 73 | ||||
-rw-r--r-- | src/marker.c | 6 | ||||
-rw-r--r-- | src/menu.c | 11 | ||||
-rw-r--r-- | src/minibuf.c | 96 | ||||
-rw-r--r-- | src/msdos.c | 8 | ||||
-rw-r--r-- | src/nsfns.m | 81 | ||||
-rw-r--r-- | src/nsfont.m | 66 | ||||
-rw-r--r-- | src/nsimage.m | 4 | ||||
-rw-r--r-- | src/nsmenu.m | 45 | ||||
-rw-r--r-- | src/nsterm.h | 73 | ||||
-rw-r--r-- | src/nsterm.m | 950 | ||||
-rw-r--r-- | src/print.c | 100 | ||||
-rw-r--r-- | src/process.c | 2308 | ||||
-rw-r--r-- | src/process.h | 65 | ||||
-rw-r--r-- | src/profiler.c | 11 | ||||
-rw-r--r-- | src/puresize.h | 2 | ||||
-rw-r--r-- | src/ralloc.c | 31 | ||||
-rw-r--r-- | src/regex.c | 702 | ||||
-rw-r--r-- | src/regex.h | 56 | ||||
-rw-r--r-- | src/search.c | 43 | ||||
-rw-r--r-- | src/sheap.c | 83 | ||||
-rw-r--r-- | src/sheap.h | 31 | ||||
-rw-r--r-- | src/sound.c | 4 | ||||
-rw-r--r-- | src/syntax.c | 499 | ||||
-rw-r--r-- | src/sysdep.c | 363 | ||||
-rw-r--r-- | src/syssignal.h | 3 | ||||
-rw-r--r-- | src/systhread.c | 417 | ||||
-rw-r--r-- | src/systhread.h | 112 | ||||
-rw-r--r-- | src/systty.h | 1 | ||||
-rw-r--r-- | src/term.c | 44 | ||||
-rw-r--r-- | src/termhooks.h | 21 | ||||
-rw-r--r-- | src/textprop.c | 20 | ||||
-rw-r--r-- | src/thread.c | 997 | ||||
-rw-r--r-- | src/thread.h | 299 | ||||
-rw-r--r-- | src/unexcw.c | 19 | ||||
-rw-r--r-- | src/unexelf.c | 80 | ||||
-rw-r--r-- | src/unexmacosx.c | 11 | ||||
-rw-r--r-- | src/unexw32.c | 34 | ||||
-rw-r--r-- | src/vm-limit.c | 11 | ||||
-rw-r--r-- | src/w32.c | 340 | ||||
-rw-r--r-- | src/w32.h | 4 | ||||
-rw-r--r-- | src/w32console.c | 27 | ||||
-rw-r--r-- | src/w32fns.c | 1137 | ||||
-rw-r--r-- | src/w32font.c | 12 | ||||
-rw-r--r-- | src/w32font.h | 1 | ||||
-rw-r--r-- | src/w32heap.c | 99 | ||||
-rw-r--r-- | src/w32heap.h | 4 | ||||
-rw-r--r-- | src/w32inevt.c | 135 | ||||
-rw-r--r-- | src/w32menu.c | 27 | ||||
-rw-r--r-- | src/w32notify.c | 336 | ||||
-rw-r--r-- | src/w32proc.c | 84 | ||||
-rw-r--r-- | src/w32reg.c | 4 | ||||
-rw-r--r-- | src/w32select.c | 116 | ||||
-rw-r--r-- | src/w32term.c | 193 | ||||
-rw-r--r-- | src/w32term.h | 48 | ||||
-rw-r--r-- | src/w32uniscribe.c | 9 | ||||
-rw-r--r-- | src/w32xfns.c | 32 | ||||
-rw-r--r-- | src/widget.c | 11 | ||||
-rw-r--r-- | src/window.c | 303 | ||||
-rw-r--r-- | src/window.h | 41 | ||||
-rw-r--r-- | src/xdisp.c | 696 | ||||
-rw-r--r-- | src/xfaces.c | 61 | ||||
-rw-r--r-- | src/xfns.c | 687 | ||||
-rw-r--r-- | src/xfont.c | 77 | ||||
-rw-r--r-- | src/xftfont.c | 102 | ||||
-rw-r--r-- | src/xgselect.c | 26 | ||||
-rw-r--r-- | src/xgselect.h | 3 | ||||
-rw-r--r-- | src/xmenu.c | 6 | ||||
-rw-r--r-- | src/xml.c | 8 | ||||
-rw-r--r-- | src/xselect.c | 73 | ||||
-rw-r--r-- | src/xsmfns.c | 4 | ||||
-rw-r--r-- | src/xterm.c | 404 | ||||
-rw-r--r-- | src/xterm.h | 39 | ||||
-rw-r--r-- | src/xwidget.c | 533 | ||||
-rw-r--r-- | src/xwidget.h | 3 |
143 files changed, 14404 insertions, 9779 deletions
diff --git a/src/.gdbinit b/src/.gdbinit index 9160ffa439e..b0c0dfd7e90 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -1215,21 +1215,6 @@ document xwhichsymbols maximum number of symbols referencing it to produce. end -define xbytecode - set $bt = byte_stack_list - while $bt - xgetptr $bt->byte_string - set $ptr = (struct Lisp_String *) $ptr - xprintbytestr $ptr - printf "\n0x%x => ", $bt->byte_string - xwhichsymbols $bt->byte_string 5 - set $bt = $bt->next - end -end -document xbytecode - Print a backtrace of the byte code stack. -end - # Show Lisp backtrace after normal backtrace. define hookpost-backtrace set $bt = backtrace_top () diff --git a/src/ChangeLog.13 b/src/ChangeLog.13 index 9e998952361..e8ab5e01ea7 100644 --- a/src/ChangeLog.13 +++ b/src/ChangeLog.13 @@ -17073,7 +17073,7 @@ 2013-05-04 Stefan Monnier <monnier@iro.umontreal.ca> * minibuf.c (Fread_minibuffer, Feval_minibuffer): Move to Elisp. - (syms_of_minibuf): Adjust accodingly. + (syms_of_minibuf): Adjust accordingly. * lread.c (Fread): * callint.c (Fcall_interactively): Adjust calls accordingly. diff --git a/src/ChangeLog.3 b/src/ChangeLog.3 index a62aee7517b..256e4b78598 100644 --- a/src/ChangeLog.3 +++ b/src/ChangeLog.3 @@ -11648,7 +11648,7 @@ * fileio.c (Fcopy_file): Always close descriptors. - * s-sunos4.h: read, write, open and close are interruptable. + * s-sunos4.h: read, write, open and close are interruptible. 1991-01-09 Jim Blandy (jimb@churchy.ai.mit.edu) diff --git a/src/Makefile.in b/src/Makefile.in index d54670932d3..9703768e98c 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -236,6 +236,8 @@ IMAGEMAGICK_CFLAGS= @IMAGEMAGICK_CFLAGS@ LIBXML2_LIBS = @LIBXML2_LIBS@ LIBXML2_CFLAGS = @LIBXML2_CFLAGS@ +GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@ + LIBZ = @LIBZ@ ## system-specific libs for dynamic modules, else empty @@ -252,10 +254,15 @@ XINERAMA_CFLAGS = @XINERAMA_CFLAGS@ XFIXES_LIBS = @XFIXES_LIBS@ XFIXES_CFLAGS = @XFIXES_CFLAGS@ +XDBE_LIBS = @XDBE_LIBS@ +XDBE_CFLAGS = @XDBE_CFLAGS@ + ## widget.o if USE_X_TOOLKIT, otherwise empty. WIDGET_OBJ=@WIDGET_OBJ@ -## sheap.o if CYGWIN, otherwise empty. +HYBRID_MALLOC = @HYBRID_MALLOC@ + +## cygw32.o if CYGWIN, otherwise empty. CYGWIN_OBJ=@CYGWIN_OBJ@ ## fontset.o fringe.o image.o if we have any window system @@ -299,20 +306,23 @@ CM_OBJ=@CM_OBJ@ LIBGPM = @LIBGPM@ -## -lresolv, or empty. -LIBRESOLV = @LIBRESOLV@ - LIBSELINUX_LIBS = @LIBSELINUX_LIBS@ LIBGNUTLS_LIBS = @LIBGNUTLS_LIBS@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@ +LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ +LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ + INTERVALS_H = dispextern.h intervals.h composite.h GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ RUN_TEMACS = ./temacs +# Whether builds should contain details. '--no-build-details' or empty. +BUILD_DETAILS = @BUILD_DETAILS@ + UNEXEC_OBJ = @UNEXEC_OBJ@ CANNOT_DUMP=@CANNOT_DUMP@ @@ -351,27 +361,28 @@ DEPFLAGS = MKDEPDIR = : endif -## DO NOT use -R. There is a special hack described in lastfile.c -## which is used instead. Some initialized data areas are modified -## at initial startup, then labeled as part of the text area when -## Emacs is dumped for the first time, and never changed again. -## -## -Demacs is needed to make some files produce the correct version -## for use in Emacs. -## -## FIXME? MYCPPFLAGS only referenced in etc/DEBUG. -ALL_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ +# Flags that might be in WARN_CFLAGS but are not valid for Objective C. +NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd + +# -Demacs makes some files produce the correct version for use in Emacs. +# MYCPPFLAGS is for by-hand Emacs-specific overrides, e.g., +# "make MYCPPFLAGS='-DDBUS_DEBUG'". +EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ -I$(lib) -I$(top_srcdir)/lib \ $(C_SWITCH_MACHINE) $(C_SWITCH_SYSTEM) $(C_SWITCH_X_SITE) \ $(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \ $(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(DBUS_CFLAGS) \ - $(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) \ + $(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \ $(WEBKIT_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ + $(LIBSYSTEMD_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ - $(WARN_CFLAGS) $(WERROR_CFLAGS) $(CFLAGS) -ALL_OBJC_CFLAGS=$(ALL_CFLAGS) $(GNU_OBJC_CFLAGS) + $(WERROR_CFLAGS) +ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) +ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \ + $(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \ + $(GNU_OBJC_CFLAGS) .SUFFIXES: .m .c.o: @@ -398,6 +409,8 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \ $(XWIDGETS_OBJ) \ profiler.o decompress.o \ + thread.o systhread.o \ + $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) obj = $(base_obj) $(NS_OBJC_OBJ) @@ -480,11 +493,12 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(WEBKIT_LIBS) \ $(LIB_EACCESS) $(LIB_FDATASYNC) $(LIB_TIMER_TIME) $(DBUS_LIBS) \ $(LIB_EXECINFO) $(XRANDR_LIBS) $(XINERAMA_LIBS) $(XFIXES_LIBS) \ - $(LIBXML2_LIBS) $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) $(CAIRO_LIBS) \ + $(XDBE_LIBS) \ + $(LIBXML2_LIBS) $(LIBGPM) $(LIBS_SYSTEM) $(CAIRO_LIBS) \ $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ - $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) \ - $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) + $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) \ + $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) $(leimdir)/leim-list.el: bootstrap-emacs$(EXEEXT) $(MAKE) -C ../leim leim-list.el EMACS="$(bootstrap_exe)" @@ -532,7 +546,7 @@ emacs$(EXEEXT): temacs$(EXEEXT) \ ifeq ($(CANNOT_DUMP),yes) ln -f temacs$(EXEEXT) $@ else - LC_ALL=C $(RUN_TEMACS) -batch -l loadup dump + LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup dump ifneq ($(PAXCTL_dumped),) $(PAXCTL_dumped) $@ endif @@ -584,7 +598,9 @@ globals.h: gl-stamp; @true $(ALLOBJS): globals.h -$(lib)/libgnu.a: $(config_h) +LIBEGNU_ARCHIVE = $(lib)/lib$(if $(HYBRID_MALLOC),e)gnu.a + +$(LIBEGNU_ARCHIVE): $(config_h) $(MAKE) -C $(lib) all ## We have to create $(etc) here because init_cmdargs tests its @@ -592,9 +608,9 @@ $(lib)/libgnu.a: $(config_h) ## This goes on to affect various things, and the emacs binary fails ## to start if Vinstallation_directory has the wrong value. temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) \ - $(lib)/libgnu.a $(EMACSRES) ${charsets} ${charscript} + $(LIBEGNU_ARCHIVE) $(EMACSRES) ${charsets} ${charscript} $(AM_V_CCLD)$(CC) $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ - -o temacs $(ALLOBJS) $(lib)/libgnu.a $(W32_RES_LINK) $(LIBES) + -o temacs $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) $(MKDIR_P) $(etc) ifneq ($(CANNOT_DUMP),yes) ifneq ($(PAXCTL_notdumped),) @@ -667,32 +683,34 @@ extraclean: distclean -rm -f *~ \#* -ETAGS = ../lib-src/etags +ETAGS = ../lib-src/etags${EXEEXT} -ctagsfiles1 = [xyzXYZ]*.[hc] -ctagsfiles2 = [a-wA-W]*.[hc] -ctagsfiles3 = [a-zA-Z]*.m +${ETAGS}: FORCE + ${MAKE} -C ../lib-src $(notdir $@) + +ctagsfiles1 = $(wildcard ${srcdir}/*.[hc]) +ctagsfiles2 = $(wildcard ${srcdir}/*.m) ## FIXME? In out-of-tree builds, should TAGS be generated in srcdir? ## This does not need to depend on ../lisp and ../lwlib TAGS files, ## because etags "--include" only includes a pointer to the file, ## rather than the file contents. -TAGS: $(srcdir)/$(ctagsfiles1) $(srcdir)/$(ctagsfiles2) $(srcdir)/$(ctagsfiles3) - "$(ETAGS)" --include=../lisp/TAGS --include=$(lwlibdir)/TAGS \ +TAGS: ${ETAGS} $(ctagsfiles1) $(ctagsfiles2) + ${ETAGS} --include=../lisp/TAGS --include=$(lwlibdir)/TAGS \ --regex='{c}/[ ]*DEFVAR_[A-Z_ (]+"\([^"]+\)"/\1/' \ --regex='{c}/[ ]*DEFVAR_[A-Z_ (]+"[^"]+",[ ]\([A-Za-z0-9_]+\)/\1/' \ - $(srcdir)/$(ctagsfiles1) $(srcdir)/$(ctagsfiles2) \ + $(ctagsfiles1) \ --regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"\([^"]+\)"/\1/' \ --regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"[^"]+",[ ]\([A-Za-z0-9_]+\)/\1/' \ - $(srcdir)/$(ctagsfiles3) + $(ctagsfiles2) ## Arrange to make tags tables for ../lisp and ../lwlib, ## which the above TAGS file for the C files includes by reference. -../lisp/TAGS: +../lisp/TAGS: FORCE $(MAKE) -C ../lisp TAGS ETAGS="$(ETAGS)" -$(lwlibdir)/TAGS: +$(lwlibdir)/TAGS: FORCE $(MAKE) -C $(lwlibdir) TAGS ETAGS="$(ETAGS)" tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS @@ -737,7 +755,7 @@ bootstrap-emacs$(EXEEXT): temacs$(EXEEXT) ifeq ($(CANNOT_DUMP),yes) ln -f temacs$(EXEEXT) $@ else - $(RUN_TEMACS) --batch --load loadup bootstrap + $(RUN_TEMACS) --batch $(BUILD_DETAILS) --load loadup bootstrap ifneq ($(PAXCTL_dumped),) $(PAXCTL_dumped) emacs$(EXEEXT) endif @@ -746,6 +764,10 @@ endif @: Compile some files earlier to speed up further compilation. $(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)" + +generate-ldefs-boot: bootstrap-emacs$(EXEEXT) + $(RUN_TEMACS) --batch $(BUILD_DETAILS) --load loadup bootstrap + ifeq ($(AUTO_DEPEND),yes) -include $(ALLOBJS:%.o=${DEPDIR}/%.d) else diff --git a/src/alloc.c b/src/alloc.c index 6be0263a816..d74c4bec7e2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -20,12 +20,11 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> +#include <errno.h> #include <stdio.h> +#include <stdlib.h> #include <limits.h> /* For CHAR_BIT. */ - -#ifdef ENABLE_CHECKING -#include <signal.h> /* For SIGABRT. */ -#endif +#include <signal.h> /* For SIGABRT, SIGDANGER. */ #ifdef HAVE_PTHREAD #include <pthread.h> @@ -35,6 +34,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "dispextern.h" #include "intervals.h" #include "puresize.h" +#include "sheap.h" #include "systime.h" #include "character.h" #include "buffer.h" @@ -47,6 +47,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ +#include <flexmember.h> #include <verify.h> #include <execinfo.h> /* For backtrace. */ @@ -58,6 +59,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "dosfns.h" /* For dos_memory_info. */ #endif +#ifdef HAVE_MALLOC_H +# include <malloc.h> +#endif + #if (defined ENABLE_CHECKING \ && defined HAVE_VALGRIND_VALGRIND_H \ && !defined USE_VALGRIND) @@ -92,7 +97,7 @@ static bool valgrind_p; #include "w32heap.h" /* for sbrk */ #endif -#if defined DOUG_LEA_MALLOC || defined GNU_LINUX +#ifdef GNU_LINUX /* The address where the heap starts. */ void * my_heap_start (void) @@ -106,8 +111,6 @@ my_heap_start (void) #ifdef DOUG_LEA_MALLOC -#include <malloc.h> - /* Specify maximum number of areas to mmap. It would be nice to use a value that explicitly means "no limit". */ @@ -117,18 +120,6 @@ my_heap_start (void) inside glibc's malloc. */ static void *malloc_state_ptr; -/* Get and free this pointer; useful around unexec. */ -void -alloc_unexec_pre (void) -{ - malloc_state_ptr = malloc_get_state (); -} -void -alloc_unexec_post (void) -{ - free (malloc_state_ptr); -} - /* Restore the dumped malloc state. Because malloc can be invoked even before main (e.g. by the dynamic linker), the dumped malloc state must be restored as early as possible using this special hook. */ @@ -139,7 +130,9 @@ malloc_initialize_hook (void) if (! initialized) { +#ifdef GNU_LINUX my_heap_start (); +#endif malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL; } else @@ -162,21 +155,53 @@ malloc_initialize_hook (void) } } - malloc_set_state (malloc_state_ptr); + if (malloc_set_state (malloc_state_ptr) != 0) + emacs_abort (); # ifndef XMALLOC_OVERRUN_CHECK alloc_unexec_post (); # endif } } +/* Declare the malloc initialization hook, which runs before 'main' starts. + EXTERNALLY_VISIBLE works around Bug#22522. */ # ifndef __MALLOC_HOOK_VOLATILE # define __MALLOC_HOOK_VOLATILE # endif -voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook +voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE = malloc_initialize_hook; #endif +#if defined DOUG_LEA_MALLOC || !defined CANNOT_DUMP + +/* Allocator-related actions to do just before and after unexec. */ + +void +alloc_unexec_pre (void) +{ +# ifdef DOUG_LEA_MALLOC + malloc_state_ptr = malloc_get_state (); + if (!malloc_state_ptr) + fatal ("malloc_get_state: %s", strerror (errno)); +# endif +# ifdef HYBRID_MALLOC + bss_sbrk_did_unexec = true; +# endif +} + +void +alloc_unexec_post (void) +{ +# ifdef DOUG_LEA_MALLOC + free (malloc_state_ptr); +# endif +# ifdef HYBRID_MALLOC + bss_sbrk_did_unexec = false; +# endif +} +#endif + /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer to a struct Lisp_String. */ @@ -212,12 +237,6 @@ EMACS_INT memory_full_cons_threshold; bool gc_in_progress; -/* True means abort if try to GC. - This is for code which is written on the assumption that - no GC will happen, so as to verify that assumption. */ - -bool abort_on_gc; - /* Number of live and free conses etc. */ static EMACS_INT total_conses, total_markers, total_symbols, total_buffers; @@ -419,10 +438,6 @@ struct mem_node enum mem_type type; }; -/* Base address of stack. Set in main. */ - -Lisp_Object *stack_base; - /* Root of the tree describing allocated Lisp memory. */ static struct mem_node *mem_root; @@ -460,23 +475,23 @@ static int staticidx; static void *pure_alloc (size_t, int); -/* Return X rounded to the next multiple of Y. Arguments should not - have side effects, as they are evaluated more than once. Assume X - + Y - 1 does not overflow. Tune for Y being a power of 2. */ +/* True if N is a power of 2. N should be positive. */ -#define ROUNDUP(x, y) ((y) & ((y) - 1) \ - ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \ - : ((x) + (y) - 1) & ~ ((y) - 1)) +#define POWER_OF_2(n) (((n) & ((n) - 1)) == 0) -/* Bug#23764 */ -#ifdef ALIGN -# undef ALIGN -#endif +/* Return X rounded to the next multiple of Y. Y should be positive, + and Y - 1 + X should not overflow. Arguments should not have side + effects, as they are evaluated more than once. Tune for Y being a + power of 2. */ + +#define ROUNDUP(x, y) (POWER_OF_2 (y) \ + ? ((y) - 1 + (x)) & ~ ((y) - 1) \ + : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y)) /* Return PTR rounded up to the next multiple of ALIGNMENT. */ static void * -ALIGN (void *ptr, int alignment) +pointer_align (void *ptr, int alignment) { return (void *) ROUNDUP ((uintptr_t) ptr, alignment); } @@ -555,6 +570,8 @@ static struct Lisp_Finalizer doomed_finalizers; Malloc ************************************************************************/ +#if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC) + /* Function malloc calls this if it finds we are near exhausting storage. */ void @@ -563,6 +580,7 @@ malloc_warning (const char *str) pending_malloc_warning = str; } +#endif /* Display an already-pending malloc warning. */ @@ -623,13 +641,14 @@ buffer_memory_full (ptrdiff_t nbytes) #define XMALLOC_OVERRUN_CHECK_OVERHEAD \ (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE) -/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to - hold a size_t value and (2) the header size is a multiple of the - alignment that Emacs needs for C types and for USE_LSB_TAG. */ #define XMALLOC_BASE_ALIGNMENT alignof (max_align_t) #define XMALLOC_HEADER_ALIGNMENT \ COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT) + +/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to + hold a size_t value and (2) the header size is a multiple of the + alignment that Emacs needs for C types and for USE_LSB_TAG. */ #define XMALLOC_OVERRUN_SIZE_SIZE \ (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \ + XMALLOC_HEADER_ALIGNMENT - 1) \ @@ -1110,41 +1129,41 @@ lisp_free (void *block) /* The entry point is lisp_align_malloc which returns blocks of at most BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */ +/* Byte alignment of storage blocks. */ +#define BLOCK_ALIGN (1 << 10) +verify (POWER_OF_2 (BLOCK_ALIGN)); + /* Use aligned_alloc if it or a simple substitute is available. Address sanitization breaks aligned allocation, as of gcc 4.8.2 and clang 3.3 anyway. Aligned allocation is incompatible with unexmacosx.c, so don't use it on Darwin. */ #if ! ADDRESS_SANITIZER && !defined DARWIN_OS -# if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC +# if (defined HAVE_ALIGNED_ALLOC \ + || (defined HYBRID_MALLOC \ + ? defined HAVE_POSIX_MEMALIGN \ + : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC)) # define USE_ALIGNED_ALLOC 1 -# ifndef HAVE_ALIGNED_ALLOC -/* Defined in gmalloc.c. */ -void *aligned_alloc (size_t, size_t); -# endif -# elif defined HYBRID_MALLOC -# if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN -# define USE_ALIGNED_ALLOC 1 -# define aligned_alloc hybrid_aligned_alloc -/* Defined in gmalloc.c. */ -void *aligned_alloc (size_t, size_t); -# endif -# elif defined HAVE_ALIGNED_ALLOC -# define USE_ALIGNED_ALLOC 1 -# elif defined HAVE_POSIX_MEMALIGN +# elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN # define USE_ALIGNED_ALLOC 1 +# define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h. */ static void * aligned_alloc (size_t alignment, size_t size) { + /* POSIX says the alignment must be a power-of-2 multiple of sizeof (void *). + Verify this for all arguments this function is given. */ + verify (BLOCK_ALIGN % sizeof (void *) == 0 + && POWER_OF_2 (BLOCK_ALIGN / sizeof (void *))); + verify (GCALIGNMENT % sizeof (void *) == 0 + && POWER_OF_2 (GCALIGNMENT / sizeof (void *))); + eassert (alignment == BLOCK_ALIGN || alignment == GCALIGNMENT); + void *p; return posix_memalign (&p, alignment, size) == 0 ? p : 0; } # endif #endif -/* BLOCK_ALIGN has to be a power of 2. */ -#define BLOCK_ALIGN (1 << 10) - /* Padding to leave at the end of a malloc'd block. This is to give malloc a chance to minimize the amount of memory wasted to alignment. It should be tuned to the particular malloc library used. @@ -1171,16 +1190,18 @@ struct ablock char payload[BLOCK_BYTES]; struct ablock *next_free; } x; - /* `abase' is the aligned base of the ablocks. */ - /* It is overloaded to hold the virtual `busy' field that counts - the number of used ablock in the parent ablocks. - The first ablock has the `busy' field, the others have the `abase' - field. To tell the difference, we assume that pointers will have - integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy' - is used to tell whether the real base of the parent ablocks is `abase' - (if not, the word before the first ablock holds a pointer to the - real base). */ + + /* ABASE is the aligned base of the ablocks. It is overloaded to + hold a virtual "busy" field that counts twice the number of used + ablock values in the parent ablocks, plus one if the real base of + the parent ablocks is ABASE (if the "busy" field is even, the + word before the first ablock holds a pointer to the real base). + The first ablock has a "busy" ABASE, and the others have an + ordinary pointer ABASE. To tell the difference, the code assumes + that pointers, when cast to uintptr_t, are at least 2 * + ABLOCKS_SIZE + 1. */ struct ablocks *abase; + /* The padding of all but the last ablock is unused. The padding of the last ablock in an ablocks is not allocated. */ #if BLOCK_PADDING @@ -1199,18 +1220,18 @@ struct ablocks #define ABLOCK_ABASE(block) \ (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \ - ? (struct ablocks *)(block) \ + ? (struct ablocks *) (block) \ : (block)->abase) /* Virtual `busy' field. */ -#define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase) +#define ABLOCKS_BUSY(a_base) ((a_base)->blocks[0].abase) /* Pointer to the (not necessarily aligned) malloc block. */ #ifdef USE_ALIGNED_ALLOC #define ABLOCKS_BASE(abase) (abase) #else #define ABLOCKS_BASE(abase) \ - (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1]) + (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1]) #endif /* The list of free ablock. */ @@ -1236,7 +1257,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type) if (!free_ablock) { int i; - intptr_t aligned; /* int gets warning casting to 64-bit pointer. */ + bool aligned; #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -1244,10 +1265,11 @@ lisp_align_malloc (size_t nbytes, enum mem_type type) #endif #ifdef USE_ALIGNED_ALLOC + verify (ABLOCKS_BYTES % BLOCK_ALIGN == 0); abase = base = aligned_alloc (BLOCK_ALIGN, ABLOCKS_BYTES); #else base = malloc (ABLOCKS_BYTES); - abase = ALIGN (base, BLOCK_ALIGN); + abase = pointer_align (base, BLOCK_ALIGN); #endif if (base == 0) @@ -1292,13 +1314,14 @@ lisp_align_malloc (size_t nbytes, enum mem_type type) abase->blocks[i].x.next_free = free_ablock; free_ablock = &abase->blocks[i]; } - ABLOCKS_BUSY (abase) = (struct ablocks *) aligned; + intptr_t ialigned = aligned; + ABLOCKS_BUSY (abase) = (struct ablocks *) ialigned; - eassert (0 == ((uintptr_t) abase) % BLOCK_ALIGN); + eassert ((uintptr_t) abase % BLOCK_ALIGN == 0); eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */ eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase); eassert (ABLOCKS_BASE (abase) == base); - eassert (aligned == (intptr_t) ABLOCKS_BUSY (abase)); + eassert ((intptr_t) ABLOCKS_BUSY (abase) == aligned); } abase = ABLOCK_ABASE (free_ablock); @@ -1334,12 +1357,14 @@ lisp_align_free (void *block) ablock->x.next_free = free_ablock; free_ablock = ablock; /* Update busy count. */ - ABLOCKS_BUSY (abase) - = (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase)); + intptr_t busy = (intptr_t) ABLOCKS_BUSY (abase) - 2; + eassume (0 <= busy && busy <= 2 * ABLOCKS_SIZE - 1); + ABLOCKS_BUSY (abase) = (struct ablocks *) busy; - if (2 > (intptr_t) ABLOCKS_BUSY (abase)) + if (busy < 2) { /* All the blocks are free. */ - int i = 0, aligned = (intptr_t) ABLOCKS_BUSY (abase); + int i = 0; + bool aligned = busy; struct ablock **tem = &free_ablock; struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1]; @@ -1367,15 +1392,21 @@ lisp_align_free (void *block) # define __alignof__(type) alignof (type) #endif -/* True if malloc returns a multiple of GCALIGNMENT. In practice this - holds if __alignof__ (max_align_t) is a multiple. Use __alignof__ - if available, as otherwise this check would fail with GCC x86. +/* True if malloc (N) is known to return a multiple of GCALIGNMENT + whenever N is also a multiple. In practice this is true if + __alignof__ (max_align_t) is a multiple as well, assuming + GCALIGNMENT is 8; other values of GCALIGNMENT have not been looked + into. Use __alignof__ if available, as otherwise + MALLOC_IS_GC_ALIGNED would be false on GCC x86 even though the + alignment is OK there. + This is a macro, not an enum constant, for portability to HP-UX 10.20 cc and AIX 3.2.5 xlc. */ -#define MALLOC_IS_GC_ALIGNED (__alignof__ (max_align_t) % GCALIGNMENT == 0) +#define MALLOC_IS_GC_ALIGNED \ + (GCALIGNMENT == 8 && __alignof__ (max_align_t) % GCALIGNMENT == 0) -/* True if P is suitably aligned for SIZE, where Lisp alignment may be - needed if SIZE is Lisp-aligned. */ +/* True if a malloc-returned pointer P is suitably aligned for SIZE, + where Lisp alignment may be needed if SIZE is Lisp-aligned. */ static bool laligned (void *p, size_t size) @@ -1404,24 +1435,20 @@ static void * lmalloc (size_t size) { #if USE_ALIGNED_ALLOC - if (! MALLOC_IS_GC_ALIGNED) + if (! MALLOC_IS_GC_ALIGNED && size % GCALIGNMENT == 0) return aligned_alloc (GCALIGNMENT, size); #endif - void *p; while (true) { - p = malloc (size); + void *p = malloc (size); if (laligned (p, size)) - break; + return p; free (p); size_t bigger = size + GCALIGNMENT; if (size < bigger) size = bigger; } - - eassert ((intptr_t) p % GCALIGNMENT == 0); - return p; } static void * @@ -1431,14 +1458,11 @@ lrealloc (void *p, size_t size) { p = realloc (p, size); if (laligned (p, size)) - break; + return p; size_t bigger = size + GCALIGNMENT; if (size < bigger) size = bigger; } - - eassert ((intptr_t) p % GCALIGNMENT == 0); - return p; } @@ -1730,27 +1754,23 @@ static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] = #ifdef GC_CHECK_STRING_BYTES -#define SDATA_SIZE(NBYTES) \ - ((SDATA_DATA_OFFSET \ - + (NBYTES) + 1 \ - + sizeof (ptrdiff_t) - 1) \ - & ~(sizeof (ptrdiff_t) - 1)) +#define SDATA_SIZE(NBYTES) FLEXSIZEOF (struct sdata, data, NBYTES) #else /* not GC_CHECK_STRING_BYTES */ /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is less than the size of that member. The 'max' is not needed when - SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the - alignment code reserves enough space. */ + SDATA_DATA_OFFSET is a multiple of FLEXALIGNOF (struct sdata), + because then the alignment code reserves enough space. */ #define SDATA_SIZE(NBYTES) \ ((SDATA_DATA_OFFSET \ - + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \ + + (SDATA_DATA_OFFSET % FLEXALIGNOF (struct sdata) == 0 \ ? NBYTES \ - : max (NBYTES, sizeof (ptrdiff_t) - 1)) \ + : max (NBYTES, FLEXALIGNOF (struct sdata) - 1)) \ + 1 \ - + sizeof (ptrdiff_t) - 1) \ - & ~(sizeof (ptrdiff_t) - 1)) + + FLEXALIGNOF (struct sdata) - 1) \ + & ~(FLEXALIGNOF (struct sdata) - 1)) #endif /* not GC_CHECK_STRING_BYTES */ @@ -1970,7 +1990,7 @@ allocate_string_data (struct Lisp_String *s, if (nbytes > LARGE_STRING_BYTES) { - size_t size = offsetof (struct sblock, data) + needed; + size_t size = FLEXSIZEOF (struct sblock, data, needed); #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -1984,9 +2004,9 @@ allocate_string_data (struct Lisp_String *s, mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); #endif - b->next_free = b->data; - b->data[0].string = NULL; + data = b->data; b->next = large_sblocks; + b->next_free = data; large_sblocks = b; } else if (current_sblock == NULL @@ -1996,9 +2016,9 @@ allocate_string_data (struct Lisp_String *s, { /* Not enough room in the current sblock. */ b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP); - b->next_free = b->data; - b->data[0].string = NULL; + data = b->data; b->next = NULL; + b->next_free = data; if (current_sblock) current_sblock->next = b; @@ -2007,14 +2027,16 @@ allocate_string_data (struct Lisp_String *s, current_sblock = b; } else - b = current_sblock; + { + b = current_sblock; + data = b->next_free; + } - data = b->next_free; + data->string = s; b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA); MALLOC_UNBLOCK_INPUT; - data->string = s; s->data = SDATA_DATA (data); #ifdef GC_CHECK_STRING_BYTES SDATA_NBYTES (data) = nbytes; @@ -2171,89 +2193,96 @@ free_large_strings (void) static void compact_small_strings (void) { - struct sblock *b, *tb, *next; - sdata *from, *to, *end, *tb_end; - sdata *to_end, *from_end; - /* TB is the sblock we copy to, TO is the sdata within TB we copy to, and TB_END is the end of TB. */ - tb = oldest_sblock; - tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE); - to = tb->data; - - /* Step through the blocks from the oldest to the youngest. We - expect that old blocks will stabilize over time, so that less - copying will happen this way. */ - for (b = oldest_sblock; b; b = b->next) + struct sblock *tb = oldest_sblock; + if (tb) { - end = b->next_free; - eassert ((char *) end <= (char *) b + SBLOCK_SIZE); + sdata *tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE); + sdata *to = tb->data; - for (from = b->data; from < end; from = from_end) + /* Step through the blocks from the oldest to the youngest. We + expect that old blocks will stabilize over time, so that less + copying will happen this way. */ + struct sblock *b = tb; + do { - /* Compute the next FROM here because copying below may - overwrite data we need to compute it. */ - ptrdiff_t nbytes; - struct Lisp_String *s = from->string; + sdata *end = b->next_free; + eassert ((char *) end <= (char *) b + SBLOCK_SIZE); + + for (sdata *from = b->data; from < end; ) + { + /* Compute the next FROM here because copying below may + overwrite data we need to compute it. */ + ptrdiff_t nbytes; + struct Lisp_String *s = from->string; #ifdef GC_CHECK_STRING_BYTES - /* Check that the string size recorded in the string is the - same as the one recorded in the sdata structure. */ - if (s && string_bytes (s) != SDATA_NBYTES (from)) - emacs_abort (); + /* Check that the string size recorded in the string is the + same as the one recorded in the sdata structure. */ + if (s && string_bytes (s) != SDATA_NBYTES (from)) + emacs_abort (); #endif /* GC_CHECK_STRING_BYTES */ - nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from); - eassert (nbytes <= LARGE_STRING_BYTES); + nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from); + eassert (nbytes <= LARGE_STRING_BYTES); - nbytes = SDATA_SIZE (nbytes); - from_end = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA); + nbytes = SDATA_SIZE (nbytes); + sdata *from_end = (sdata *) ((char *) from + + nbytes + GC_STRING_EXTRA); #ifdef GC_CHECK_STRING_OVERRUN - if (memcmp (string_overrun_cookie, - (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE, - GC_STRING_OVERRUN_COOKIE_SIZE)) - emacs_abort (); + if (memcmp (string_overrun_cookie, + (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE, + GC_STRING_OVERRUN_COOKIE_SIZE)) + emacs_abort (); #endif - /* Non-NULL S means it's alive. Copy its data. */ - if (s) - { - /* If TB is full, proceed with the next sblock. */ - to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); - if (to_end > tb_end) + /* Non-NULL S means it's alive. Copy its data. */ + if (s) { - tb->next_free = to; - tb = tb->next; - tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE); - to = tb->data; - to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); - } + /* If TB is full, proceed with the next sblock. */ + sdata *to_end = (sdata *) ((char *) to + + nbytes + GC_STRING_EXTRA); + if (to_end > tb_end) + { + tb->next_free = to; + tb = tb->next; + tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE); + to = tb->data; + to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); + } - /* Copy, and update the string's `data' pointer. */ - if (from != to) - { - eassert (tb != b || to < from); - memmove (to, from, nbytes + GC_STRING_EXTRA); - to->string->data = SDATA_DATA (to); - } + /* Copy, and update the string's `data' pointer. */ + if (from != to) + { + eassert (tb != b || to < from); + memmove (to, from, nbytes + GC_STRING_EXTRA); + to->string->data = SDATA_DATA (to); + } - /* Advance past the sdata we copied to. */ - to = to_end; + /* Advance past the sdata we copied to. */ + to = to_end; + } + from = from_end; } + b = b->next; } - } + while (b); - /* The rest of the sblocks following TB don't contain live data, so - we can free them. */ - for (b = tb->next; b; b = next) - { - next = b->next; - lisp_free (b); + /* The rest of the sblocks following TB don't contain live data, so + we can free them. */ + for (b = tb->next; b; ) + { + struct sblock *next = b->next; + lisp_free (b); + b = next; + } + + tb->next_free = to; + tb->next = NULL; } - tb->next_free = to; - tb->next = NULL; current_sblock = tb; } @@ -2919,15 +2948,15 @@ set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p) enum { /* Alignment of struct Lisp_Vector objects. */ - vector_alignment = COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR, - GCALIGNMENT), + vector_alignment = COMMON_MULTIPLE (FLEXALIGNOF (struct Lisp_Vector), + GCALIGNMENT), /* Vector size requests are a multiple of this. */ roundup_size = COMMON_MULTIPLE (vector_alignment, word_size) }; /* Verify assumptions described above. */ -verify ((VECTOR_BLOCK_SIZE % roundup_size) == 0); +verify (VECTOR_BLOCK_SIZE % roundup_size == 0); verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS)); /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */ @@ -3157,8 +3186,7 @@ vector_nbytes (struct Lisp_Vector *v) } /* Release extra resources still in use by VECTOR, which may be any - vector-like object. For now, this is used just to free data in - font objects. */ + vector-like object. */ static void cleanup_vector (struct Lisp_Vector *vector) @@ -3168,7 +3196,7 @@ cleanup_vector (struct Lisp_Vector *vector) && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)) { - struct font_driver *drv = ((struct font *) vector)->driver; + struct font_driver const *drv = ((struct font *) vector)->driver; /* The font driver might sometimes be NULL, e.g. if Emacs was interrupted before it had time to set it up. */ @@ -3179,6 +3207,13 @@ cleanup_vector (struct Lisp_Vector *vector) drv->close ((struct font *) vector); } } + + if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) + finalize_one_thread ((struct thread_state *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) + finalize_one_mutex ((struct Lisp_Mutex *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR)) + finalize_one_condvar ((struct Lisp_CondVar *) vector); } /* Reclaim space used by unmarked vectors. */ @@ -3396,22 +3431,13 @@ allocate_buffer (void) DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, doc: /* Return a newly created vector of length LENGTH, with each element being INIT. See also the function `vector'. */) - (register Lisp_Object length, Lisp_Object init) + (Lisp_Object length, Lisp_Object init) { - Lisp_Object vector; - register ptrdiff_t sizei; - register ptrdiff_t i; - register struct Lisp_Vector *p; - CHECK_NATNUM (length); - - p = allocate_vector (XFASTINT (length)); - sizei = XFASTINT (length); - for (i = 0; i < sizei; i++) + struct Lisp_Vector *p = allocate_vector (XFASTINT (length)); + for (ptrdiff_t i = 0; i < XFASTINT (length); i++) p->contents[i] = init; - - XSETVECTOR (vector, p); - return vector; + return make_lisp_ptr (p, Lisp_Vectorlike); } DEFUN ("vector", Fvector, Svector, 0, MANY, 0, @@ -3420,12 +3446,9 @@ Any number of arguments, even zero arguments, are allowed. usage: (vector &rest OBJECTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - ptrdiff_t i; - register Lisp_Object val = make_uninit_vector (nargs); - register struct Lisp_Vector *p = XVECTOR (val); - - for (i = 0; i < nargs; i++) - p->contents[i] = args[i]; + Lisp_Object val = make_uninit_vector (nargs); + struct Lisp_Vector *p = XVECTOR (val); + memcpy (p->contents, args, nargs * sizeof *args); return val; } @@ -3464,9 +3487,8 @@ stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - ptrdiff_t i; - register Lisp_Object val = make_uninit_vector (nargs); - register struct Lisp_Vector *p = XVECTOR (val); + Lisp_Object val = make_uninit_vector (nargs); + struct Lisp_Vector *p = XVECTOR (val); /* We used to purecopy everything here, if purify-flag was set. This worked OK for Emacs-23, but with Emacs-24's lexical binding code, it can be @@ -3476,8 +3498,7 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT just wasteful and other times plainly wrong (e.g. those free vars may want to be setcar'd). */ - for (i = 0; i < nargs; i++) - p->contents[i] = args[i]; + memcpy (p->contents, args, nargs * sizeof *args); make_byte_code (p); XSETCOMPILED (val, p); return val; @@ -3548,7 +3569,7 @@ init_symbol (Lisp_Object val, Lisp_Object name) set_symbol_next (val, NULL); p->gcmarkbit = false; p->interned = SYMBOL_UNINTERNED; - p->constant = 0; + p->trapped_write = SYMBOL_UNTRAPPED_WRITE; p->declared_special = false; p->pinned = false; } @@ -5028,14 +5049,13 @@ test_setjmp (void) would be necessary, each one starting with one byte more offset from the stack start. */ -static void -mark_stack (void *end) +void +mark_stack (char *bottom, char *end) { - /* This assumes that the stack is a contiguous region in memory. If that's not the case, something has to be done here to iterate over the stack segments. */ - mark_memory (stack_base, end); + mark_memory (bottom, end); /* Allow for marking a secondary stack, like the register stack on the ia64. */ @@ -5044,6 +5064,81 @@ mark_stack (void *end) #endif } +/* This is a trampoline function that flushes registers to the stack, + and then calls FUNC. ARG is passed through to FUNC verbatim. + + This function must be called whenever Emacs is about to release the + global interpreter lock. This lets the garbage collector easily + find roots in registers on threads that are not actively running + Lisp. + + It is invalid to run any Lisp code or to allocate any GC memory + from FUNC. */ + +void +flush_stack_call_func (void (*func) (void *arg), void *arg) +{ + void *end; + struct thread_state *self = current_thread; + +#ifdef HAVE___BUILTIN_UNWIND_INIT + /* Force callee-saved registers and register windows onto the stack. + This is the preferred method if available, obviating the need for + machine dependent methods. */ + __builtin_unwind_init (); + end = &end; +#else /* not HAVE___BUILTIN_UNWIND_INIT */ +#ifndef GC_SAVE_REGISTERS_ON_STACK + /* jmp_buf may not be aligned enough on darwin-ppc64 */ + union aligned_jmpbuf { + Lisp_Object o; + sys_jmp_buf j; + } j; + volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom; +#endif + /* This trick flushes the register windows so that all the state of + the process is contained in the stack. */ + /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is + needed on ia64 too. See mach_dep.c, where it also says inline + assembler doesn't work with relevant proprietary compilers. */ +#ifdef __sparc__ +#if defined (__sparc64__) && defined (__FreeBSD__) + /* FreeBSD does not have a ta 3 handler. */ + asm ("flushw"); +#else + asm ("ta 3"); +#endif +#endif + + /* Save registers that we need to see on the stack. We need to see + registers used to hold register variables and registers used to + pass parameters. */ +#ifdef GC_SAVE_REGISTERS_ON_STACK + GC_SAVE_REGISTERS_ON_STACK (end); +#else /* not GC_SAVE_REGISTERS_ON_STACK */ + +#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that + setjmp will definitely work, test it + and print a message with the result + of the test. */ + if (!setjmp_tested_p) + { + setjmp_tested_p = 1; + test_setjmp (); + } +#endif /* GC_SETJMP_WORKS */ + + sys_setjmp (j.j); + end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; +#endif /* not GC_SAVE_REGISTERS_ON_STACK */ +#endif /* not HAVE___BUILTIN_UNWIND_INIT */ + + self->stack_top = end; + (*func) (arg); + + eassert (current_thread == self); +} + static bool c_symbol_p (struct Lisp_Symbol *sym) { @@ -5173,7 +5268,7 @@ pure_alloc (size_t size, int type) { /* Allocate space for a Lisp object from the beginning of the free space with taking account of alignment. */ - result = ALIGN (purebeg + pure_bytes_used_lisp, GCALIGNMENT); + result = pointer_align (purebeg + pure_bytes_used_lisp, GCALIGNMENT); pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size; } else @@ -5200,6 +5295,8 @@ pure_alloc (size_t size, int type) } +#ifndef CANNOT_DUMP + /* Print a warning if PURESIZE is too small. */ void @@ -5210,6 +5307,7 @@ check_pure_size (void) " bytes needed)"), pure_bytes_used + pure_bytes_used_before_overflow); } +#endif /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from @@ -5436,7 +5534,7 @@ purecopy (Lisp_Object obj) } else { - Lisp_Object fmt = build_pure_c_string ("Don't know how to purify: %S"); + AUTO_STRING (fmt, "Don't know how to purify: %S"); Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj))); } @@ -5662,16 +5760,13 @@ garbage_collect_1 (void *end) Lisp_Object retval = Qnil; size_t tot_before = 0; - if (abort_on_gc) - emacs_abort (); - /* Can't GC if pure storage overflowed because we can't determine if something is a pure object or not. */ if (pure_bytes_used_before_overflow) return Qnil; /* Record this function, so it appears on the profiler's backtraces. */ - record_in_backtrace (Qautomatic_gc, 0, 0); + record_in_backtrace (QAutomatic_GC, 0, 0); check_cons_list (); @@ -5749,24 +5844,14 @@ garbage_collect_1 (void *end) mark_object (*staticvec[i]); mark_pinned_symbols (); - mark_specpdl (); mark_terminals (); mark_kboards (); + mark_threads (); #ifdef USE_GTK xg_mark_data (); #endif - mark_stack (end); - - { - struct handler *handler; - for (handler = handlerlist; handler; handler = handler->next) - { - mark_object (handler->tag_or_ch); - mark_object (handler->val); - } - } #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif @@ -5798,8 +5883,6 @@ garbage_collect_1 (void *end) gc_sweep (); - relocate_byte_stack (); - /* Clear the mark bits that we set in certain root slots. */ VECTOR_UNMARK (&buffer_defaults); VECTOR_UNMARK (&buffer_local_symbols); @@ -6134,7 +6217,7 @@ mark_face_cache (struct face_cache *c) int i, j; for (i = 0; i < c->used; ++i) { - struct face *face = FACE_FROM_ID (c->f, i); + struct face *face = FACE_FROM_ID_OR_NULL (c->f, i); if (face) { @@ -6321,7 +6404,7 @@ mark_object (Lisp_Object arg) #ifdef GC_CHECK_MARKED_OBJECTS m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj)) + if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) emacs_abort (); #endif /* GC_CHECK_MARKED_OBJECTS */ @@ -6331,7 +6414,9 @@ mark_object (Lisp_Object arg) else pvectype = PVEC_NORMAL_VECTOR; - if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER) + if (pvectype != PVEC_SUBR + && pvectype != PVEC_BUFFER + && !main_thread_p (po)) CHECK_LIVE (live_vector_p); switch (pvectype) @@ -7044,7 +7129,7 @@ We divide the value by 1024 to make sure it fits in a Lisp integer. */) { Lisp_Object end; -#ifdef HAVE_NS +#if defined HAVE_NS || !HAVE_SBRK /* Avoid warning. sbrk has no relation to memory allocated anyway. */ XSETINT (end, 0); #else @@ -7232,21 +7317,6 @@ die (const char *msg, const char *file, int line) #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS -/* Debugging check whether STR is ASCII-only. */ - -const char * -verify_ascii (const char *str) -{ - const unsigned char *ptr = (unsigned char *) str, *end = ptr + strlen (str); - while (ptr < end) - { - int c = STRING_CHAR_ADVANCE (ptr); - if (!ASCII_CHAR_P (c)) - emacs_abort (); - } - return str; -} - /* Stress alloca with inconveniently sized requests and check whether all allocated areas may be used for Lisp_Object. */ @@ -7402,7 +7472,7 @@ do hash-consing of the objects allocated to pure space. */); DEFSYM (Qstring_bytes, "string-bytes"); DEFSYM (Qvector_slots, "vector-slots"); DEFSYM (Qheap, "heap"); - DEFSYM (Qautomatic_gc, "Automatic GC"); + DEFSYM (QAutomatic_GC, "Automatic GC"); DEFSYM (Qgc_cons_threshold, "gc-cons-threshold"); DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots"); diff --git a/src/bidi.c b/src/bidi.c index c2208cd12c2..5824de54ad8 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -1107,15 +1107,9 @@ bidi_initialize (void) emacs_abort (); staticpro (&bidi_brackets_table); - DEFSYM (Qparagraph_start, "paragraph-start"); - paragraph_start_re = Fsymbol_value (Qparagraph_start); - if (!STRINGP (paragraph_start_re)) - paragraph_start_re = build_string ("\f\\|[ \t]*$"); + paragraph_start_re = build_string ("^\\(\f\\|[ \t]*\\)$"); staticpro (¶graph_start_re); - DEFSYM (Qparagraph_separate, "paragraph-separate"); - paragraph_separate_re = Fsymbol_value (Qparagraph_separate); - if (!STRINGP (paragraph_separate_re)) - paragraph_separate_re = build_string ("[ \t\f]*$"); + paragraph_separate_re = build_string ("^[ \t\f]*$"); staticpro (¶graph_separate_re); bidi_cache_sp = 0; diff --git a/src/buffer.c b/src/buffer.c index 89f4479740a..28cf7024acb 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -25,13 +25,14 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <sys/param.h> #include <errno.h> #include <stdio.h> +#include <stdlib.h> #include <unistd.h> #include <verify.h> #include "lisp.h" -#include "coding.h" #include "intervals.h" +#include "process.h" #include "systime.h" #include "window.h" #include "commands.h" @@ -48,8 +49,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for mmap_* */ #endif -struct buffer *current_buffer; /* The current buffer. */ - /* First buffer in chain of all buffers (in reverse order of creation). Threaded through ->header.next.buffer. */ @@ -984,40 +983,54 @@ reset_buffer_local_variables (struct buffer *b, bool permanent_too) bset_local_var_alist (b, Qnil); else { - Lisp_Object tmp, prop, last = Qnil; + Lisp_Object tmp, last = Qnil; for (tmp = BVAR (b, local_var_alist); CONSP (tmp); tmp = XCDR (tmp)) - if (!NILP (prop = Fget (XCAR (XCAR (tmp)), Qpermanent_local))) - { - /* If permanent-local, keep it. */ - last = tmp; - if (EQ (prop, Qpermanent_local_hook)) - { - /* This is a partially permanent hook variable. - Preserve only the elements that want to be preserved. */ - Lisp_Object list, newlist; - list = XCDR (XCAR (tmp)); - if (!CONSP (list)) - newlist = list; - else - for (newlist = Qnil; CONSP (list); list = XCDR (list)) - { - Lisp_Object elt = XCAR (list); - /* Preserve element ELT if it's t, - if it is a function with a `permanent-local-hook' property, - or if it's not a symbol. */ - if (! SYMBOLP (elt) - || EQ (elt, Qt) - || !NILP (Fget (elt, Qpermanent_local_hook))) - newlist = Fcons (elt, newlist); - } - XSETCDR (XCAR (tmp), Fnreverse (newlist)); - } - } - /* Delete this local variable. */ - else if (NILP (last)) - bset_local_var_alist (b, XCDR (tmp)); - else - XSETCDR (last, XCDR (tmp)); + { + Lisp_Object local_var = XCAR (XCAR (tmp)); + Lisp_Object prop = Fget (local_var, Qpermanent_local); + + if (!NILP (prop)) + { + /* If permanent-local, keep it. */ + last = tmp; + if (EQ (prop, Qpermanent_local_hook)) + { + /* This is a partially permanent hook variable. + Preserve only the elements that want to be preserved. */ + Lisp_Object list, newlist; + list = XCDR (XCAR (tmp)); + if (!CONSP (list)) + newlist = list; + else + for (newlist = Qnil; CONSP (list); list = XCDR (list)) + { + Lisp_Object elt = XCAR (list); + /* Preserve element ELT if it's t, + if it is a function with a `permanent-local-hook' property, + or if it's not a symbol. */ + if (! SYMBOLP (elt) + || EQ (elt, Qt) + || !NILP (Fget (elt, Qpermanent_local_hook))) + newlist = Fcons (elt, newlist); + } + newlist = Fnreverse (newlist); + if (XSYMBOL (local_var)->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (local_var, newlist, + Qmakunbound, Fcurrent_buffer ()); + XSETCDR (XCAR (tmp), newlist); + continue; /* Don't do variable write trapping twice. */ + } + } + /* Delete this local variable. */ + else if (NILP (last)) + bset_local_var_alist (b, XCDR (tmp)); + else + XSETCDR (last, XCDR (tmp)); + + if (XSYMBOL (local_var)->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (local_var, Qnil, + Qmakunbound, Fcurrent_buffer ()); + } } for (i = 0; i < last_per_buffer_idx; ++i) @@ -1051,44 +1064,36 @@ it is in the sequence to be tried) even if a buffer with that name exists. If NAME begins with a space (i.e., a buffer that is not normally visible to users), then if buffer NAME already exists a random number is first appended to NAME, to speed up finding a non-existent buffer. */) - (register Lisp_Object name, Lisp_Object ignore) + (Lisp_Object name, Lisp_Object ignore) { - register Lisp_Object gentemp, tem, tem2; - ptrdiff_t count; - char number[INT_BUFSIZE_BOUND (ptrdiff_t) + sizeof "<>"]; + Lisp_Object genbase; CHECK_STRING (name); - tem = Fstring_equal (name, ignore); - if (!NILP (tem)) - return name; - tem = Fget_buffer (name); - if (NILP (tem)) + if (!NILP (Fstring_equal (name, ignore)) || NILP (Fget_buffer (name))) return name; - if (!strncmp (SSDATA (name), " ", 1)) /* see bug#1229 */ + if (SREF (name, 0) != ' ') /* See bug#1229. */ + genbase = name; + else { /* Note fileio.c:make_temp_name does random differently. */ - tem2 = concat2 (name, make_formatted_string - (number, "-%"pI"d", - XFASTINT (Frandom (make_number (999999))))); - tem = Fget_buffer (tem2); - if (NILP (tem)) - return tem2; + char number[sizeof "-999999"]; + int i = XFASTINT (Frandom (make_number (999999))); + AUTO_STRING_WITH_LEN (lnumber, number, sprintf (number, "-%d", i)); + genbase = concat2 (name, lnumber); + if (NILP (Fget_buffer (genbase))) + return genbase; } - else - tem2 = name; - count = 1; - while (1) + for (ptrdiff_t count = 2; ; count++) { - gentemp = concat2 (tem2, make_formatted_string - (number, "<%"pD"d>", ++count)); - tem = Fstring_equal (gentemp, ignore); - if (!NILP (tem)) - return gentemp; - tem = Fget_buffer (gentemp); - if (NILP (tem)) + char number[INT_BUFSIZE_BOUND (ptrdiff_t) + sizeof "<>"]; + AUTO_STRING_WITH_LEN (lnumber, number, + sprintf (number, "<%"pD"d>", count)); + Lisp_Object gentemp = concat2 (genbase, lnumber); + if (!NILP (Fstring_equal (gentemp, ignore)) + || NILP (Fget_buffer (gentemp))) return gentemp; } } @@ -1648,6 +1653,9 @@ cleaning up all windows currently displaying the buffer to be killed. */) if (!BUFFER_LIVE_P (b)) return Qnil; + if (thread_check_current_buffer (b)) + return Qnil; + /* Run hooks with the buffer to be killed the current buffer. */ { ptrdiff_t count = SPECPDL_INDEX (); @@ -1993,7 +2001,9 @@ the current buffer's major mode. */) function = BVAR (current_buffer, major_mode); } - if (NILP (function) || EQ (function, Qfundamental_mode)) + if (NILP (function)) /* If function is `fundamental-mode', allow it to run + so that `run-mode-hooks' and thus + `hack-local-variables' get run. */ return Qnil; count = SPECPDL_INDEX (); @@ -2001,7 +2011,7 @@ the current buffer's major mode. */) /* To select a nonfundamental mode, select the buffer temporarily and then call the mode function. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_current_buffer (); Fset_buffer (buffer); call0 (function); @@ -2024,9 +2034,6 @@ DEFUN ("current-buffer", Fcurrent_buffer, Scurrent_buffer, 0, 0, 0, void set_buffer_internal_1 (register struct buffer *b) { - register struct buffer *old_buf; - register Lisp_Object tail; - #ifdef USE_MMAP_FOR_BUFFERS if (b->text->beg == NULL) enlarge_buffer_text (b, 0); @@ -2035,6 +2042,17 @@ set_buffer_internal_1 (register struct buffer *b) if (current_buffer == b) return; + set_buffer_internal_2 (b); +} + +/* Like set_buffer_internal_1, but doesn't check whether B is already + the current buffer. Called upon switch of the current thread, see + post_acquire_global_lock. */ +void set_buffer_internal_2 (register struct buffer *b) +{ + register struct buffer *old_buf; + register Lisp_Object tail; + BUFFER_CHECK_INDIRECTION (b); old_buf = current_buffer; @@ -3562,8 +3580,8 @@ void fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end) { Lisp_Object overlay; - struct Lisp_Overlay *before_list IF_LINT (= NULL); - struct Lisp_Overlay *after_list IF_LINT (= NULL); + struct Lisp_Overlay *before_list; + struct Lisp_Overlay *after_list; /* These are either nil, indicating that before_list or after_list should be assigned, or the cons cell the cdr of which should be assigned. */ @@ -3710,7 +3728,7 @@ fix_overlays_before (struct buffer *bp, ptrdiff_t prev, ptrdiff_t pos) /* If parent is nil, replace overlays_before; otherwise, parent->next. */ struct Lisp_Overlay *tail = bp->overlays_before, *parent = NULL, *right_pair; Lisp_Object tem; - ptrdiff_t end IF_LINT (= 0); + ptrdiff_t end; /* After the insertion, the several overlays may be in incorrect order. The possibility is that, in the list `overlays_before', @@ -3917,7 +3935,8 @@ buffer. */) struct buffer *b, *ob = 0; Lisp_Object obuffer; ptrdiff_t count = SPECPDL_INDEX (); - ptrdiff_t n_beg, n_end, o_beg IF_LINT (= 0), o_end IF_LINT (= 0); + ptrdiff_t n_beg, n_end; + ptrdiff_t o_beg UNINIT, o_end UNINIT; CHECK_OVERLAY (overlay); if (NILP (buffer)) @@ -5279,7 +5298,7 @@ init_buffer (int initialized) if (NILP (BVAR (&buffer_defaults, enable_multibyte_characters))) Fset_buffer_multibyte (Qnil); - pwd = get_current_dir_name (); + pwd = emacs_get_current_dir_name (); if (!pwd) { @@ -5418,144 +5437,6 @@ syms_of_buffer (void) Fput (Qprotected_field, Qerror_message, build_pure_c_string ("Attempt to modify a protected field")); - DEFVAR_BUFFER_DEFAULTS ("default-mode-line-format", - mode_line_format, - doc: /* Default value of `mode-line-format' for buffers that don't override it. -This is the same as (default-value \\='mode-line-format). */); - - DEFVAR_BUFFER_DEFAULTS ("default-header-line-format", - header_line_format, - doc: /* Default value of `header-line-format' for buffers that don't override it. -This is the same as (default-value \\='header-line-format). */); - - DEFVAR_BUFFER_DEFAULTS ("default-cursor-type", cursor_type, - doc: /* Default value of `cursor-type' for buffers that don't override it. -This is the same as (default-value \\='cursor-type). */); - - DEFVAR_BUFFER_DEFAULTS ("default-line-spacing", - extra_line_spacing, - doc: /* Default value of `line-spacing' for buffers that don't override it. -This is the same as (default-value \\='line-spacing). */); - - DEFVAR_BUFFER_DEFAULTS ("default-cursor-in-non-selected-windows", - cursor_in_non_selected_windows, - doc: /* Default value of `cursor-in-non-selected-windows'. -This is the same as (default-value \\='cursor-in-non-selected-windows). */); - - DEFVAR_BUFFER_DEFAULTS ("default-abbrev-mode", - abbrev_mode, - doc: /* Default value of `abbrev-mode' for buffers that do not override it. -This is the same as (default-value \\='abbrev-mode). */); - - DEFVAR_BUFFER_DEFAULTS ("default-ctl-arrow", - ctl_arrow, - doc: /* Default value of `ctl-arrow' for buffers that do not override it. -This is the same as (default-value \\='ctl-arrow). */); - - DEFVAR_BUFFER_DEFAULTS ("default-enable-multibyte-characters", - enable_multibyte_characters, - doc: /* Default value of `enable-multibyte-characters' for buffers not overriding it. -This is the same as (default-value \\='enable-multibyte-characters). */); - - DEFVAR_BUFFER_DEFAULTS ("default-buffer-file-coding-system", - buffer_file_coding_system, - doc: /* Default value of `buffer-file-coding-system' for buffers not overriding it. -This is the same as (default-value \\='buffer-file-coding-system). */); - - DEFVAR_BUFFER_DEFAULTS ("default-truncate-lines", - truncate_lines, - doc: /* Default value of `truncate-lines' for buffers that do not override it. -This is the same as (default-value \\='truncate-lines). */); - - DEFVAR_BUFFER_DEFAULTS ("default-fill-column", - fill_column, - doc: /* Default value of `fill-column' for buffers that do not override it. -This is the same as (default-value \\='fill-column). */); - - DEFVAR_BUFFER_DEFAULTS ("default-left-margin", - left_margin, - doc: /* Default value of `left-margin' for buffers that do not override it. -This is the same as (default-value \\='left-margin). */); - - DEFVAR_BUFFER_DEFAULTS ("default-tab-width", - tab_width, - doc: /* Default value of `tab-width' for buffers that do not override it. -NOTE: This controls the display width of a TAB character, and not -the size of an indentation step. -This is the same as (default-value \\='tab-width). */); - - DEFVAR_BUFFER_DEFAULTS ("default-case-fold-search", - case_fold_search, - doc: /* Default value of `case-fold-search' for buffers that don't override it. -This is the same as (default-value \\='case-fold-search). */); - - DEFVAR_BUFFER_DEFAULTS ("default-left-margin-width", - left_margin_cols, - doc: /* Default value of `left-margin-width' for buffers that don't override it. -This is the same as (default-value \\='left-margin-width). */); - - DEFVAR_BUFFER_DEFAULTS ("default-right-margin-width", - right_margin_cols, - doc: /* Default value of `right-margin-width' for buffers that don't override it. -This is the same as (default-value \\='right-margin-width). */); - - DEFVAR_BUFFER_DEFAULTS ("default-left-fringe-width", - left_fringe_width, - doc: /* Default value of `left-fringe-width' for buffers that don't override it. -This is the same as (default-value \\='left-fringe-width). */); - - DEFVAR_BUFFER_DEFAULTS ("default-right-fringe-width", - right_fringe_width, - doc: /* Default value of `right-fringe-width' for buffers that don't override it. -This is the same as (default-value \\='right-fringe-width). */); - - DEFVAR_BUFFER_DEFAULTS ("default-fringes-outside-margins", - fringes_outside_margins, - doc: /* Default value of `fringes-outside-margins' for buffers that don't override it. -This is the same as (default-value \\='fringes-outside-margins). */); - - DEFVAR_BUFFER_DEFAULTS ("default-scroll-bar-width", - scroll_bar_width, - doc: /* Default value of `scroll-bar-width' for buffers that don't override it. -This is the same as (default-value \\='scroll-bar-width). */); - - DEFVAR_BUFFER_DEFAULTS ("default-vertical-scroll-bar", - vertical_scroll_bar_type, - doc: /* Default value of `vertical-scroll-bar' for buffers that don't override it. -This is the same as (default-value \\='vertical-scroll-bar). */); - - DEFVAR_BUFFER_DEFAULTS ("default-indicate-empty-lines", - indicate_empty_lines, - doc: /* Default value of `indicate-empty-lines' for buffers that don't override it. -This is the same as (default-value \\='indicate-empty-lines). */); - - DEFVAR_BUFFER_DEFAULTS ("default-indicate-buffer-boundaries", - indicate_buffer_boundaries, - doc: /* Default value of `indicate-buffer-boundaries' for buffers that don't override it. -This is the same as (default-value \\='indicate-buffer-boundaries). */); - - DEFVAR_BUFFER_DEFAULTS ("default-fringe-indicator-alist", - fringe_indicator_alist, - doc: /* Default value of `fringe-indicator-alist' for buffers that don't override it. -This is the same as (default-value \\='fringe-indicator-alist). */); - - DEFVAR_BUFFER_DEFAULTS ("default-fringe-cursor-alist", - fringe_cursor_alist, - doc: /* Default value of `fringe-cursor-alist' for buffers that don't override it. -This is the same as (default-value \\='fringe-cursor-alist). */); - - DEFVAR_BUFFER_DEFAULTS ("default-scroll-up-aggressively", - scroll_up_aggressively, - doc: /* Default value of `scroll-up-aggressively'. -This value applies in buffers that don't have their own local values. -This is the same as (default-value \\='scroll-up-aggressively). */); - - DEFVAR_BUFFER_DEFAULTS ("default-scroll-down-aggressively", - scroll_down_aggressively, - doc: /* Default value of `scroll-down-aggressively'. -This value applies in buffers that don't have their own local values. -This is the same as (default-value \\='scroll-down-aggressively). */); - DEFVAR_PER_BUFFER ("header-line-format", &BVAR (current_buffer, header_line_format), Qnil, @@ -5626,9 +5507,6 @@ A string is printed verbatim in the mode line except for %-constructs: %% -- print %. %- -- print infinitely many dashes. Decimal digits after the % specify field width to which to pad. */); - DEFVAR_BUFFER_DEFAULTS ("default-major-mode", major_mode, - doc: /* Value of `major-mode' for new buffers. */); - DEFVAR_PER_BUFFER ("major-mode", &BVAR (current_buffer, major_mode), Qsymbolp, doc: /* Symbol for current buffer's major mode. @@ -5687,7 +5565,7 @@ file I/O and the behavior of various editing commands. This variable is buffer-local but you cannot set it directly; use the function `set-buffer-multibyte' to change a buffer's representation. See also Info node `(elisp)Text Representations'. */); - XSYMBOL (intern_c_string ("enable-multibyte-characters"))->constant = 1; + make_symbol_constant (intern_c_string ("enable-multibyte-characters")); DEFVAR_PER_BUFFER ("buffer-file-coding-system", &BVAR (current_buffer, buffer_file_coding_system), Qnil, diff --git a/src/buffer.h b/src/buffer.h index a53ef12f35e..e2f94f1501b 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -881,6 +881,25 @@ struct buffer Lisp_Object undo_list_; }; +INLINE bool +BUFFERP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_BUFFER); +} + +INLINE void +CHECK_BUFFER (Lisp_Object x) +{ + CHECK_TYPE (BUFFERP (x), Qbufferp, x); +} + +INLINE struct buffer * +XBUFFER (Lisp_Object a) +{ + eassert (BUFFERP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + /* Most code should use these functions to set Lisp fields in struct buffer. (Some setters that are private to a single .c file are defined as static in those files.) */ @@ -1040,10 +1059,6 @@ extern struct buffer *all_buffers; #define FOR_EACH_BUFFER(b) \ for ((b) = all_buffers; (b); (b) = (b)->next) -/* This points to the current buffer. */ - -extern struct buffer *current_buffer; - /* This structure holds the default values of the buffer-local variables that have special slots in each buffer. The default value occupies the same slot in this structure @@ -1086,6 +1101,7 @@ extern void recenter_overlay_lists (struct buffer *, ptrdiff_t); extern ptrdiff_t overlay_strings (ptrdiff_t, struct window *, unsigned char **); extern void validate_region (Lisp_Object *, Lisp_Object *); extern void set_buffer_internal_1 (struct buffer *); +extern void set_buffer_internal_2 (struct buffer *); extern void set_buffer_temp (struct buffer *); extern Lisp_Object buffer_local_value (Lisp_Object, Lisp_Object); extern void record_buffer (Lisp_Object); @@ -1187,8 +1203,7 @@ buffer_has_overlays (void) INLINE int FETCH_MULTIBYTE_CHAR (ptrdiff_t pos) { - unsigned char *p = ((pos >= GPT_BYTE ? GAP_SIZE : 0) - + pos + BEG_ADDR - BEG_BYTE); + unsigned char *p = BYTE_POS_ADDR (pos); return STRING_CHAR (p); } diff --git a/src/bytecode.c b/src/bytecode.c index 9ae2e820d51..3bb96c2ed2d 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -17,22 +17,6 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ -/* -hacked on by jwz@lucid.com 17-jun-91 - o added a compile-time switch to turn on simple sanity checking; - o put back the obsolete byte-codes for error-detection; - o added a new instruction, unbind_all, which I will use for - tail-recursion elimination; - o made temp_output_buffer_show be called with the right number - of args; - o made the new bytecodes be called with args in the right order; - o added metering support. - -by Hallvard: - o added relative jump instructions; - o all conditionals now only do QUIT if they jump. - */ - #include <config.h> #include "lisp.h" @@ -43,33 +27,35 @@ by Hallvard: #include "syntax.h" #include "window.h" -#ifdef CHECK_FRAME_FONT -#include "frame.h" -#include "xterm.h" +/* Work around GCC bug 54561. */ +#if GNUC_PREREQ (4, 3, 0) +# pragma GCC diagnostic ignored "-Wclobbered" +#endif + +/* Define BYTE_CODE_SAFE true to enable some minor sanity checking, + useful for debugging the byte compiler. It defaults to false. */ + +#ifndef BYTE_CODE_SAFE +# define BYTE_CODE_SAFE false #endif -/* - * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for - * debugging the byte compiler...) - * - * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. - */ -/* #define BYTE_CODE_SAFE */ +/* Define BYTE_CODE_METER to generate a byte-op usage histogram. */ /* #define BYTE_CODE_METER */ /* If BYTE_CODE_THREADED is defined, then the interpreter will be indirect threaded, using GCC's computed goto extension. This code, as currently implemented, is incompatible with BYTE_CODE_SAFE and BYTE_CODE_METER. */ -#if (defined __GNUC__ && !defined __STRICT_ANSI__ \ - && !defined BYTE_CODE_SAFE && !defined BYTE_CODE_METER) +#if (defined __GNUC__ && !defined __STRICT_ANSI__ && !defined __CHKP__ \ + && !BYTE_CODE_SAFE && !defined BYTE_CODE_METER) #define BYTE_CODE_THREADED #endif #ifdef BYTE_CODE_METER -#define METER_2(code1, code2) AREF (AREF (Vbyte_code_meter, code1), code2) +#define METER_2(code1, code2) \ + (*aref_addr (AREF (Vbyte_code_meter, code1), code2)) #define METER_1(code) METER_2 (0, code) #define METER_CODE(last_code, this_code) \ @@ -289,87 +275,25 @@ enum byte_code_op BYTE_CODES #undef DEFINE -#ifdef BYTE_CODE_SAFE +#if BYTE_CODE_SAFE Bscan_buffer = 0153, /* No longer generated as of v18. */ Bset_mark = 0163, /* this loser is no longer generated as of v18 */ #endif }; - -/* Whether to maintain a `top' and `bottom' field in the stack frame. */ -#define BYTE_MAINTAIN_TOP BYTE_CODE_SAFE - -/* Structure describing a value stack used during byte-code execution - in Fbyte_code. */ - -struct byte_stack -{ - /* Program counter. This points into the byte_string below - and is relocated when that string is relocated. */ - const unsigned char *pc; - - /* Top and bottom of stack. The bottom points to an area of memory - allocated with alloca in Fbyte_code. */ -#if BYTE_MAINTAIN_TOP - Lisp_Object *top, *bottom; -#endif - - /* The string containing the byte-code, and its current address. - Storing this here protects it from GC because mark_byte_stack - marks it. */ - Lisp_Object byte_string; - const unsigned char *byte_string_start; - - /* Next entry in byte_stack_list. */ - struct byte_stack *next; -}; - -/* A list of currently active byte-code execution value stacks. - Fbyte_code adds an entry to the head of this list before it starts - processing byte-code, and it removes the entry again when it is - done. Signaling an error truncates the list. */ - -struct byte_stack *byte_stack_list; - - -/* Relocate program counters in the stacks on byte_stack_list. Called - when GC has completed. */ - -void -relocate_byte_stack (void) -{ - struct byte_stack *stack; - - for (stack = byte_stack_list; stack; stack = stack->next) - { - if (stack->byte_string_start != SDATA (stack->byte_string)) - { - ptrdiff_t offset = stack->pc - stack->byte_string_start; - stack->byte_string_start = SDATA (stack->byte_string); - stack->pc = stack->byte_string_start + offset; - } - } -} - /* Fetch the next byte from the bytecode stream. */ -#ifdef BYTE_CODE_SAFE -#define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++) -#else -#define FETCH *stack.pc++ -#endif +#define FETCH (*pc++) /* Fetch two bytes from the bytecode stream and make a 16-bit number out of them. */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) -/* Push x onto the execution stack. This used to be #define PUSH(x) - (*++stackp = (x)) This oddity is necessary because Alliant can't be - bothered to compile the preincrement operator properly, as of 4/91. - -JimB */ +/* Push X onto the execution stack. The expression X should not + contain TOP, to avoid competing side effects. */ -#define PUSH(x) (top++, *top = (x)) +#define PUSH(x) (*++top = (x)) /* Pop a value off the execution stack. */ @@ -384,60 +308,6 @@ relocate_byte_stack (void) #define TOP (*top) -/* Actions that must be performed before and after calling a function - that might GC. */ - -#if !BYTE_MAINTAIN_TOP -#define BEFORE_POTENTIAL_GC() ((void)0) -#define AFTER_POTENTIAL_GC() ((void)0) -#else -#define BEFORE_POTENTIAL_GC() stack.top = top -#define AFTER_POTENTIAL_GC() stack.top = NULL -#endif - -/* Garbage collect if we have consed enough since the last time. - We do this at every branch, to avoid loops that never GC. */ - -#define MAYBE_GC() \ - do { \ - BEFORE_POTENTIAL_GC (); \ - maybe_gc (); \ - AFTER_POTENTIAL_GC (); \ - } while (0) - -/* Check for jumping out of range. */ - -#ifdef BYTE_CODE_SAFE - -#define CHECK_RANGE(ARG) \ - if (ARG >= bytestr_length) emacs_abort () - -#else /* not BYTE_CODE_SAFE */ - -#define CHECK_RANGE(ARG) - -#endif /* not BYTE_CODE_SAFE */ - -/* A version of the QUIT macro which makes sure that the stack top is - set before signaling `quit'. */ - -#define BYTE_CODE_QUIT \ - do { \ - if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \ - { \ - Lisp_Object flag = Vquit_flag; \ - Vquit_flag = Qnil; \ - BEFORE_POTENTIAL_GC (); \ - if (EQ (Vthrow_on_input, flag)) \ - Fthrow (Vthrow_on_input, Qt); \ - Fsignal (Qquit, Qnil); \ - AFTER_POTENTIAL_GC (); \ - } \ - else if (pending_signals) \ - process_pending_signals (); \ - } while (0) - - DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, doc: /* Function used internally in byte-compiled code. The first argument, BYTESTR, is a string of byte code; @@ -467,41 +337,15 @@ Lisp_Object exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args) { - ptrdiff_t count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER int volatile this_op = 0; - int prev_op; -#endif - int op; - /* Lisp_Object v1, v2; */ - Lisp_Object *vectorp; -#ifdef BYTE_CODE_SAFE - ptrdiff_t const_length; - Lisp_Object *stacke; - ptrdiff_t bytestr_length; -#endif - struct byte_stack stack; - Lisp_Object *top; - Lisp_Object result; - enum handlertype type; - -#if 0 /* CHECK_FRAME_FONT */ - { - struct frame *f = SELECTED_FRAME (); - if (FRAME_X_P (f) - && FRAME_FONT (f)->direction != 0 - && FRAME_FONT (f)->direction != 1) - emacs_abort (); - } #endif CHECK_STRING (bytestr); CHECK_VECTOR (vector); CHECK_NATNUM (maxdepth); -#ifdef BYTE_CODE_SAFE - const_length = ASIZE (vector); -#endif + ptrdiff_t const_length = ASIZE (vector); if (STRING_MULTIBYTE (bytestr)) /* BYTESTR must have been produced by Emacs 20.2 or the earlier @@ -511,90 +355,59 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, convert them back to the originally intended unibyte form. */ bytestr = Fstring_as_unibyte (bytestr); -#ifdef BYTE_CODE_SAFE - bytestr_length = SBYTES (bytestr); -#endif - vectorp = XVECTOR (vector)->contents; - - stack.byte_string = bytestr; - stack.pc = stack.byte_string_start = SDATA (bytestr); - if (MAX_ALLOCA / word_size <= XFASTINT (maxdepth)) - memory_full (SIZE_MAX); - top = alloca ((XFASTINT (maxdepth) + 1) * sizeof *top); -#if BYTE_MAINTAIN_TOP - stack.bottom = top + 1; - stack.top = NULL; -#endif - stack.next = byte_stack_list; - byte_stack_list = &stack; - -#ifdef BYTE_CODE_SAFE - stacke = stack.bottom - 1 + XFASTINT (maxdepth); -#endif + ptrdiff_t bytestr_length = SBYTES (bytestr); + Lisp_Object *vectorp = XVECTOR (vector)->contents; + + unsigned char quitcounter = 1; + EMACS_INT stack_items = XFASTINT (maxdepth) + 1; + USE_SAFE_ALLOCA; + Lisp_Object *stack_base; + SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length); + Lisp_Object *stack_lim = stack_base + stack_items; + Lisp_Object *top = stack_base; + memcpy (stack_lim, SDATA (bytestr), bytestr_length); + void *void_stack_lim = stack_lim; + unsigned char const *bytestr_data = void_stack_lim; + unsigned char const *pc = bytestr_data; + ptrdiff_t count = SPECPDL_INDEX (); - if (INTEGERP (args_template)) + if (!NILP (args_template)) { + eassert (INTEGERP (args_template)); ptrdiff_t at = XINT (args_template); bool rest = (at & 128) != 0; int mandatory = at & 127; ptrdiff_t nonrest = at >> 8; - eassert (mandatory <= nonrest); - if (nargs <= nonrest) - { - ptrdiff_t i; - for (i = 0 ; i < nargs; i++, args++) - PUSH (*args); - if (nargs < mandatory) - /* Too few arguments. */ - Fsignal (Qwrong_number_of_arguments, - list2 (Fcons (make_number (mandatory), - rest ? Qand_rest : make_number (nonrest)), - make_number (nargs))); - else - { - for (; i < nonrest; i++) - PUSH (Qnil); - if (rest) - PUSH (Qnil); - } - } - else if (rest) - { - ptrdiff_t i; - for (i = 0 ; i < nonrest; i++, args++) - PUSH (*args); - PUSH (Flist (nargs - nonrest, args)); - } - else - /* Too many arguments. */ + ptrdiff_t maxargs = rest ? PTRDIFF_MAX : nonrest; + if (! (mandatory <= nargs && nargs <= maxargs)) Fsignal (Qwrong_number_of_arguments, list2 (Fcons (make_number (mandatory), make_number (nonrest)), make_number (nargs))); - } - else if (! NILP (args_template)) - /* We should push some arguments on the stack. */ - { - error ("Unknown args template!"); + ptrdiff_t pushedargs = min (nonrest, nargs); + for (ptrdiff_t i = 0; i < pushedargs; i++, args++) + PUSH (*args); + if (nonrest < nargs) + PUSH (Flist (nargs - nonrest, args)); + else + for (ptrdiff_t i = nargs - rest; i < nonrest; i++) + PUSH (Qnil); } - while (1) + while (true) { -#ifdef BYTE_CODE_SAFE - if (top > stacke) - emacs_abort (); - else if (top < stack.bottom - 1) + int op; + enum handlertype type; + + if (BYTE_CODE_SAFE && ! (stack_base <= top && top < stack_lim)) emacs_abort (); -#endif #ifdef BYTE_CODE_METER - prev_op = this_op; + int prev_op = this_op; this_op = op = FETCH; METER_CODE (prev_op, op); -#else -#ifndef BYTE_CODE_THREADED +#elif !defined BYTE_CODE_THREADED op = FETCH; #endif -#endif /* The interpreter can be compiled one of two ways: as an ordinary switch-based interpreter, or as a threaded @@ -637,7 +450,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, the table clearer. */ #define LABEL(OP) [OP] = &&insn_ ## OP -#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +#if GNUC_PREREQ (4, 6, 0) # pragma GCC diagnostic push # pragma GCC diagnostic ignored "-Woverride-init" #elif defined __clang__ @@ -656,7 +469,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #undef DEFINE }; -#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) || defined __clang__ +#if GNUC_PREREQ (4, 6, 0) || defined __clang__ # pragma GCC diagnostic pop #endif @@ -675,7 +488,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bvarref3): CASE (Bvarref4): CASE (Bvarref5): - op = op - Bvarref; + op -= Bvarref; goto varref; /* This seems to be the most frequently executed byte-code @@ -684,92 +497,51 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, op = FETCH; varref: { - Lisp_Object v1, v2; - - v1 = vectorp[op]; - if (SYMBOLP (v1)) - { - if (XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL - || (v2 = SYMBOL_VAL (XSYMBOL (v1)), - EQ (v2, Qunbound))) - { - BEFORE_POTENTIAL_GC (); - v2 = Fsymbol_value (v1); - AFTER_POTENTIAL_GC (); - } - } - else - { - BEFORE_POTENTIAL_GC (); - v2 = Fsymbol_value (v1); - AFTER_POTENTIAL_GC (); - } + Lisp_Object v1 = vectorp[op], v2; + if (!SYMBOLP (v1) + || XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL + || (v2 = SYMBOL_VAL (XSYMBOL (v1)), EQ (v2, Qunbound))) + v2 = Fsymbol_value (v1); PUSH (v2); NEXT; } CASE (Bgotoifnil): { - Lisp_Object v1; - MAYBE_GC (); + Lisp_Object v1 = POP; op = FETCH2; - v1 = POP; if (NILP (v1)) - { - BYTE_CODE_QUIT; - CHECK_RANGE (op); - stack.pc = stack.byte_string_start + op; - } + goto op_branch; NEXT; } CASE (Bcar): - { - Lisp_Object v1; - v1 = TOP; - if (CONSP (v1)) - TOP = XCAR (v1); - else if (NILP (v1)) - TOP = Qnil; - else - { - BEFORE_POTENTIAL_GC (); - wrong_type_argument (Qlistp, v1); - } - NEXT; - } + if (CONSP (TOP)) + TOP = XCAR (TOP); + else if (!NILP (TOP)) + wrong_type_argument (Qlistp, TOP); + NEXT; CASE (Beq): { - Lisp_Object v1; - v1 = POP; + Lisp_Object v1 = POP; TOP = EQ (v1, TOP) ? Qt : Qnil; NEXT; } CASE (Bmemq): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fmemq (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bcdr): { - Lisp_Object v1; - v1 = TOP; - if (CONSP (v1)) - TOP = XCDR (v1); - else if (NILP (v1)) - TOP = Qnil; - else - { - BEFORE_POTENTIAL_GC (); - wrong_type_argument (Qlistp, v1); - } + if (CONSP (TOP)) + TOP = XCDR (TOP); + else if (!NILP (TOP)) + wrong_type_argument (Qlistp, TOP); NEXT; } @@ -790,31 +562,23 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, op = FETCH; varset: { - Lisp_Object sym, val; - - sym = vectorp[op]; - val = TOP; + Lisp_Object sym = vectorp[op]; + Lisp_Object val = POP; /* Inline the most common case. */ if (SYMBOLP (sym) && !EQ (val, Qunbound) && !XSYMBOL (sym)->redirect - && !SYMBOL_CONSTANT_P (sym)) + && !SYMBOL_TRAPPED_WRITE_P (sym)) SET_SYMBOL_VAL (XSYMBOL (sym), val); else - { - BEFORE_POTENTIAL_GC (); - set_internal (sym, val, Qnil, 0); - AFTER_POTENTIAL_GC (); - } + set_internal (sym, val, Qnil, SET_INTERNAL_SET); } - (void) POP; NEXT; CASE (Bdup): { - Lisp_Object v1; - v1 = TOP; + Lisp_Object v1 = TOP; PUSH (v1); NEXT; } @@ -838,9 +602,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, op -= Bvarbind; varbind: /* Specbind can signal and thus GC. */ - BEFORE_POTENTIAL_GC (); specbind (vectorp[op], POP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bcall6): @@ -860,15 +622,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, op -= Bcall; docall: { - BEFORE_POTENTIAL_GC (); DISCARD (op); #ifdef BYTE_CODE_METER if (byte_metering_on && SYMBOLP (TOP)) { - Lisp_Object v1, v2; - - v1 = TOP; - v2 = Fget (v1, Qbyte_code_meter); + Lisp_Object v1 = TOP; + Lisp_Object v2 = Fget (v1, Qbyte_code_meter); if (INTEGERP (v2) && XINT (v2) < MOST_POSITIVE_FIXNUM) { @@ -878,7 +637,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } #endif TOP = Ffuncall (op + 1, &TOP); - AFTER_POTENTIAL_GC (); NEXT; } @@ -898,124 +656,85 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bunbind5): op -= Bunbind; dounbind: - BEFORE_POTENTIAL_GC (); unbind_to (SPECPDL_INDEX () - op, Qnil); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bunbind_all): /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, but will be needed for tail-recursion elimination. */ - BEFORE_POTENTIAL_GC (); unbind_to (count, Qnil); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bgoto): - MAYBE_GC (); - BYTE_CODE_QUIT; - op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */ - CHECK_RANGE (op); - stack.pc = stack.byte_string_start + op; + op = FETCH2; + op_branch: + op -= pc - bytestr_data; + op_relative_branch: + if (BYTE_CODE_SAFE + && ! (bytestr_data - pc <= op + && op < bytestr_data + bytestr_length - pc)) + emacs_abort (); + quitcounter += op < 0; + if (!quitcounter) + { + quitcounter = 1; + maybe_gc (); + QUIT; + } + pc += op; NEXT; CASE (Bgotoifnonnil): - { - Lisp_Object v1; - MAYBE_GC (); - op = FETCH2; - v1 = POP; - if (!NILP (v1)) - { - BYTE_CODE_QUIT; - CHECK_RANGE (op); - stack.pc = stack.byte_string_start + op; - } - NEXT; - } + op = FETCH2; + if (!NILP (POP)) + goto op_branch; + NEXT; CASE (Bgotoifnilelsepop): - MAYBE_GC (); op = FETCH2; if (NILP (TOP)) - { - BYTE_CODE_QUIT; - CHECK_RANGE (op); - stack.pc = stack.byte_string_start + op; - } - else DISCARD (1); + goto op_branch; + DISCARD (1); NEXT; CASE (Bgotoifnonnilelsepop): - MAYBE_GC (); op = FETCH2; if (!NILP (TOP)) - { - BYTE_CODE_QUIT; - CHECK_RANGE (op); - stack.pc = stack.byte_string_start + op; - } - else DISCARD (1); + goto op_branch; + DISCARD (1); NEXT; CASE (BRgoto): - MAYBE_GC (); - BYTE_CODE_QUIT; - stack.pc += (int) *stack.pc - 127; - NEXT; + op = FETCH - 128; + goto op_relative_branch; CASE (BRgotoifnil): - { - Lisp_Object v1; - MAYBE_GC (); - v1 = POP; - if (NILP (v1)) - { - BYTE_CODE_QUIT; - stack.pc += (int) *stack.pc - 128; - } - stack.pc++; - NEXT; - } + op = FETCH - 128; + if (NILP (POP)) + goto op_relative_branch; + NEXT; CASE (BRgotoifnonnil): - { - Lisp_Object v1; - MAYBE_GC (); - v1 = POP; - if (!NILP (v1)) - { - BYTE_CODE_QUIT; - stack.pc += (int) *stack.pc - 128; - } - stack.pc++; - NEXT; - } + op = FETCH - 128; + if (!NILP (POP)) + goto op_relative_branch; + NEXT; CASE (BRgotoifnilelsepop): - MAYBE_GC (); - op = *stack.pc++; + op = FETCH - 128; if (NILP (TOP)) - { - BYTE_CODE_QUIT; - stack.pc += op - 128; - } - else DISCARD (1); + goto op_relative_branch; + DISCARD (1); NEXT; CASE (BRgotoifnonnilelsepop): - MAYBE_GC (); - op = *stack.pc++; + op = FETCH - 128; if (!NILP (TOP)) - { - BYTE_CODE_QUIT; - stack.pc += op - 128; - } - else DISCARD (1); + goto op_relative_branch; + DISCARD (1); NEXT; CASE (Breturn): - result = POP; goto exit; CASE (Bdiscard): @@ -1041,10 +760,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ptrdiff_t count1 = SPECPDL_INDEX (); record_unwind_protect (restore_window_configuration, Fcurrent_window_configuration (Qnil)); - BEFORE_POTENTIAL_GC (); TOP = Fprogn (TOP); unbind_to (count1, TOP); - AFTER_POTENTIAL_GC (); NEXT; } @@ -1055,11 +772,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bcatch): /* Obsolete since 24.4. */ { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = internal_catch (TOP, eval_sub, v1); - AFTER_POTENTIAL_GC (); NEXT; } @@ -1070,93 +784,69 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, type = CONDITION_CASE; pushhandler: { - Lisp_Object tag = POP; - int dest = FETCH2; - - struct handler *c = push_handler (tag, type); - c->bytecode_dest = dest; + struct handler *c = push_handler (POP, type); + c->bytecode_dest = FETCH2; c->bytecode_top = top; if (sys_setjmp (c->jmp)) { struct handler *c = handlerlist; - int dest; top = c->bytecode_top; - dest = c->bytecode_dest; + op = c->bytecode_dest; handlerlist = c->next; PUSH (c->val); - CHECK_RANGE (dest); - /* Might have been re-set by longjmp! */ - stack.byte_string_start = SDATA (stack.byte_string); - stack.pc = stack.byte_string_start + dest; + goto op_branch; } NEXT; } CASE (Bpophandler): /* New in 24.4. */ - { - handlerlist = handlerlist->next; - NEXT; - } + handlerlist = handlerlist->next; + NEXT; CASE (Bunwind_protect): /* FIXME: avoid closure for lexbind. */ { Lisp_Object handler = POP; /* Support for a function here is new in 24.4. */ - record_unwind_protect (NILP (Ffunctionp (handler)) - ? unwind_body : bcall0, + record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore, handler); NEXT; } CASE (Bcondition_case): /* Obsolete since 24.4. */ { - Lisp_Object handlers, body; - handlers = POP; - body = POP; - BEFORE_POTENTIAL_GC (); + Lisp_Object handlers = POP, body = POP; TOP = internal_lisp_condition_case (TOP, body, handlers); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Btemp_output_buffer_setup): /* Obsolete since 24.1. */ - BEFORE_POTENTIAL_GC (); CHECK_STRING (TOP); temp_output_buffer_setup (SSDATA (TOP)); - AFTER_POTENTIAL_GC (); TOP = Vstandard_output; NEXT; CASE (Btemp_output_buffer_show): /* Obsolete since 24.1. */ { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; temp_output_buffer_show (TOP); TOP = v1; /* pop binding of standard-output */ unbind_to (SPECPDL_INDEX () - 1, Qnil); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bnth): { - Lisp_Object v1, v2; - EMACS_INT n; - BEFORE_POTENTIAL_GC (); - v1 = POP; - v2 = TOP; - CHECK_NUMBER (v2); - n = XINT (v2); - immediate_quit = 1; - while (--n >= 0 && CONSP (v1)) - v1 = XCDR (v1); - immediate_quit = 0; - TOP = CAR (v1); - AFTER_POTENTIAL_GC (); + Lisp_Object v2 = POP, v1 = TOP; + CHECK_NUMBER (v1); + EMACS_INT n = XINT (v1); + immediate_quit = true; + while (--n >= 0 && CONSP (v2)) + v2 = XCDR (v2); + immediate_quit = false; + TOP = CAR (v2); NEXT; } @@ -1182,8 +872,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bcons): { - Lisp_Object v1; - v1 = POP; + Lisp_Object v1 = POP; TOP = Fcons (TOP, v1); NEXT; } @@ -1194,8 +883,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Blist2): { - Lisp_Object v1; - v1 = POP; + Lisp_Object v1 = POP; TOP = list2 (TOP, v1); NEXT; } @@ -1217,305 +905,191 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Blength): - BEFORE_POTENTIAL_GC (); TOP = Flength (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Baref): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Faref (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Baset): { - Lisp_Object v1, v2; - BEFORE_POTENTIAL_GC (); - v2 = POP; v1 = POP; + Lisp_Object v2 = POP, v1 = POP; TOP = Faset (TOP, v1, v2); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bsymbol_value): - BEFORE_POTENTIAL_GC (); TOP = Fsymbol_value (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bsymbol_function): - BEFORE_POTENTIAL_GC (); TOP = Fsymbol_function (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bset): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fset (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bfset): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Ffset (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bget): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fget (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bsubstring): { - Lisp_Object v1, v2; - BEFORE_POTENTIAL_GC (); - v2 = POP; v1 = POP; + Lisp_Object v2 = POP, v1 = POP; TOP = Fsubstring (TOP, v1, v2); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bconcat2): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Fconcat (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bconcat3): - BEFORE_POTENTIAL_GC (); DISCARD (2); TOP = Fconcat (3, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bconcat4): - BEFORE_POTENTIAL_GC (); DISCARD (3); TOP = Fconcat (4, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (BconcatN): op = FETCH; - BEFORE_POTENTIAL_GC (); DISCARD (op - 1); TOP = Fconcat (op, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bsub1): - { - Lisp_Object v1; - v1 = TOP; - if (INTEGERP (v1)) - { - XSETINT (v1, XINT (v1) - 1); - TOP = v1; - } - else - { - BEFORE_POTENTIAL_GC (); - TOP = Fsub1 (v1); - AFTER_POTENTIAL_GC (); - } - NEXT; - } + TOP = INTEGERP (TOP) ? make_number (XINT (TOP) - 1) : Fsub1 (TOP); + NEXT; CASE (Badd1): - { - Lisp_Object v1; - v1 = TOP; - if (INTEGERP (v1)) - { - XSETINT (v1, XINT (v1) + 1); - TOP = v1; - } - else - { - BEFORE_POTENTIAL_GC (); - TOP = Fadd1 (v1); - AFTER_POTENTIAL_GC (); - } - NEXT; - } + TOP = INTEGERP (TOP) ? make_number (XINT (TOP) + 1) : Fadd1 (TOP); + NEXT; CASE (Beqlsign): { - Lisp_Object v1, v2; - BEFORE_POTENTIAL_GC (); - v2 = POP; v1 = TOP; + Lisp_Object v2 = POP, v1 = TOP; CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1); CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2); - AFTER_POTENTIAL_GC (); + bool equal; if (FLOATP (v1) || FLOATP (v2)) { - double f1, f2; - - f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1)); - f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2)); - TOP = (f1 == f2 ? Qt : Qnil); + double f1 = FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1); + double f2 = FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2); + equal = f1 == f2; } else - TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil); + equal = XINT (v1) == XINT (v2); + TOP = equal ? Qt : Qnil; NEXT; } CASE (Bgtr): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = arithcompare (TOP, v1, ARITH_GRTR); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Blss): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = arithcompare (TOP, v1, ARITH_LESS); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bleq): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bgeq): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bdiff): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Fminus (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bnegate): - { - Lisp_Object v1; - v1 = TOP; - if (INTEGERP (v1)) - { - XSETINT (v1, - XINT (v1)); - TOP = v1; - } - else - { - BEFORE_POTENTIAL_GC (); - TOP = Fminus (1, &TOP); - AFTER_POTENTIAL_GC (); - } - NEXT; - } + TOP = INTEGERP (TOP) ? make_number (- XINT (TOP)) : Fminus (1, &TOP); + NEXT; CASE (Bplus): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Fplus (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bmax): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Fmax (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bmin): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Fmin (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bmult): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Ftimes (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bquo): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Fquo (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Brem): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Frem (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bpoint): - { - Lisp_Object v1; - XSETFASTINT (v1, PT); - PUSH (v1); - NEXT; - } + PUSH (make_natnum (PT)); + NEXT; CASE (Bgoto_char): - BEFORE_POTENTIAL_GC (); TOP = Fgoto_char (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Binsert): - BEFORE_POTENTIAL_GC (); TOP = Finsert (1, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (BinsertN): op = FETCH; - BEFORE_POTENTIAL_GC (); DISCARD (op - 1); TOP = Finsert (op, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bpoint_max): @@ -1527,53 +1101,27 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } CASE (Bpoint_min): - { - Lisp_Object v1; - XSETFASTINT (v1, BEGV); - PUSH (v1); - NEXT; - } + PUSH (make_natnum (BEGV)); + NEXT; CASE (Bchar_after): - BEFORE_POTENTIAL_GC (); TOP = Fchar_after (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bfollowing_char): - { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = Ffollowing_char (); - AFTER_POTENTIAL_GC (); - PUSH (v1); - NEXT; - } + PUSH (Ffollowing_char ()); + NEXT; CASE (Bpreceding_char): - { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = Fprevious_char (); - AFTER_POTENTIAL_GC (); - PUSH (v1); - NEXT; - } + PUSH (Fprevious_char ()); + NEXT; CASE (Bcurrent_column): - { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - XSETFASTINT (v1, current_column ()); - AFTER_POTENTIAL_GC (); - PUSH (v1); - NEXT; - } + PUSH (make_natnum (current_column ())); + NEXT; CASE (Bindent_to): - BEFORE_POTENTIAL_GC (); TOP = Findent_to (TOP, Qnil); - AFTER_POTENTIAL_GC (); NEXT; CASE (Beolp): @@ -1597,63 +1145,43 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bset_buffer): - BEFORE_POTENTIAL_GC (); TOP = Fset_buffer (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Binteractive_p): /* Obsolete since 24.1. */ - BEFORE_POTENTIAL_GC (); PUSH (call0 (intern ("interactive-p"))); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bforward_char): - BEFORE_POTENTIAL_GC (); TOP = Fforward_char (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bforward_word): - BEFORE_POTENTIAL_GC (); TOP = Fforward_word (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bskip_chars_forward): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fskip_chars_forward (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bskip_chars_backward): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fskip_chars_backward (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bforward_line): - BEFORE_POTENTIAL_GC (); TOP = Fforward_line (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bchar_syntax): { - int c; - - BEFORE_POTENTIAL_GC (); CHECK_CHARACTER (TOP); - AFTER_POTENTIAL_GC (); - c = XFASTINT (TOP); + int c = XFASTINT (TOP); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) MAKE_CHAR_MULTIBYTE (c); XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]); @@ -1662,239 +1190,169 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bbuffer_substring): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fbuffer_substring (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bdelete_region): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fdelete_region (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bnarrow_to_region): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fnarrow_to_region (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bwiden): - BEFORE_POTENTIAL_GC (); PUSH (Fwiden ()); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bend_of_line): - BEFORE_POTENTIAL_GC (); TOP = Fend_of_line (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bset_marker): { - Lisp_Object v1, v2; - BEFORE_POTENTIAL_GC (); - v1 = POP; - v2 = POP; - TOP = Fset_marker (TOP, v2, v1); - AFTER_POTENTIAL_GC (); + Lisp_Object v2 = POP, v1 = POP; + TOP = Fset_marker (TOP, v1, v2); NEXT; } CASE (Bmatch_beginning): - BEFORE_POTENTIAL_GC (); TOP = Fmatch_beginning (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bmatch_end): - BEFORE_POTENTIAL_GC (); TOP = Fmatch_end (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bupcase): - BEFORE_POTENTIAL_GC (); TOP = Fupcase (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bdowncase): - BEFORE_POTENTIAL_GC (); TOP = Fdowncase (TOP); - AFTER_POTENTIAL_GC (); - NEXT; + NEXT; - CASE (Bstringeqlsign): + CASE (Bstringeqlsign): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fstring_equal (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bstringlss): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fstring_lessp (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bequal): { - Lisp_Object v1; - v1 = POP; + Lisp_Object v1 = POP; TOP = Fequal (TOP, v1); NEXT; } CASE (Bnthcdr): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fnthcdr (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Belt): { - Lisp_Object v1, v2; if (CONSP (TOP)) { /* Exchange args and then do nth. */ - EMACS_INT n; - BEFORE_POTENTIAL_GC (); - v2 = POP; - v1 = TOP; + Lisp_Object v2 = POP, v1 = TOP; CHECK_NUMBER (v2); - AFTER_POTENTIAL_GC (); - n = XINT (v2); - immediate_quit = 1; + EMACS_INT n = XINT (v2); + immediate_quit = true; while (--n >= 0 && CONSP (v1)) v1 = XCDR (v1); - immediate_quit = 0; + immediate_quit = false; TOP = CAR (v1); } else { - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Felt (TOP, v1); - AFTER_POTENTIAL_GC (); } NEXT; } CASE (Bmember): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fmember (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bassq): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fassq (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bnreverse): - BEFORE_POTENTIAL_GC (); TOP = Fnreverse (TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bsetcar): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fsetcar (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bsetcdr): { - Lisp_Object v1; - BEFORE_POTENTIAL_GC (); - v1 = POP; + Lisp_Object v1 = POP; TOP = Fsetcdr (TOP, v1); - AFTER_POTENTIAL_GC (); NEXT; } CASE (Bcar_safe): - { - Lisp_Object v1; - v1 = TOP; - TOP = CAR_SAFE (v1); - NEXT; - } + TOP = CAR_SAFE (TOP); + NEXT; CASE (Bcdr_safe): - { - Lisp_Object v1; - v1 = TOP; - TOP = CDR_SAFE (v1); - NEXT; - } + TOP = CDR_SAFE (TOP); + NEXT; CASE (Bnconc): - BEFORE_POTENTIAL_GC (); DISCARD (1); TOP = Fnconc (2, &TOP); - AFTER_POTENTIAL_GC (); NEXT; CASE (Bnumberp): - TOP = (NUMBERP (TOP) ? Qt : Qnil); + TOP = NUMBERP (TOP) ? Qt : Qnil; NEXT; CASE (Bintegerp): TOP = INTEGERP (TOP) ? Qt : Qnil; NEXT; -#ifdef BYTE_CODE_SAFE +#if BYTE_CODE_SAFE /* These are intentionally written using 'case' syntax, because they are incompatible with the threaded interpreter. */ case Bset_mark: - BEFORE_POTENTIAL_GC (); error ("set-mark is an obsolete bytecode"); - AFTER_POTENTIAL_GC (); break; case Bscan_buffer: - BEFORE_POTENTIAL_GC (); error ("scan-buffer is an obsolete bytecode"); - AFTER_POTENTIAL_GC (); break; #endif @@ -1905,7 +1363,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, call3 (Qerror, build_string ("Invalid byte opcode: op=%s, ptr=%d"), make_number (op), - make_number ((stack.pc - 1) - stack.byte_string_start)); + make_number (pc - 1 - bytestr_data)); /* Handy byte-codes for lexical binding. */ CASE (Bstack_ref1): @@ -1914,32 +1372,32 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bstack_ref4): CASE (Bstack_ref5): { - Lisp_Object *ptr = top - (op - Bstack_ref); - PUSH (*ptr); + Lisp_Object v1 = top[Bstack_ref - op]; + PUSH (v1); NEXT; } CASE (Bstack_ref6): { - Lisp_Object *ptr = top - (FETCH); - PUSH (*ptr); + Lisp_Object v1 = top[- FETCH]; + PUSH (v1); NEXT; } CASE (Bstack_ref7): { - Lisp_Object *ptr = top - (FETCH2); - PUSH (*ptr); + Lisp_Object v1 = top[- FETCH2]; + PUSH (v1); NEXT; } CASE (Bstack_set): /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ { - Lisp_Object *ptr = top - (FETCH); + Lisp_Object *ptr = top - FETCH; *ptr = POP; NEXT; } CASE (Bstack_set2): { - Lisp_Object *ptr = top - (FETCH2); + Lisp_Object *ptr = top - FETCH2; *ptr = POP; NEXT; } @@ -1955,27 +1413,16 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE_DEFAULT CASE (Bconstant): -#ifdef BYTE_CODE_SAFE - if (op < Bconstant) - { - emacs_abort (); - } - if ((op -= Bconstant) >= const_length) - { - emacs_abort (); - } - PUSH (vectorp[op]); -#else + if (BYTE_CODE_SAFE + && ! (Bconstant <= op && op < Bconstant + const_length)) + emacs_abort (); PUSH (vectorp[op - Bconstant]); -#endif NEXT; } } exit: - byte_stack_list = byte_stack_list->next; - /* Binds and unbinds are supposed to be compiled balanced. */ if (SPECPDL_INDEX () != count) { @@ -1984,9 +1431,25 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, error ("binding stack not balanced (serious byte compiler bug)"); } + Lisp_Object result = TOP; + SAFE_FREE (); return result; } +/* `args_template' has the same meaning as in exec_byte_code() above. */ +Lisp_Object +get_byte_code_arity (Lisp_Object args_template) +{ + eassert (NATNUMP (args_template)); + EMACS_INT at = XINT (args_template); + bool rest = (at & 128) != 0; + int mandatory = at & 127; + EMACS_INT nonrest = at >> 8; + + return Fcons (make_number (mandatory), + rest ? Qmany : make_number (nonrest)); +} + void syms_of_bytecode (void) { @@ -2008,7 +1471,7 @@ The variable byte-code-meter indicates how often each byte opcode is used. If a symbol has a property named `byte-code-meter' whose value is an integer, it is incremented each time that symbol's function is called. */); - byte_metering_on = 0; + byte_metering_on = false; Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0)); DEFSYM (Qbyte_code_meter, "byte-code-meter"); { diff --git a/src/callproc.c b/src/callproc.c index 76b5caa4465..f0fe5c66611 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <errno.h> #include <stdio.h> +#include <stdlib.h> #include <sys/types.h> #include <unistd.h> @@ -31,7 +32,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "lisp.h" #ifdef WINDOWSNT -#define NOMINMAX #include <sys/socket.h> /* for fcntl */ #include <windows.h> #include "w32.h" @@ -292,7 +292,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, Lisp_Object output_file = Qnil; #ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */ char *tempfile = NULL; - int pid; #else sigset_t oldset; pid_t pid; @@ -537,11 +536,9 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, } #ifdef MSDOS /* MW, July 1993 */ - /* Note that on MSDOS `child_setup' actually returns the child process - exit status, not its PID, so assign it to status below. */ - pid = child_setup (filefd, fd_output, fd_error, new_argv, 0, current_dir); + status = child_setup (filefd, fd_output, fd_error, new_argv, 0, current_dir); - if (pid < 0) + if (status < 0) { child_errno = errno; unbind_to (count, Qnil); @@ -550,7 +547,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, code_convert_string_norecord (build_string (strerror (child_errno)), Vlocale_coding_system, 0); } - status = pid; for (i = 0; i < CALLPROC_FDS; i++) if (0 <= callproc_fd[i]) @@ -565,8 +561,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, { /* Since CRLF is converted to LF within `decode_coding', we can always open a file with binary mode. */ - callproc_fd[CALLPROC_PIPEREAD] = emacs_open (tempfile, - O_RDONLY | O_BINARY, 0); + callproc_fd[CALLPROC_PIPEREAD] = emacs_open (tempfile, O_RDONLY, 0); if (callproc_fd[CALLPROC_PIPEREAD] < 0) { int open_errno = errno; @@ -1085,10 +1080,6 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &r return unbind_to (count, val); } -#ifndef WINDOWSNT -static int relocate_fd (int fd, int minfd); -#endif - static char ** add_env (char **env, char **new_env, char *string) { @@ -1167,9 +1158,13 @@ exec_failed (char const *name, int err) CURRENT_DIR is an elisp string giving the path of the current directory the subprocess should have. Since we can't really signal a decent error from within the child, this should be verified as an - executable directory by the parent. */ + executable directory by the parent. -int + On GNUish hosts, either exec or return an error number. + On MS-Windows, either return a pid or signal an error. + On MS-DOS, either return an exit status or signal an error. */ + +CHILD_SETUP_TYPE child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, Lisp_Object current_dir) { @@ -1307,7 +1302,7 @@ child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, #ifdef WINDOWSNT prepare_standard_handles (in, out, err, handles); - set_process_dir (SDATA (current_dir)); + set_process_dir (SSDATA (current_dir)); /* Spawn the child. (See w32proc.c:sys_spawnve). */ cpid = spawnve (_P_NOWAIT, new_argv[0], new_argv, env); reset_standard_handles (in, out, err, handles); @@ -1317,43 +1312,23 @@ child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, return cpid; #else /* not WINDOWSNT */ - /* Make sure that in, out, and err are not actually already in - descriptors zero, one, or two; this could happen if Emacs is - started with its standard in, out, or error closed, as might - happen under X. */ - { - int oin = in, oout = out; - - /* We have to avoid relocating the same descriptor twice! */ - - in = relocate_fd (in, 3); - if (out == oin) - out = in; - else - out = relocate_fd (out, 3); +#ifndef MSDOS - if (err == oin) - err = in; - else if (err == oout) - err = out; - else - err = relocate_fd (err, 3); - } + restore_nofile_limit (); -#ifndef MSDOS /* Redirect file descriptors and clear the close-on-exec flag on the redirected ones. IN, OUT, and ERR are close-on-exec so they need not be closed explicitly. */ - dup2 (in, 0); - dup2 (out, 1); - dup2 (err, 2); + dup2 (in, STDIN_FILENO); + dup2 (out, STDOUT_FILENO); + dup2 (err, STDERR_FILENO); setpgid (0, 0); tcsetpgrp (0, pid); - execve (new_argv[0], new_argv, env); - exec_failed (new_argv[0], errno); + int errnum = emacs_exec_file (new_argv[0], new_argv, env); + exec_failed (new_argv[0], errnum); #else /* MSDOS */ pid = run_msdos_command (new_argv, pwd_var + 4, in, out, err, env); @@ -1366,31 +1341,6 @@ child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, #endif /* not WINDOWSNT */ } -#ifndef WINDOWSNT -/* Move the file descriptor FD so that its number is not less than MINFD. - If the file descriptor is moved at all, the original is closed on MSDOS, - but not elsewhere as the caller will close it anyway. */ -static int -relocate_fd (int fd, int minfd) -{ - if (fd >= minfd) - return fd; - else - { - int new = fcntl (fd, F_DUPFD_CLOEXEC, minfd); - if (new == -1) - { - emacs_perror ("while setting up child"); - _exit (EXIT_CANCELED); - } -#ifdef MSDOS - emacs_close (fd); -#endif - return new; - } -} -#endif /* not WINDOWSNT */ - static bool getenv_internal_1 (const char *var, ptrdiff_t varlen, char **value, ptrdiff_t *valuelen, Lisp_Object env) @@ -1402,7 +1352,7 @@ getenv_internal_1 (const char *var, ptrdiff_t varlen, char **value, && SBYTES (entry) >= varlen #ifdef WINDOWSNT /* NT environment variables are case insensitive. */ - && ! strnicmp (SDATA (entry), var, varlen) + && ! strnicmp (SSDATA (entry), var, varlen) #else /* not WINDOWSNT */ && ! memcmp (SDATA (entry), var, varlen) #endif /* not WINDOWSNT */ @@ -1435,6 +1385,20 @@ getenv_internal (const char *var, ptrdiff_t varlen, char **value, Vprocess_environment)) return *value ? 1 : 0; + /* On Windows we make some modifications to Emacs' environment + without recording them in Vprocess_environment. */ +#ifdef WINDOWSNT + { + char* tmpval = getenv (var); + if (tmpval) + { + *value = tmpval; + *valuelen = strlen (tmpval); + return 1; + } + } +#endif + /* For DISPLAY try to get the values from the frame or the initial env. */ if (strcmp (var, "DISPLAY") == 0) { diff --git a/src/casefiddle.c b/src/casefiddle.c index c5bfa366630..2d32f498d0c 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -196,7 +196,7 @@ casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e) ptrdiff_t start_byte; /* Position of first and last changes. */ - ptrdiff_t first = -1, last IF_LINT (= 0); + ptrdiff_t first = -1, last; ptrdiff_t opoint = PT; ptrdiff_t opoint_byte = PT_BYTE; @@ -294,15 +294,31 @@ casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e) } } -DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r", +DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 3, + "(list (region-beginning) (region-end) (region-noncontiguous-p))", doc: /* Convert the region to upper case. In programs, wants two arguments. These arguments specify the starting and ending character numbers of the region to operate on. When used as a command, the text between point and the mark is operated on. See also `capitalize-region'. */) - (Lisp_Object beg, Lisp_Object end) + (Lisp_Object beg, Lisp_Object end, Lisp_Object region_noncontiguous_p) { - casify_region (CASE_UP, beg, end); + Lisp_Object bounds = Qnil; + + if (!NILP (region_noncontiguous_p)) + { + bounds = call1 (Fsymbol_value (intern ("region-extract-function")), + intern ("bounds")); + + while (CONSP (bounds)) + { + casify_region (CASE_UP, XCAR (XCAR (bounds)), XCDR (XCAR (bounds))); + bounds = XCDR (bounds); + } + } + else + casify_region (CASE_UP, beg, end); + return Qnil; } @@ -360,22 +376,16 @@ character positions to operate on. */) } static Lisp_Object -operate_on_word (Lisp_Object arg, ptrdiff_t *newpoint) +casify_word (enum case_action flag, Lisp_Object arg) { - Lisp_Object val; - ptrdiff_t farend; - EMACS_INT iarg; - CHECK_NUMBER (arg); - iarg = XINT (arg); - farend = scan_words (PT, iarg); + ptrdiff_t farend = scan_words (PT, XINT (arg)); if (!farend) - farend = iarg > 0 ? ZV : BEGV; - - *newpoint = PT > farend ? PT : farend; - XSETFASTINT (val, farend); - - return val; + farend = XINT (arg) <= 0 ? BEGV : ZV; + ptrdiff_t newpoint = max (PT, farend); + casify_region (flag, make_number (PT), make_number (farend)); + SET_PT (newpoint); + return Qnil; } DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p", @@ -388,13 +398,7 @@ With negative argument, convert previous words but do not move. See also `capitalize-word'. */) (Lisp_Object arg) { - Lisp_Object beg, end; - ptrdiff_t newpoint; - XSETFASTINT (beg, PT); - end = operate_on_word (arg, &newpoint); - casify_region (CASE_UP, beg, end); - SET_PT (newpoint); - return Qnil; + return casify_word (CASE_UP, arg); } DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p", @@ -406,13 +410,7 @@ is ignored when moving forward. With negative argument, convert previous words but do not move. */) (Lisp_Object arg) { - Lisp_Object beg, end; - ptrdiff_t newpoint; - XSETFASTINT (beg, PT); - end = operate_on_word (arg, &newpoint); - casify_region (CASE_DOWN, beg, end); - SET_PT (newpoint); - return Qnil; + return casify_word (CASE_DOWN, arg); } DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p", @@ -427,13 +425,7 @@ is ignored when moving forward. With negative argument, capitalize previous words but do not move. */) (Lisp_Object arg) { - Lisp_Object beg, end; - ptrdiff_t newpoint; - XSETFASTINT (beg, PT); - end = operate_on_word (arg, &newpoint); - casify_region (CASE_CAPITALIZE, beg, end); - SET_PT (newpoint); - return Qnil; + return casify_word (CASE_CAPITALIZE, arg); } void diff --git a/src/ccl.c b/src/ccl.c index d9620340f09..b9dc52e2568 100644 --- a/src/ccl.c +++ b/src/ccl.c @@ -1908,8 +1908,6 @@ ccl_get_compiled_code (Lisp_Object ccl_prog, ptrdiff_t *idx) bool setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog) { - int i; - if (! NILP (ccl_prog)) { struct Lisp_Vector *vp; @@ -1931,8 +1929,7 @@ setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog) } } ccl->ic = CCL_HEADER_MAIN; - for (i = 0; i < 8; i++) - ccl->reg[i] = 0; + memset (ccl->reg, 0, sizeof ccl->reg); ccl->last_block = false; ccl->status = 0; ccl->stack_idx = 0; diff --git a/src/character.c b/src/character.c index 9f60aa718d5..75a7dab6845 100644 --- a/src/character.c +++ b/src/character.c @@ -278,7 +278,7 @@ If the multibyte character does not represent a byte, return -1. */) static ptrdiff_t char_width (int c, struct Lisp_Char_Table *dp) { - ptrdiff_t width = CHAR_WIDTH (c); + ptrdiff_t width = CHARACTER_WIDTH (c); if (dp) { @@ -291,7 +291,7 @@ char_width (int c, struct Lisp_Char_Table *dp) ch = AREF (disp, i); if (CHARACTERP (ch)) { - int w = CHAR_WIDTH (XFASTINT (ch)); + int w = CHARACTER_WIDTH (XFASTINT (ch)); if (INT_ADD_WRAPV (width, w, &width)) string_overflow (); } @@ -983,17 +983,26 @@ alphabeticp (int c) || gen_cat == UNICODE_CATEGORY_Nl); } -/* Return true if C is a decimal-number character. */ +/* Return true if C is a alphabetic or decimal-number character. */ bool -decimalnump (int c) +alphanumericp (int c) { Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); if (! INTEGERP (category)) return false; EMACS_INT gen_cat = XINT (category); - /* See UTS #18. */ - return gen_cat == UNICODE_CATEGORY_Nd; + /* See UTS #18. Same comment as for alphabeticp applies. FIXME. */ + return (gen_cat == UNICODE_CATEGORY_Lu + || gen_cat == UNICODE_CATEGORY_Ll + || gen_cat == UNICODE_CATEGORY_Lt + || gen_cat == UNICODE_CATEGORY_Lm + || gen_cat == UNICODE_CATEGORY_Lo + || gen_cat == UNICODE_CATEGORY_Mn + || gen_cat == UNICODE_CATEGORY_Mc + || gen_cat == UNICODE_CATEGORY_Me + || gen_cat == UNICODE_CATEGORY_Nl + || gen_cat == UNICODE_CATEGORY_Nd); } /* Return true if C is a graphic character. */ diff --git a/src/character.h b/src/character.h index a94ec6d22dd..fc8a0dd74d2 100644 --- a/src/character.h +++ b/src/character.h @@ -588,9 +588,10 @@ sanitize_char_width (EMACS_INT width) /* Return the width of character C. The width is measured by how many columns C will occupy on the screen when displayed in the current - buffer. */ + buffer. The name CHARACTER_WIDTH avoids a collision with <limits.h> + CHAR_WIDTH when enabled; see ISO/IEC TS 18661-1:2014. */ -#define CHAR_WIDTH(c) \ +#define CHARACTER_WIDTH(c) \ (ASCII_CHAR_P (c) \ ? ASCII_CHAR_WIDTH (c) \ : sanitize_char_width (XINT (CHAR_TABLE_REF (Vchar_width_table, c)))) @@ -605,14 +606,13 @@ sanitize_char_width (EMACS_INT width) : (c) <= 0xE01EF ? (c) - 0xE0100 + 17 \ : 0) -/* If C is a high surrogate, return 1. If C is a low surrogate, - return 2. Otherwise, return 0. */ +/* Return true if C is a surrogate. */ -#define CHAR_SURROGATE_PAIR_P(c) \ - ((c) < 0xD800 ? 0 \ - : (c) <= 0xDBFF ? 1 \ - : (c) <= 0xDFFF ? 2 \ - : 0) +INLINE bool +char_surrogate_p (int c) +{ + return 0xD800 <= c && c <= 0xDFFF; +} /* Data type for Unicode general category. @@ -677,7 +677,7 @@ extern Lisp_Object Vchar_unify_table; extern Lisp_Object string_escape_byte8 (Lisp_Object); extern bool alphabeticp (int); -extern bool decimalnump (int); +extern bool alphanumericp (int); extern bool graphicp (int); extern bool printablep (int); diff --git a/src/charset.c b/src/charset.c index 8ff469e13a3..09520ccc2ad 100644 --- a/src/charset.c +++ b/src/charset.c @@ -30,6 +30,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <errno.h> #include <stdio.h> +#include <stdlib.h> #include <unistd.h> #include <limits.h> #include <sys/types.h> @@ -240,7 +241,8 @@ struct charset_map_entries static void load_charset_map (struct charset *charset, struct charset_map_entries *entries, int n_entries, int control_flag) { - Lisp_Object vec IF_LINT (= Qnil), table IF_LINT (= Qnil); + Lisp_Object vec UNINIT; + Lisp_Object table UNINIT; unsigned max_code = CHARSET_MAX_CODE (charset); bool ascii_compatible_p = charset->ascii_compatible_p; int min_char, max_char, nonascii_min_char; @@ -434,7 +436,7 @@ read_hex (FILE *fp, bool *eof, bool *overflow) n = 0; while (c_isxdigit (c = getc (fp))) { - if (UINT_MAX >> 4 < n) + if (INT_LEFT_SHIFT_OVERFLOW (n, 4)) *overflow = 1; n = ((n << 4) | (c - ('0' <= c && c <= '9' ? '0' @@ -842,9 +844,9 @@ usage: (define-charset-internal ...) */) int nchars; if (nargs != charset_arg_max) - return Fsignal (Qwrong_number_of_arguments, - Fcons (intern ("define-charset-internal"), - make_number (nargs))); + Fsignal (Qwrong_number_of_arguments, + Fcons (intern ("define-charset-internal"), + make_number (nargs))); attrs = Fmake_vector (make_number (charset_attr_max), Qnil); @@ -1050,8 +1052,8 @@ usage: (define-charset-internal ...) */) /* Here, we just copy the parent's fast_map. It's not accurate, but at least it works for quickly detecting which character DOESN'T belong to this charset. */ - for (i = 0; i < 190; i++) - charset.fast_map[i] = parent_charset->fast_map[i]; + memcpy (charset.fast_map, parent_charset->fast_map, + sizeof charset.fast_map); /* We also copy these for parents. */ charset.min_char = parent_charset->min_char; @@ -1400,7 +1402,7 @@ check_iso_charset_parameter (Lisp_Object dimension, Lisp_Object chars, int final_ch = XFASTINT (final_char); if (! ('0' <= final_ch && final_ch <= '~')) - error ("Invalid FINAL-CHAR '%c', it should be '0'..'~'", final_ch); + error ("Invalid FINAL-CHAR `%c', it should be `0'..`~'", final_ch); return chars_flag; } @@ -1838,12 +1840,12 @@ encode_char (struct charset *charset, int c) } -DEFUN ("decode-char", Fdecode_char, Sdecode_char, 2, 3, 0, +DEFUN ("decode-char", Fdecode_char, Sdecode_char, 2, 2, 0, doc: /* Decode the pair of CHARSET and CODE-POINT into a character. Return nil if CODE-POINT is not valid in CHARSET. CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE). */) - (Lisp_Object charset, Lisp_Object code_point, Lisp_Object restriction) + (Lisp_Object charset, Lisp_Object code_point) { int c, id; unsigned code; @@ -1857,10 +1859,10 @@ CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE). */) } -DEFUN ("encode-char", Fencode_char, Sencode_char, 2, 3, 0, +DEFUN ("encode-char", Fencode_char, Sencode_char, 2, 2, 0, doc: /* Encode the character CH into a code-point of CHARSET. Return nil if CHARSET doesn't include CH. */) - (Lisp_Object ch, Lisp_Object charset, Lisp_Object restriction) + (Lisp_Object ch, Lisp_Object charset) { int c, id; unsigned code; diff --git a/src/chartab.c b/src/chartab.c index 6cf8fea0b6d..fa5a8e41164 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -492,7 +492,7 @@ char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val) int lim = CHARTAB_IDX (to, 0, 0); int i, c; - for (i = CHARTAB_IDX (from, 0, 0), c = 0; i <= lim; + for (i = CHARTAB_IDX (from, 0, 0), c = i * chartab_chars[0]; i <= lim; i++, c += chartab_chars[0]) { if (c > to) @@ -321,7 +321,7 @@ cmgoto (struct tty_display_info *tty, int row, int col) llcost, relcost, directcost; - int use IF_LINT (= 0); + int use UNINIT; char *p; const char *dcm; diff --git a/src/coding.c b/src/coding.c index 3e4af722e4c..f2a92c940b7 100644 --- a/src/coding.c +++ b/src/coding.c @@ -2365,7 +2365,8 @@ decode_coding_emacs_mule (struct coding_system *coding) while (1) { - int c, id IF_LINT (= 0); + int c; + int id UNINIT; src_base = src; consumed_chars_base = consumed_chars; @@ -2410,7 +2411,7 @@ decode_coding_emacs_mule (struct coding_system *coding) } else { - int nchars IF_LINT (= 0), nbytes IF_LINT (= 0); + int nchars UNINIT, nbytes UNINIT; /* emacs_mule_char can load a charset map from a file, which allocates a large structure and might cause buffer text to be relocated as result. Thus, we need to remember the @@ -6814,39 +6815,33 @@ decode_eol (struct coding_system *coding) else if (EQ (eol_type, Qdos)) { ptrdiff_t n = 0; + ptrdiff_t pos = coding->dst_pos; + ptrdiff_t pos_byte = coding->dst_pos_byte; + ptrdiff_t pos_end = pos_byte + coding->produced - 1; - if (NILP (coding->dst_object)) - { - /* Start deleting '\r' from the tail to minimize the memory - movement. */ - for (p = pend - 2; p >= pbeg; p--) - if (*p == '\r') - { - memmove (p, p + 1, pend-- - p - 1); - n++; - } - } - else + /* This assertion is here instead of code, now deleted, that + handled the NILP case, which no longer happens with the + current codebase. */ + eassert (!NILP (coding->dst_object)); + + while (pos_byte < pos_end) { - ptrdiff_t pos = coding->dst_pos; - ptrdiff_t pos_byte = coding->dst_pos_byte; - ptrdiff_t pos_end = pos_byte + coding->produced - 1; + int incr; + + p = BYTE_POS_ADDR (pos_byte); + if (coding->dst_multibyte) + incr = BYTES_BY_CHAR_HEAD (*p); + else + incr = 1; - while (pos_byte < pos_end) + if (*p == '\r' && p[1] == '\n') { - p = BYTE_POS_ADDR (pos_byte); - if (*p == '\r' && p[1] == '\n') - { - del_range_2 (pos, pos_byte, pos + 1, pos_byte + 1, 0); - n++; - pos_end--; - } - pos++; - if (coding->dst_multibyte) - pos_byte += BYTES_BY_CHAR_HEAD (*p); - else - pos_byte++; + del_range_2 (pos, pos_byte, pos + 1, pos_byte + 1, 0); + n++; + pos_end--; } + pos++; + pos_byte += incr; } coding->produced -= n; coding->produced_char -= n; @@ -6957,18 +6952,21 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup) /* Return a translation of character(s) at BUF according to TRANS. - TRANS is TO-CHAR or ((FROM . TO) ...) where - FROM = [FROM-CHAR ...], TO is TO-CHAR or [TO-CHAR ...]. - The return value is TO-CHAR or ([FROM-CHAR ...] . TO) if a - translation is found, and Qnil if not found.. - If BUF is too short to lookup characters in FROM, return Qt. */ + TRANS is TO-CHAR, [TO-CHAR ...], or ((FROM . TO) ...) where FROM = + [FROM-CHAR ...], TO is TO-CHAR or [TO-CHAR ...]. The return value + is TO-CHAR or [TO-CHAR ...] if a translation is found, Qnil if not + found, or Qt if BUF is too short to lookup characters in FROM. As + a side effect, if a translation is found, *NCHARS is set to the + number of characters being translated. */ static Lisp_Object -get_translation (Lisp_Object trans, int *buf, int *buf_end) +get_translation (Lisp_Object trans, int *buf, int *buf_end, ptrdiff_t *nchars) { - - if (INTEGERP (trans)) - return trans; + if (INTEGERP (trans) || VECTORP (trans)) + { + *nchars = 1; + return trans; + } for (; CONSP (trans); trans = XCDR (trans)) { Lisp_Object val = XCAR (trans); @@ -6984,7 +6982,10 @@ get_translation (Lisp_Object trans, int *buf, int *buf_end) break; } if (i == len) - return val; + { + *nchars = len; + return XCDR (val); + } } return Qnil; } @@ -7027,20 +7028,13 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, LOOKUP_TRANSLATION_TABLE (translation_table, c, trans); if (! NILP (trans)) { - trans = get_translation (trans, buf, buf_end); + trans = get_translation (trans, buf, buf_end, &from_nchars); if (INTEGERP (trans)) c = XINT (trans); - else if (CONSP (trans)) + else if (VECTORP (trans)) { - from_nchars = ASIZE (XCAR (trans)); - trans = XCDR (trans); - if (INTEGERP (trans)) - c = XINT (trans); - else - { - to_nchars = ASIZE (trans); - c = XINT (AREF (trans, 0)); - } + to_nchars = ASIZE (trans); + c = XINT (AREF (trans, 0)); } else if (EQ (trans, Qt) && ! last_block) break; @@ -7681,22 +7675,16 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, for (i = 1; i < max_lookup && p < src_end; i++) lookup_buf[i] = STRING_CHAR_ADVANCE (p); lookup_buf_end = lookup_buf + i; - trans = get_translation (trans, lookup_buf, lookup_buf_end); + trans = get_translation (trans, lookup_buf, lookup_buf_end, + &from_nchars); if (INTEGERP (trans)) c = XINT (trans); - else if (CONSP (trans)) + else if (VECTORP (trans)) { - from_nchars = ASIZE (XCAR (trans)); - trans = XCDR (trans); - if (INTEGERP (trans)) - c = XINT (trans); - else - { - to_nchars = ASIZE (trans); - if (buf_end - buf < to_nchars) - break; - c = XINT (AREF (trans, 0)); - } + to_nchars = ASIZE (trans); + if (buf_end - buf < to_nchars) + break; + c = XINT (AREF (trans, 0)); } else break; @@ -7863,6 +7851,15 @@ code_conversion_save (bool with_work_buf, bool multibyte) return workbuf; } +static void +coding_restore_undo_list (Lisp_Object arg) +{ + Lisp_Object undo_list = XCAR (arg); + struct buffer *buf = XBUFFER (XCDR (arg)); + + bset_undo_list (buf, undo_list); +} + void decode_coding_gap (struct coding_system *coding, ptrdiff_t chars, ptrdiff_t bytes) @@ -7975,13 +7972,19 @@ decode_coding_gap (struct coding_system *coding, { ptrdiff_t prev_Z = Z, prev_Z_BYTE = Z_BYTE; Lisp_Object val; + Lisp_Object undo_list = BVAR (current_buffer, undo_list); + ptrdiff_t count1 = SPECPDL_INDEX (); + record_unwind_protect (coding_restore_undo_list, + Fcons (undo_list, Fcurrent_buffer ())); + bset_undo_list (current_buffer, Qt); TEMP_SET_PT_BOTH (coding->dst_pos, coding->dst_pos_byte); val = call1 (CODING_ATTR_POST_READ (attrs), make_number (coding->produced_char)); CHECK_NATNUM (val); coding->produced_char += Z - prev_Z; coding->produced += Z_BYTE - prev_Z_BYTE; + unbind_to (count1, Qnil); } unbind_to (count, Qnil); @@ -8025,12 +8028,12 @@ decode_coding_object (struct coding_system *coding, Lisp_Object dst_object) { ptrdiff_t count = SPECPDL_INDEX (); - unsigned char *destination IF_LINT (= NULL); - ptrdiff_t dst_bytes IF_LINT (= 0); + unsigned char *destination UNINIT; + ptrdiff_t dst_bytes UNINIT; ptrdiff_t chars = to - from; ptrdiff_t bytes = to_byte - from_byte; Lisp_Object attrs; - ptrdiff_t saved_pt = -1, saved_pt_byte IF_LINT (= 0); + ptrdiff_t saved_pt = -1, saved_pt_byte UNINIT; bool need_marker_adjustment = 0; Lisp_Object old_deactivate_mark; @@ -8122,13 +8125,19 @@ decode_coding_object (struct coding_system *coding, { ptrdiff_t prev_Z = Z, prev_Z_BYTE = Z_BYTE; Lisp_Object val; + Lisp_Object undo_list = BVAR (current_buffer, undo_list); + ptrdiff_t count1 = SPECPDL_INDEX (); + record_unwind_protect (coding_restore_undo_list, + Fcons (undo_list, Fcurrent_buffer ())); + bset_undo_list (current_buffer, Qt); TEMP_SET_PT_BOTH (coding->dst_pos, coding->dst_pos_byte); val = safe_call1 (CODING_ATTR_POST_READ (attrs), make_number (coding->produced_char)); CHECK_NATNUM (val); coding->produced_char += Z - prev_Z; coding->produced += Z_BYTE - prev_Z_BYTE; + unbind_to (count1, Qnil); } if (EQ (dst_object, Qt)) @@ -8208,7 +8217,7 @@ encode_coding_object (struct coding_system *coding, ptrdiff_t chars = to - from; ptrdiff_t bytes = to_byte - from_byte; Lisp_Object attrs; - ptrdiff_t saved_pt = -1, saved_pt_byte IF_LINT (= 0); + ptrdiff_t saved_pt = -1, saved_pt_byte; bool need_marker_adjustment = 0; bool kill_src_buffer = 0; Lisp_Object old_deactivate_mark; @@ -8429,11 +8438,10 @@ from_unicode (Lisp_Object str) Lisp_Object from_unicode_buffer (const wchar_t *wstr) { - return from_unicode ( - make_unibyte_string ( - (char *) wstr, - /* we get one of the two final 0 bytes for free. */ - 1 + sizeof (wchar_t) * wcslen (wstr))); + /* We get one of the two final null bytes for free. */ + ptrdiff_t len = 1 + sizeof (wchar_t) * wcslen (wstr); + AUTO_STRING_WITH_LEN (str, (char *) wstr, len); + return from_unicode (str); } wchar_t * @@ -8583,8 +8591,8 @@ detect_coding_system (const unsigned char *src, base_category = XINT (CODING_ATTR_CATEGORY (attrs)); if (base_category == coding_category_undecided) { - enum coding_category category IF_LINT (= 0); - struct coding_system *this IF_LINT (= NULL); + enum coding_category category UNINIT; + struct coding_system *this UNINIT; int c, i; bool inhibit_nbd = inhibit_flag (coding.spec.undecided.inhibit_nbd, inhibit_null_byte_detection); @@ -9854,7 +9862,8 @@ usage: (find-operation-coding-system OPERATION ARGUMENTS...) */) if (!(STRINGP (target) || (EQ (operation, Qinsert_file_contents) && CONSP (target) && STRINGP (XCAR (target)) && BUFFERP (XCDR (target))) - || (EQ (operation, Qopen_network_stream) && INTEGERP (target)))) + || (EQ (operation, Qopen_network_stream) + && (INTEGERP (target) || EQ (target, Qt))))) error ("Invalid argument %"pI"d of operation `%s'", XFASTINT (target_idx) + 1, SDATA (SYMBOL_NAME (operation))); if (CONSP (target)) @@ -10558,9 +10567,9 @@ usage: (define-coding-system-internal ...) */) return Qnil; short_args: - return Fsignal (Qwrong_number_of_arguments, - Fcons (intern ("define-coding-system-internal"), - make_number (nargs))); + Fsignal (Qwrong_number_of_arguments, + Fcons (intern ("define-coding-system-internal"), + make_number (nargs))); } @@ -11319,24 +11328,4 @@ internal character representation. */); #endif staticpro (&system_eol_type); } - -char * -emacs_strerror (int error_number) -{ - char *str; - - synchronize_system_messages_locale (); - str = strerror (error_number); - - if (! NILP (Vlocale_coding_system)) - { - Lisp_Object dec = code_convert_string_norecord (build_string (str), - Vlocale_coding_system, - 0); - str = SSDATA (dec); - } - - return str; -} - #endif /* emacs */ diff --git a/src/coding.h b/src/coding.h index 93ddff0c6bd..426be6277ca 100644 --- a/src/coding.h +++ b/src/coding.h @@ -768,8 +768,6 @@ extern Lisp_Object preferred_coding_system (void); #ifdef emacs -extern char *emacs_strerror (int); - /* Coding system to be used to encode text for terminal display when terminal coding system is nil. */ extern struct coding_system safe_terminal_coding; diff --git a/src/composite.c b/src/composite.c index 49b00036361..da921358e9f 100644 --- a/src/composite.c +++ b/src/composite.c @@ -335,7 +335,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, ch = XINT (key_contents[i]); /* TAB in a composition means display glyphs with padding space on the left or right. */ - this_width = (ch == '\t' ? 1 : CHAR_WIDTH (ch)); + this_width = (ch == '\t' ? 1 : CHARACTER_WIDTH (ch)); if (cmp->width < this_width) cmp->width = this_width; } @@ -346,7 +346,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, double leftmost = 0.0, rightmost; ch = XINT (key_contents[0]); - rightmost = ch != '\t' ? CHAR_WIDTH (ch) : 1; + rightmost = ch != '\t' ? CHARACTER_WIDTH (ch) : 1; for (i = 1; i < glyph_len; i += 2) { @@ -356,7 +356,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, rule = XINT (key_contents[i]); ch = XINT (key_contents[i + 1]); - this_width = ch != '\t' ? CHAR_WIDTH (ch) : 1; + this_width = ch != '\t' ? CHARACTER_WIDTH (ch) : 1; /* A composition rule is specified by an integer value that encodes global and new reference points (GREF and @@ -891,7 +891,6 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos, if (len <= 0) return unbind_to (count, Qnil); to = limit = charpos + len; -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (f)) { font_object = font_range (charpos, bytepos, &to, win, face, string); @@ -902,7 +901,6 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos, return unbind_to (count, Qnil); } else -#endif /* not HAVE_WINDOW_SYSTEM */ font_object = win->frame; lgstring = Fcomposition_get_gstring (pos, make_number (to), font_object, string); @@ -1308,7 +1306,8 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos, int composition_update_it (struct composition_it *cmp_it, ptrdiff_t charpos, ptrdiff_t bytepos, Lisp_Object string) { - int i, c IF_LINT (= 0); + int i; + int c UNINIT; if (cmp_it->ch < 0) { @@ -1384,7 +1383,7 @@ composition_update_it (struct composition_it *cmp_it, ptrdiff_t charpos, ptrdiff { c = XINT (LGSTRING_CHAR (gstring, from + i)); cmp_it->nbytes += CHAR_BYTES (c); - cmp_it->width += CHAR_WIDTH (c); + cmp_it->width += CHARACTER_WIDTH (c); } } return c; diff --git a/src/conf_post.h b/src/conf_post.h index d8070fad8e7..060b912fafb 100644 --- a/src/conf_post.h +++ b/src/conf_post.h @@ -18,31 +18,33 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ -/* Commentary: +/* Put the code here rather than in configure.ac using AH_BOTTOM. + This way, the code does not get processed by autoheader. For + example, undefs here are not commented out. - Rather than writing this code directly in AH_BOTTOM, we include it - via this file. This is so that it does not get processed by - autoheader. Eg, any undefs here would otherwise be commented out. -*/ + To help make dependencies clearer elsewhere, this file typically + does not #include other files. The exceptions are first stdbool.h + because it is unlikely to interfere with configuration and bool is + such a core part of the C language, and second ms-w32.h (DOS_NT + only) because it historically was included here and changing that + would take some work. */ -/* Code: */ +#include <stdbool.h> -/* Include any platform specific configuration file. */ -#ifdef config_opsysfile -# include config_opsysfile +#if defined DOS_NT && !defined DEFER_MS_W32_H +# include <ms-w32.h> #endif -#include <stdbool.h> - /* GNUC_PREREQ (V, W, X) is true if this is GNU C version V.W.X or later. It can be used in a preprocessor expression. */ #ifndef __GNUC_MINOR__ # define GNUC_PREREQ(v, w, x) false #elif ! defined __GNUC_PATCHLEVEL__ -# define GNUC_PREREQ(v, w, x) ((v) < __GNUC__ + ((w) <= __GNUC_MINOR__)) +# define GNUC_PREREQ(v, w, x) \ + ((v) < __GNUC__ + ((w) < __GNUC_MINOR__ + ((x) == 0)) #else # define GNUC_PREREQ(v, w, x) \ - ((v) < __GNUC__ + ((w) <= __GNUC_MINOR__ + ((x) <= __GNUC_PATCHLEVEL__))) + ((v) < __GNUC__ + ((w) < __GNUC_MINOR__ + ((x) <= __GNUC_PATCHLEVEL__))) #endif /* The type of bool bitfields. Needed to compile Objective-C with @@ -54,25 +56,23 @@ typedef unsigned int bool_bf; typedef bool bool_bf; #endif -#ifndef WINDOWSNT -/* On AIX 3 this must be included before any other include file. */ -#include <alloca.h> -#if ! HAVE_ALLOCA -# error "alloca not available on this machine" -#endif -#endif - /* Simulate __has_attribute on compilers that lack it. It is used only on arguments like alloc_size that are handled in this simulation. */ #ifndef __has_attribute # define __has_attribute(a) __has_attribute_##a -# define __has_attribute_alloc_size (4 < __GNUC__ + (3 <= __GNUC_MINOR__)) -# define __has_attribute_cleanup (3 < __GNUC__ + (4 <= __GNUC_MINOR__)) -# define __has_attribute_externally_visible \ - (4 < __GNUC__ + (1 <= __GNUC_MINOR__)) +# define __has_attribute_alloc_size GNUC_PREREQ (4, 3, 0) +# define __has_attribute_cleanup GNUC_PREREQ (3, 4, 0) +# define __has_attribute_externally_visible GNUC_PREREQ (4, 1, 0) # define __has_attribute_no_address_safety_analysis false -# define __has_attribute_no_sanitize_address \ - (4 < __GNUC__ + (8 <= __GNUC_MINOR__)) +# define __has_attribute_no_sanitize_address GNUC_PREREQ (4, 8, 0) +#endif + +/* Simulate __has_builtin on compilers that lack it. It is used only + on arguments like __builtin_assume_aligned that are handled in this + simulation. */ +#ifndef __has_builtin +# define __has_builtin(a) __has_builtin_##a +# define __has_builtin___builtin_assume_aligned GNUC_PREREQ (4, 7, 0) #endif /* Simulate __has_feature on compilers that lack it. It is used only @@ -88,6 +88,11 @@ typedef bool bool_bf; # define ADDRESS_SANITIZER false #endif +/* Yield PTR, which must be aligned to ALIGNMENT. */ +#if ! __has_builtin (__builtin_assume_aligned) +# define __builtin_assume_aligned(ptr, ...) ((void *) (ptr)) +#endif + #ifdef DARWIN_OS #ifdef emacs #define malloc unexec_malloc @@ -110,12 +115,9 @@ typedef bool bool_bf; #ifdef emacs #define malloc hybrid_malloc #define realloc hybrid_realloc +#define aligned_alloc hybrid_aligned_alloc #define calloc hybrid_calloc #define free hybrid_free -#if defined HAVE_GET_CURRENT_DIR_NAME && !defined BROKEN_GET_CURRENT_DIR_NAME -#define HYBRID_GET_CURRENT_DIR_NAME 1 -#define get_current_dir_name hybrid_get_current_dir_name -#endif #endif #endif /* HYBRID_MALLOC */ @@ -131,14 +133,6 @@ typedef bool bool_bf; #undef HAVE_RINT #endif /* HPUX */ -#ifdef IRIX6_5 -#ifdef emacs -char *_getpty(); -#endif -#define INET6 /* Needed for struct sockaddr_in6. */ -#undef HAVE_GETADDRINFO /* IRIX has getaddrinfo but not struct addrinfo. */ -#endif /* IRIX6_5 */ - #ifdef MSDOS #ifndef __DJGPP__ You lose; /* Emacs for DOS must be compiled with DJGPP */ @@ -203,7 +197,7 @@ You lose; /* Emacs for DOS must be compiled with DJGPP */ #endif #ifdef CYGWIN -#define SYSTEM_PURESIZE_EXTRA 10000 +#define SYSTEM_PURESIZE_EXTRA 50000 #endif #if defined HAVE_NTGUI && !defined DebPrint @@ -211,7 +205,7 @@ You lose; /* Emacs for DOS must be compiled with DJGPP */ extern void _DebPrint (const char *fmt, ...); # define DebPrint(stuff) _DebPrint stuff # else -# define DebPrint(stuff) +# define DebPrint(stuff) ((void) 0) # endif #endif @@ -238,9 +232,6 @@ extern void _DebPrint (const char *fmt, ...); extern char *emacs_getenv_TZ (void); extern int emacs_setenv_TZ (char const *); -#include <string.h> -#include <stdlib.h> - #if __GNUC__ >= 3 /* On GCC 3.0 we might get a warning. */ #define NO_INLINE __attribute__((noinline)) #else @@ -253,19 +244,21 @@ extern int emacs_setenv_TZ (char const *); #define EXTERNALLY_VISIBLE #endif -#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7) +#if GNUC_PREREQ (2, 7, 0) # define ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec)) #else # define ATTRIBUTE_FORMAT(spec) /* empty */ #endif -#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) -# define ATTRIBUTE_FORMAT_PRINTF(formatstring_parameter, first_argument) \ - ATTRIBUTE_FORMAT ((__gnu_printf__, formatstring_parameter, first_argument)) +#if GNUC_PREREQ (4, 4, 0) && defined __GLIBC_MINOR__ +# define PRINTF_ARCHETYPE __gnu_printf__ +#elif GNUC_PREREQ (4, 4, 0) && defined __MINGW32__ +# define PRINTF_ARCHETYPE __ms_printf__ #else -# define ATTRIBUTE_FORMAT_PRINTF(formatstring_parameter, first_argument) \ - ATTRIBUTE_FORMAT ((__printf__, formatstring_parameter, first_argument)) +# define PRINTF_ARCHETYPE __printf__ #endif +#define ATTRIBUTE_FORMAT_PRINTF(string_index, first_to_check) \ + ATTRIBUTE_FORMAT ((PRINTF_ARCHETYPE, string_index, first_to_check)) #define ATTRIBUTE_CONST _GL_ATTRIBUTE_CONST #define ATTRIBUTE_UNUSED _GL_UNUSED @@ -289,7 +282,7 @@ extern int emacs_setenv_TZ (char const *); no_sanitize_address attribute. This bug is fixed in GCC 4.9.0 and clang 3.4. */ #if (! ADDRESS_SANITIZER \ - || ((4 < __GNUC__ + (9 <= __GNUC_MINOR__)) \ + || (GNUC_PREREQ (4, 9, 0) \ || 3 < __clang_major__ + (4 <= __clang_minor__))) # define ADDRESS_SANITIZER_WORKAROUND /* No workaround needed. */ #else @@ -355,22 +348,10 @@ extern int emacs_setenv_TZ (char const *); #define INLINE_HEADER_BEGIN _GL_INLINE_HEADER_BEGIN #define INLINE_HEADER_END _GL_INLINE_HEADER_END -/* To use the struct hack with N elements, declare the struct like this: - struct s { ...; t name[FLEXIBLE_ARRAY_MEMBER]; }; - and allocate (offsetof (struct s, name) + N * sizeof (t)) bytes. - IBM xlc 12.1 claims to do C99 but mishandles flexible array members. */ -#ifdef __IBMC__ -# define FLEXIBLE_ARRAY_MEMBER 1 +/* 'int x UNINIT;' is equivalent to 'int x;', except it cajoles GCC + into not warning incorrectly about use of an uninitialized variable. */ +#if defined GCC_LINT || defined lint +# define UNINIT = {0,} #else -# define FLEXIBLE_ARRAY_MEMBER +# define UNINIT /* empty */ #endif - -/* Use this to suppress gcc's `...may be used before initialized' warnings. */ -#ifdef lint -/* Use CODE only if lint checking is in effect. */ -# define IF_LINT(Code) Code -#else -# define IF_LINT(Code) /* empty */ -#endif - -/* conf_post.h ends here */ diff --git a/src/cygw32.c b/src/cygw32.c index 682232035f6..ca9069a120b 100644 --- a/src/cygw32.c +++ b/src/cygw32.c @@ -31,7 +31,7 @@ fchdir_unwind (int dir_fd) } static void -chdir_to_default_directory () +chdir_to_default_directory (void) { Lisp_Object new_cwd; int old_cwd_fd = emacs_open (".", O_RDONLY | O_DIRECTORY, 0); @@ -46,7 +46,7 @@ chdir_to_default_directory () if (!STRINGP (new_cwd)) new_cwd = build_string ("/"); - if (chdir (SDATA (ENCODE_FILE (new_cwd)))) + if (chdir (SSDATA (ENCODE_FILE (new_cwd)))) error ("could not chdir: %s", strerror (errno)); } diff --git a/src/data.c b/src/data.c index 3a51129d182..e2c1a288a8f 100644 --- a/src/data.c +++ b/src/data.c @@ -31,6 +31,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "character.h" #include "buffer.h" #include "keyboard.h" +#include "process.h" #include "frame.h" #include "keymap.h" @@ -138,7 +139,7 @@ wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3) make_number (bool_vector_size (a3))); } -Lisp_Object +_Noreturn void wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value) { /* If VALUE is not even a valid Lisp object, we'd want to abort here @@ -258,6 +259,12 @@ for example, (type-of 1) returns `integer'. */) return Qfont_entity; if (FONT_OBJECT_P (object)) return Qfont_object; + if (THREADP (object)) + return Qthread; + if (MUTEXP (object)) + return Qmutex; + if (CONDVARP (object)) + return Qcondition_variable; return Qvector; case Lisp_Float: @@ -528,6 +535,33 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, return Qnil; } +DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0, + doc: /* Return t if OBJECT is a thread. */) + (Lisp_Object object) +{ + if (THREADP (object)) + return Qt; + return Qnil; +} + +DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, + doc: /* Return t if OBJECT is a mutex. */) + (Lisp_Object object) +{ + if (MUTEXP (object)) + return Qt; + return Qnil; +} + +DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, + 1, 1, 0, + doc: /* Return t if OBJECT is a condition variable. */) + (Lisp_Object object) +{ + if (CONDVARP (object)) + return Qt; + return Qnil; +} /* Extract and set components of lists. */ @@ -700,6 +734,9 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, { register Lisp_Object function; CHECK_SYMBOL (symbol); + /* Perhaps not quite the right error signal, but seems good enough. */ + if (NILP (symbol)) + xsignal1 (Qsetting_constant, symbol); function = XSYMBOL (symbol)->function; @@ -1140,9 +1177,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_ tem1 = blv->where; if (NILP (tem1) - || (blv->frame_local - ? !EQ (selected_frame, tem1) - : current_buffer != XBUFFER (tem1))) + || current_buffer != XBUFFER (tem1)) { /* Unload the previously loaded binding. */ @@ -1153,16 +1188,8 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_ { Lisp_Object var; XSETSYMBOL (var, symbol); - if (blv->frame_local) - { - tem1 = assq_no_quit (var, XFRAME (selected_frame)->param_alist); - set_blv_where (blv, selected_frame); - } - else - { - tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist)); - set_blv_where (blv, Fcurrent_buffer ()); - } + tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist)); + set_blv_where (blv, Fcurrent_buffer ()); } if (!(blv->found = !NILP (tem1))) tem1 = blv->defcell; @@ -1225,21 +1252,22 @@ DEFUN ("set", Fset, Sset, 2, 2, 0, doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */) (register Lisp_Object symbol, Lisp_Object newval) { - set_internal (symbol, newval, Qnil, 0); + set_internal (symbol, newval, Qnil, SET_INTERNAL_SET); return newval; } /* Store the value NEWVAL into SYMBOL. - If buffer/frame-locality is an issue, WHERE specifies which context to use. + If buffer-locality is an issue, WHERE specifies which context to use. (nil stands for the current buffer/frame). - If BINDFLAG is false, then if this symbol is supposed to become - local in every buffer where it is set, then we make it local. - If BINDFLAG is true, we don't do that. */ + If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to + become local in every buffer where it is set, then we make it + local. If BINDFLAG is SET_INTERNAL_BIND or SET_INTERNAL_UNBIND, we + don't do that. */ void set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, - bool bindflag) + enum Set_Internal_Bind bindflag) { bool voide = EQ (newval, Qunbound); struct Lisp_Symbol *sym; @@ -1250,18 +1278,31 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, return; */ CHECK_SYMBOL (symbol); - if (SYMBOL_CONSTANT_P (symbol)) + sym = XSYMBOL (symbol); + switch (sym->trapped_write) { + case SYMBOL_NOWRITE: if (NILP (Fkeywordp (symbol)) - || !EQ (newval, Fsymbol_value (symbol))) - xsignal1 (Qsetting_constant, symbol); + || !EQ (newval, Fsymbol_value (symbol))) + xsignal1 (Qsetting_constant, symbol); else - /* Allow setting keywords to their own value. */ - return; - } + /* Allow setting keywords to their own value. */ + return; + + case SYMBOL_TRAPPED_WRITE: + /* Setting due to thread-switching doesn't count. */ + if (bindflag != SET_INTERNAL_THREAD_SWITCH) + notify_variable_watchers (symbol, voide? Qnil : newval, + (bindflag == SET_INTERNAL_BIND? Qlet : + bindflag == SET_INTERNAL_UNBIND? Qunlet : + voide? Qmakunbound : Qset), + where); + /* FALLTHROUGH! */ + case SYMBOL_UNTRAPPED_WRITE: + break; - maybe_set_redisplay (symbol); - sym = XSYMBOL (symbol); + default: emacs_abort (); + } start: switch (sym->redirect) @@ -1272,15 +1313,10 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); if (NILP (where)) - { - if (blv->frame_local) - where = selected_frame; - else - XSETBUFFER (where, current_buffer); - } + XSETBUFFER (where, current_buffer); + /* If the current buffer is not the buffer whose binding is - loaded, or if there may be frame-local bindings and the frame - isn't the right one, or if it's a Lisp_Buffer_Local_Value and + loaded, or if it's a Lisp_Buffer_Local_Value and the default binding is loaded, the loaded binding may be the wrong one. */ if (!EQ (blv->where, where) @@ -1297,9 +1333,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, /* Find the new binding. */ XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */ tem1 = assq_no_quit (symbol, - (blv->frame_local - ? XFRAME (where)->param_alist - : BVAR (XBUFFER (where), local_var_alist))); + BVAR (XBUFFER (where), local_var_alist)); set_blv_where (blv, where); blv->found = 1; @@ -1326,9 +1360,6 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, and load that binding. */ else { - /* local_if_set is only supported for buffer-local - bindings, not for frame-local bindings. */ - eassert (!blv->frame_local); tem1 = Fcons (symbol, XCDR (blv->defcell)); bset_local_var_alist (XBUFFER (where), @@ -1366,7 +1397,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, int offset = XBUFFER_OBJFWD (innercontents)->offset; int idx = PER_BUFFER_IDX (offset); if (idx > 0 - && !bindflag + && bindflag == SET_INTERNAL_SET && !let_shadows_buffer_binding_p (sym)) SET_PER_BUFFER_VALUE_P (buf, idx, 1); } @@ -1385,6 +1416,127 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, } return; } + +static void +set_symbol_trapped_write (Lisp_Object symbol, enum symbol_trapped_write trap) +{ + struct Lisp_Symbol* sym = XSYMBOL (symbol); + if (sym->trapped_write == SYMBOL_NOWRITE) + xsignal1 (Qtrapping_constant, symbol); + sym->trapped_write = trap; +} + +static void +restore_symbol_trapped_write (Lisp_Object symbol) +{ + set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE); +} + +static void +harmonize_variable_watchers (Lisp_Object alias, Lisp_Object base_variable) +{ + if (!EQ (base_variable, alias) + && EQ (base_variable, Findirect_variable (alias))) + set_symbol_trapped_write + (alias, XSYMBOL (base_variable)->trapped_write); +} + +DEFUN ("add-variable-watcher", Fadd_variable_watcher, Sadd_variable_watcher, + 2, 2, 0, + doc: /* Cause WATCH-FUNCTION to be called when SYMBOL is set. + +It will be called with 4 arguments: (SYMBOL NEWVAL OPERATION WHERE). +SYMBOL is the variable being changed. +NEWVAL is the value it will be changed to. +OPERATION is a symbol representing the kind of change, one of: `set', +`let', `unlet', `makunbound', and `defvaralias'. +WHERE is a buffer if the buffer-local value of the variable being +changed, nil otherwise. + +All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */) + (Lisp_Object symbol, Lisp_Object watch_function) +{ + symbol = Findirect_variable (symbol); + set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE); + map_obarray (Vobarray, harmonize_variable_watchers, symbol); + + Lisp_Object watchers = Fget (symbol, Qwatchers); + Lisp_Object member = Fmember (watch_function, watchers); + if (NILP (member)) + Fput (symbol, Qwatchers, Fcons (watch_function, watchers)); + return Qnil; +} + +DEFUN ("remove-variable-watcher", Fremove_variable_watcher, Sremove_variable_watcher, + 2, 2, 0, + doc: /* Undo the effect of `add-variable-watcher'. +Remove WATCH-FUNCTION from the list of functions to be called when +SYMBOL (or its aliases) are set. */) + (Lisp_Object symbol, Lisp_Object watch_function) +{ + symbol = Findirect_variable (symbol); + Lisp_Object watchers = Fget (symbol, Qwatchers); + watchers = Fdelete (watch_function, watchers); + if (NILP (watchers)) + { + set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE); + map_obarray (Vobarray, harmonize_variable_watchers, symbol); + } + Fput (symbol, Qwatchers, watchers); + return Qnil; +} + +DEFUN ("get-variable-watchers", Fget_variable_watchers, Sget_variable_watchers, + 1, 1, 0, + doc: /* Return a list of SYMBOL's active watchers. */) + (Lisp_Object symbol) +{ + return (SYMBOL_TRAPPED_WRITE_P (symbol) == SYMBOL_TRAPPED_WRITE) + ? Fget (Findirect_variable (symbol), Qwatchers) + : Qnil; +} + +void +notify_variable_watchers (Lisp_Object symbol, + Lisp_Object newval, + Lisp_Object operation, + Lisp_Object where) +{ + symbol = Findirect_variable (symbol); + + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect (restore_symbol_trapped_write, symbol); + /* Avoid recursion. */ + set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE); + + if (NILP (where) + && !EQ (operation, Qset_default) && !EQ (operation, Qmakunbound) + && !NILP (Flocal_variable_if_set_p (symbol, Fcurrent_buffer ()))) + { + XSETBUFFER (where, current_buffer); + } + + if (EQ (operation, Qset_default)) + operation = Qset; + + for (Lisp_Object watchers = Fget (symbol, Qwatchers); + CONSP (watchers); + watchers = XCDR (watchers)) + { + Lisp_Object watcher = XCAR (watchers); + /* Call subr directly to avoid gc. */ + if (SUBRP (watcher)) + { + Lisp_Object args[] = { symbol, newval, operation, where }; + funcall_subr (XSUBR (watcher), ARRAYELTS (args), args); + } + else + CALLN (Ffuncall, watcher, symbol, newval, operation, where); + } + + unbind_to (count, Qnil); +} + /* Access or set a buffer-local symbol's default value. */ @@ -1462,31 +1614,42 @@ local bindings in certain buffers. */) xsignal1 (Qvoid_variable, symbol); } -DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, - doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated. -The default value is seen in buffers that do not have their own values -for this variable. */) - (Lisp_Object symbol, Lisp_Object value) +void +set_default_internal (Lisp_Object symbol, Lisp_Object value, + enum Set_Internal_Bind bindflag) { struct Lisp_Symbol *sym; CHECK_SYMBOL (symbol); - if (SYMBOL_CONSTANT_P (symbol)) + sym = XSYMBOL (symbol); + switch (sym->trapped_write) { + case SYMBOL_NOWRITE: if (NILP (Fkeywordp (symbol)) - || !EQ (value, Fdefault_value (symbol))) - xsignal1 (Qsetting_constant, symbol); + || !EQ (value, Fsymbol_value (symbol))) + xsignal1 (Qsetting_constant, symbol); else - /* Allow setting keywords to their own value. */ - return value; + /* Allow setting keywords to their own value. */ + return; + + case SYMBOL_TRAPPED_WRITE: + /* Don't notify here if we're going to call Fset anyway. */ + if (sym->redirect != SYMBOL_PLAINVAL + /* Setting due to thread switching doesn't count. */ + && bindflag != SET_INTERNAL_THREAD_SWITCH) + notify_variable_watchers (symbol, value, Qset_default, Qnil); + /* FALLTHROUGH! */ + case SYMBOL_UNTRAPPED_WRITE: + break; + + default: emacs_abort (); } - sym = XSYMBOL (symbol); start: switch (sym->redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; - case SYMBOL_PLAINVAL: return Fset (symbol, value); + case SYMBOL_PLAINVAL: set_internal (symbol, value, Qnil, bindflag); return; case SYMBOL_LOCALIZED: { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); @@ -1497,7 +1660,7 @@ for this variable. */) /* If the default binding is now loaded, set the REALVALUE slot too. */ if (blv->fwd && EQ (blv->defcell, blv->valcell)) store_symval_forwarding (blv->fwd, value, NULL); - return value; + return; } case SYMBOL_FORWARDED: { @@ -1523,15 +1686,25 @@ for this variable. */) if (!PER_BUFFER_VALUE_P (b, idx)) set_per_buffer_value (b, offset, value); } - return value; } else - return Fset (symbol, value); + set_internal (symbol, value, Qnil, bindflag); + return; } default: emacs_abort (); } } +DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, + doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated. +The default value is seen in buffers that do not have their own values +for this variable. */) + (Lisp_Object symbol, Lisp_Object value) +{ + set_default_internal (symbol, value, SET_INTERNAL_SET); + return value; +} + DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0, doc: /* Set the default value of variable VAR to VALUE. VAR, the variable name, is literal (not evaluated); @@ -1589,7 +1762,6 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded, eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd))); blv->fwd = forwarded ? valcontents.fwd : NULL; set_blv_where (blv, Qnil); - blv->frame_local = 0; blv->local_if_set = 0; set_blv_defcell (blv, tem); set_blv_valcell (blv, tem); @@ -1619,8 +1791,8 @@ The function `default-value' gets the default value and `set-default' sets it. { struct Lisp_Symbol *sym; struct Lisp_Buffer_Local_Value *blv = NULL; - union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO}); - bool forwarded IF_LINT (= 0); + union Lisp_Val_Fwd valcontents; + bool forwarded; CHECK_SYMBOL (variable); sym = XSYMBOL (variable); @@ -1636,9 +1808,6 @@ The function `default-value' gets the default value and `set-default' sets it. break; case SYMBOL_LOCALIZED: blv = SYMBOL_BLV (sym); - if (blv->frame_local) - error ("Symbol %s may not be buffer-local", - SDATA (SYMBOL_NAME (variable))); break; case SYMBOL_FORWARDED: forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym); @@ -1651,7 +1820,7 @@ The function `default-value' gets the default value and `set-default' sets it. default: emacs_abort (); } - if (sym->constant) + if (SYMBOL_CONSTANT_P (variable)) error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); if (!blv) @@ -1697,8 +1866,8 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) (Lisp_Object variable) { Lisp_Object tem; - bool forwarded IF_LINT (= 0); - union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO}); + bool forwarded; + union Lisp_Val_Fwd valcontents; struct Lisp_Symbol *sym; struct Lisp_Buffer_Local_Value *blv = NULL; @@ -1713,9 +1882,6 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break; case SYMBOL_LOCALIZED: blv = SYMBOL_BLV (sym); - if (blv->frame_local) - error ("Symbol %s may not be buffer-local", - SDATA (SYMBOL_NAME (variable))); break; case SYMBOL_FORWARDED: forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym); @@ -1726,7 +1892,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) default: emacs_abort (); } - if (sym->constant) + if (sym->trapped_write == SYMBOL_NOWRITE) error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); @@ -1832,12 +1998,13 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) } case SYMBOL_LOCALIZED: blv = SYMBOL_BLV (sym); - if (blv->frame_local) - return variable; break; default: emacs_abort (); } + if (sym->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ()); + /* Get rid of this buffer's alist element, if any. */ XSETSYMBOL (variable, sym); /* Propagate variable indirection. */ tem = Fassq (variable, BVAR (current_buffer, local_var_alist)); @@ -1864,81 +2031,6 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) /* Lisp functions for creating and removing buffer-local variables. */ -/* Obsolete since 22.2. NB adjust doc of modify-frame-parameters - when/if this is removed. */ - -DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local, - 1, 1, "vMake Variable Frame Local: ", - doc: /* Enable VARIABLE to have frame-local bindings. -This does not create any frame-local bindings for VARIABLE, -it just makes them possible. - -A frame-local binding is actually a frame parameter value. -If a frame F has a value for the frame parameter named VARIABLE, -that also acts as a frame-local binding for VARIABLE in F-- -provided this function has been called to enable VARIABLE -to have frame-local bindings at all. - -The only way to create a frame-local binding for VARIABLE in a frame -is to set the VARIABLE frame parameter of that frame. See -`modify-frame-parameters' for how to set frame parameters. - -Note that since Emacs 23.1, variables cannot be both buffer-local and -frame-local any more (buffer-local bindings used to take precedence over -frame-local bindings). */) - (Lisp_Object variable) -{ - bool forwarded; - union Lisp_Val_Fwd valcontents; - struct Lisp_Symbol *sym; - struct Lisp_Buffer_Local_Value *blv = NULL; - - CHECK_SYMBOL (variable); - sym = XSYMBOL (variable); - - start: - switch (sym->redirect) - { - case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; - case SYMBOL_PLAINVAL: - forwarded = 0; valcontents.value = SYMBOL_VAL (sym); - if (EQ (valcontents.value, Qunbound)) - valcontents.value = Qnil; - break; - case SYMBOL_LOCALIZED: - if (SYMBOL_BLV (sym)->frame_local) - return variable; - else - error ("Symbol %s may not be frame-local", - SDATA (SYMBOL_NAME (variable))); - case SYMBOL_FORWARDED: - forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym); - if (KBOARD_OBJFWDP (valcontents.fwd) || BUFFER_OBJFWDP (valcontents.fwd)) - error ("Symbol %s may not be frame-local", - SDATA (SYMBOL_NAME (variable))); - break; - default: emacs_abort (); - } - - if (sym->constant) - error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable))); - - blv = make_blv (sym, forwarded, valcontents); - blv->frame_local = 1; - sym->redirect = SYMBOL_LOCALIZED; - SET_SYMBOL_BLV (sym, blv); - { - Lisp_Object symbol; - XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */ - if (let_shadows_global_binding_p (symbol)) - { - AUTO_STRING (format, "Making %s frame-local while let-bound!"); - CALLN (Fmessage, format, SYMBOL_NAME (variable)); - } - } - return variable; -} - DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p, 1, 2, 0, doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER. @@ -1970,10 +2062,7 @@ BUFFER defaults to the current buffer. */) { elt = XCAR (tail); if (EQ (variable, XCAR (elt))) - { - eassert (!blv->frame_local); - return Qt; - } + return Qt; } return Qnil; } @@ -2032,7 +2121,6 @@ DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locu 1, 1, 0, doc: /* Return a value indicating where VARIABLE's current binding comes from. If the current binding is buffer-local, the value is the current buffer. -If the current binding is frame-local, the value is the selected frame. If the current binding is global (the default), the value is nil. */) (register Lisp_Object variable) { @@ -2463,7 +2551,7 @@ uintmax_t cons_to_unsigned (Lisp_Object c, uintmax_t max) { bool valid = 0; - uintmax_t val IF_LINT (= 0); + uintmax_t val; if (INTEGERP (c)) { valid = 0 <= XINT (c); @@ -2516,7 +2604,7 @@ intmax_t cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max) { bool valid = 0; - intmax_t val IF_LINT (= 0); + intmax_t val; if (INTEGERP (c)) { val = XINT (c); @@ -2774,7 +2862,7 @@ float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code, case Alogand: case Alogior: case Alogxor: - return wrong_type_argument (Qinteger_or_marker_p, val); + wrong_type_argument (Qinteger_or_marker_p, val); case Amax: if (!argnum || isnan (next) || next > accum) accum = next; @@ -2924,48 +3012,42 @@ usage: (logxor &rest INTS-OR-MARKERS) */) return arith_driver (Alogxor, nargs, args); } -DEFUN ("ash", Fash, Sash, 2, 2, 0, - doc: /* Return VALUE with its bits shifted left by COUNT. -If COUNT is negative, shifting is actually to the right. -In this case, the sign bit is duplicated. */) - (register Lisp_Object value, Lisp_Object count) +static Lisp_Object +ash_lsh_impl (register Lisp_Object value, Lisp_Object count, bool lsh) { register Lisp_Object val; CHECK_NUMBER (value); CHECK_NUMBER (count); - if (XINT (count) >= BITS_PER_EMACS_INT) + if (XINT (count) >= EMACS_INT_WIDTH) XSETINT (val, 0); else if (XINT (count) > 0) XSETINT (val, XUINT (value) << XFASTINT (count)); - else if (XINT (count) <= -BITS_PER_EMACS_INT) - XSETINT (val, XINT (value) < 0 ? -1 : 0); + else if (XINT (count) <= -EMACS_INT_WIDTH) + XSETINT (val, lsh ? 0 : XINT (value) < 0 ? -1 : 0); else - XSETINT (val, XINT (value) >> -XINT (count)); + XSETINT (val, lsh ? XUINT (value) >> -XINT (count) : \ + XINT (value) >> -XINT (count)); return val; } +DEFUN ("ash", Fash, Sash, 2, 2, 0, + doc: /* Return VALUE with its bits shifted left by COUNT. +If COUNT is negative, shifting is actually to the right. +In this case, the sign bit is duplicated. */) + (register Lisp_Object value, Lisp_Object count) +{ + return ash_lsh_impl (value, count, false); +} + DEFUN ("lsh", Flsh, Slsh, 2, 2, 0, doc: /* Return VALUE with its bits shifted left by COUNT. If COUNT is negative, shifting is actually to the right. In this case, zeros are shifted in on the left. */) (register Lisp_Object value, Lisp_Object count) { - register Lisp_Object val; - - CHECK_NUMBER (value); - CHECK_NUMBER (count); - - if (XINT (count) >= BITS_PER_EMACS_INT) - XSETINT (val, 0); - else if (XINT (count) > 0) - XSETINT (val, XUINT (value) << XFASTINT (count)); - else if (XINT (count) <= -BITS_PER_EMACS_INT) - XSETINT (val, 0); - else - XSETINT (val, XUINT (value) >> -XINT (count)); - return val; + return ash_lsh_impl (value, count, true); } DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, @@ -3031,24 +3113,24 @@ bool_vector_spare_mask (EMACS_INT nr_bits) /* Info about unsigned long long, falling back on unsigned long if unsigned long long is not available. */ -#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX -enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long long) }; +#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH +enum { ULL_WIDTH = ULLONG_WIDTH }; # define ULL_MAX ULLONG_MAX #else -enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long) }; +enum { ULL_WIDTH = ULONG_WIDTH }; # define ULL_MAX ULONG_MAX # define count_one_bits_ll count_one_bits_l # define count_trailing_zeros_ll count_trailing_zeros_l #endif /* Shift VAL right by the width of an unsigned long long. - BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */ + ULL_WIDTH must be less than BITS_PER_BITS_WORD. */ static bits_word shift_right_ull (bits_word w) { /* Pacify bogus GCC warning about shift count exceeding type width. */ - int shift = BITS_PER_ULL - BITS_PER_BITS_WORD < 0 ? BITS_PER_ULL : 0; + int shift = ULL_WIDTH - BITS_PER_BITS_WORD < 0 ? ULL_WIDTH : 0; return w >> shift; } @@ -3065,7 +3147,7 @@ count_one_bits_word (bits_word w) { int i = 0, count = 0; while (count += count_one_bits_ll (w), - (i += BITS_PER_ULL) < BITS_PER_BITS_WORD) + (i += ULL_WIDTH) < BITS_PER_BITS_WORD) w = shift_right_ull (w); return count; } @@ -3210,18 +3292,18 @@ count_trailing_zero_bits (bits_word val) { int count; for (count = 0; - count < BITS_PER_BITS_WORD - BITS_PER_ULL; - count += BITS_PER_ULL) + count < BITS_PER_BITS_WORD - ULL_WIDTH; + count += ULL_WIDTH) { if (val & ULL_MAX) return count + count_trailing_zeros_ll (val); val = shift_right_ull (val); } - if (BITS_PER_BITS_WORD % BITS_PER_ULL != 0 + if (BITS_PER_BITS_WORD % ULL_WIDTH != 0 && BITS_WORD_MAX == (bits_word) -1) val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX, - BITS_PER_BITS_WORD % BITS_PER_ULL); + BITS_PER_BITS_WORD % ULL_WIDTH); return count + count_trailing_zeros_ll (val); } } @@ -3471,6 +3553,7 @@ syms_of_data (void) DEFSYM (Qcyclic_variable_indirection, "cyclic-variable-indirection"); DEFSYM (Qvoid_variable, "void-variable"); DEFSYM (Qsetting_constant, "setting-constant"); + DEFSYM (Qtrapping_constant, "trapping-constant"); DEFSYM (Qinvalid_read_syntax, "invalid-read-syntax"); DEFSYM (Qinvalid_function, "invalid-function"); @@ -3549,6 +3632,8 @@ syms_of_data (void) PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void"); PUT_ERROR (Qsetting_constant, error_tail, "Attempt to set a constant symbol"); + PUT_ERROR (Qtrapping_constant, error_tail, + "Attempt to trap writes to a constant symbol"); PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax"); PUT_ERROR (Qinvalid_function, error_tail, "Invalid function"); PUT_ERROR (Qwrong_number_of_arguments, error_tail, @@ -3606,6 +3691,9 @@ syms_of_data (void) DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); + DEFSYM (Qthread, "thread"); + DEFSYM (Qmutex, "mutex"); + DEFSYM (Qcondition_variable, "condition-variable"); DEFSYM (Qdefun, "defun"); @@ -3646,6 +3734,9 @@ syms_of_data (void) defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); defsubr (&Schar_or_string_p); + defsubr (&Sthreadp); + defsubr (&Smutexp); + defsubr (&Scondition_variable_p); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); @@ -3672,7 +3763,6 @@ syms_of_data (void) defsubr (&Smake_variable_buffer_local); defsubr (&Smake_local_variable); defsubr (&Skill_local_variable); - defsubr (&Smake_variable_frame_local); defsubr (&Slocal_variable_p); defsubr (&Slocal_variable_if_set_p); defsubr (&Svariable_binding_locus); @@ -3727,10 +3817,19 @@ syms_of_data (void) DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum, doc: /* The largest value that is representable in a Lisp integer. */); Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM); - XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1; + make_symbol_constant (intern_c_string ("most-positive-fixnum")); DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum, doc: /* The smallest value that is representable in a Lisp integer. */); Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM); - XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1; + make_symbol_constant (intern_c_string ("most-negative-fixnum")); + + DEFSYM (Qwatchers, "watchers"); + DEFSYM (Qmakunbound, "makunbound"); + DEFSYM (Qunlet, "unlet"); + DEFSYM (Qset, "set"); + DEFSYM (Qset_default, "set-default"); + defsubr (&Sadd_variable_watcher); + defsubr (&Sremove_variable_watcher); + defsubr (&Sget_variable_watchers); } diff --git a/src/dbusbind.c b/src/dbusbind.c index 56bfd7164a4..08b7cc2ddf2 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -20,6 +20,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #ifdef HAVE_DBUS #include <stdio.h> +#include <stdlib.h> #include <dbus/dbus.h> #include "lisp.h" @@ -90,7 +91,7 @@ static bool xd_in_read_queued_messages = 0; } while (0) /* Macros for debugging. In order to enable them, build with - "env MYCPPFLAGS='-DDBUS_DEBUG -Wall' make". */ + "make MYCPPFLAGS='-DDBUS_DEBUG'". */ #ifdef DBUS_DEBUG #define XD_DEBUG_MESSAGE(...) \ do { \ @@ -168,25 +169,25 @@ static int xd_symbol_to_dbus_type (Lisp_Object object) { return - ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE - : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN - : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16 - : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16 - : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32 - : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32 - : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64 - : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64 - : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE - : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING - : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH - : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE + (EQ (object, QCbyte) ? DBUS_TYPE_BYTE + : EQ (object, QCboolean) ? DBUS_TYPE_BOOLEAN + : EQ (object, QCint16) ? DBUS_TYPE_INT16 + : EQ (object, QCuint16) ? DBUS_TYPE_UINT16 + : EQ (object, QCint32) ? DBUS_TYPE_INT32 + : EQ (object, QCuint32) ? DBUS_TYPE_UINT32 + : EQ (object, QCint64) ? DBUS_TYPE_INT64 + : EQ (object, QCuint64) ? DBUS_TYPE_UINT64 + : EQ (object, QCdouble) ? DBUS_TYPE_DOUBLE + : EQ (object, QCstring) ? DBUS_TYPE_STRING + : EQ (object, QCobject_path) ? DBUS_TYPE_OBJECT_PATH + : EQ (object, QCsignature) ? DBUS_TYPE_SIGNATURE #ifdef DBUS_TYPE_UNIX_FD - : (EQ (object, QCdbus_type_unix_fd)) ? DBUS_TYPE_UNIX_FD + : EQ (object, QCunix_fd) ? DBUS_TYPE_UNIX_FD #endif - : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY - : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT - : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT - : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY + : EQ (object, QCarray) ? DBUS_TYPE_ARRAY + : EQ (object, QCvariant) ? DBUS_TYPE_VARIANT + : EQ (object, QCstruct) ? DBUS_TYPE_STRUCT + : EQ (object, QCdict_entry) ? DBUS_TYPE_DICT_ENTRY : DBUS_TYPE_INVALID); } @@ -257,16 +258,16 @@ XD_OBJECT_TO_STRING (Lisp_Object object) if ((session_bus_address != NULL) \ && (!NILP (Fstring_equal \ (bus, build_string (session_bus_address))))) \ - bus = QCdbus_session_bus; \ + bus = QCsession; \ } \ \ else \ { \ CHECK_SYMBOL (bus); \ - if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus))) \ + if (!(EQ (bus, QCsystem) || EQ (bus, QCsession))) \ XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \ /* We do not want to have an autolaunch for the session bus. */ \ - if (EQ (bus, QCdbus_session_bus) && session_bus_address == NULL) \ + if (EQ (bus, QCsession) && session_bus_address == NULL) \ XD_SIGNAL2 (build_string ("No connection to bus"), bus); \ } \ } while (0) @@ -395,7 +396,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) CHECK_CONS (object); /* Type symbol is optional. */ - if (EQ (QCdbus_type_array, CAR_SAFE (elt))) + if (EQ (QCarray, CAR_SAFE (elt))) elt = XD_NEXT_VALUE (elt); /* If the array is empty, DBUS_TYPE_STRING is the default @@ -1009,8 +1010,7 @@ xd_add_watch (DBusWatch *watch, void *data) } /* Stop monitoring WATCH for possible I/O. - DATA is the used bus, either a string or QCdbus_system_bus or - QCdbus_session_bus. */ + DATA is the used bus, either a string or QCsystem or QCsession. */ static void xd_remove_watch (DBusWatch *watch, void *data) { @@ -1025,7 +1025,7 @@ xd_remove_watch (DBusWatch *watch, void *data) /* Unset session environment. */ #if 0 /* This is buggy, since unsetenv is not thread-safe. */ - if (XSYMBOL (QCdbus_session_bus) == data) + if (XSYMBOL (QCsession) == data) { XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS"); unsetenv ("DBUS_SESSION_BUS_ADDRESS"); @@ -1147,14 +1147,14 @@ this connection to those buses. */) connection = dbus_connection_open_private (SSDATA (bus), &derror); else - if (NILP (private)) - connection = dbus_bus_get (EQ (bus, QCdbus_system_bus) - ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION, - &derror); - else - connection = dbus_bus_get_private (EQ (bus, QCdbus_system_bus) - ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION, - &derror); + { + DBusBusType bustype = (EQ (bus, QCsystem) + ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION); + if (NILP (private)) + connection = dbus_bus_get (bustype, &derror); + else + connection = dbus_bus_get_private (bustype, &derror); + } if (dbus_error_is_set (&derror)) XD_ERROR (derror); @@ -1309,7 +1309,7 @@ usage: (dbus-message-internal &rest REST) */) XD_DBUS_VALIDATE_PATH (path); XD_DBUS_VALIDATE_INTERFACE (interface); XD_DBUS_VALIDATE_MEMBER (member); - if (!NILP (handler) && (!FUNCTIONP (handler))) + if (!NILP (handler) && !FUNCTIONP (handler)) wrong_type_argument (Qinvalid_function, handler); } @@ -1405,7 +1405,7 @@ usage: (dbus-message-internal &rest REST) */) } /* Check for timeout parameter. */ - if ((count+2 <= nargs) && (EQ ((args[count]), QCdbus_timeout))) + if ((count + 2 <= nargs) && EQ (args[count], QCtimeout)) { CHECK_NATNUM (args[count+1]); timeout = min (XFASTINT (args[count+1]), INT_MAX); @@ -1452,8 +1452,7 @@ usage: (dbus-message-internal &rest REST) */) /* The result is the key in Vdbus_registered_objects_table. */ serial = dbus_message_get_serial (dmessage); - result = list3 (QCdbus_registered_serial, - bus, make_fixnum_or_float (serial)); + result = list3 (QCserial, bus, make_fixnum_or_float (serial)); /* Create a hash table entry. */ Fputhash (result, handler, Vdbus_registered_objects_table); @@ -1540,8 +1539,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) || (mtype == DBUS_MESSAGE_TYPE_ERROR)) { /* Search for a registered function of the message. */ - key = list3 (QCdbus_registered_serial, bus, - make_fixnum_or_float (serial)); + key = list3 (QCserial, bus, make_fixnum_or_float (serial)); value = Fgethash (key, Vdbus_registered_objects_table, Qnil); /* There shall be exactly one entry. Construct an event. */ @@ -1566,9 +1564,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) goto cleanup; /* Search for a registered function of the message. */ - key = list4 ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) - ? QCdbus_registered_method - : QCdbus_registered_signal, + key = list4 (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL ? QCmethod : QCsignal, bus, build_string (interface), build_string (member)); value = Fgethash (key, Vdbus_registered_objects_table, Qnil); @@ -1697,37 +1693,37 @@ syms_of_dbusbind (void) build_pure_c_string ("D-Bus error")); /* Lisp symbols of the system and session buses. */ - DEFSYM (QCdbus_system_bus, ":system"); - DEFSYM (QCdbus_session_bus, ":session"); + DEFSYM (QCsystem, ":system"); + DEFSYM (QCsession, ":session"); /* Lisp symbol for method call timeout. */ - DEFSYM (QCdbus_timeout, ":timeout"); + DEFSYM (QCtimeout, ":timeout"); /* Lisp symbols of D-Bus types. */ - DEFSYM (QCdbus_type_byte, ":byte"); - DEFSYM (QCdbus_type_boolean, ":boolean"); - DEFSYM (QCdbus_type_int16, ":int16"); - DEFSYM (QCdbus_type_uint16, ":uint16"); - DEFSYM (QCdbus_type_int32, ":int32"); - DEFSYM (QCdbus_type_uint32, ":uint32"); - DEFSYM (QCdbus_type_int64, ":int64"); - DEFSYM (QCdbus_type_uint64, ":uint64"); - DEFSYM (QCdbus_type_double, ":double"); - DEFSYM (QCdbus_type_string, ":string"); - DEFSYM (QCdbus_type_object_path, ":object-path"); - DEFSYM (QCdbus_type_signature, ":signature"); + DEFSYM (QCbyte, ":byte"); + DEFSYM (QCboolean, ":boolean"); + DEFSYM (QCint16, ":int16"); + DEFSYM (QCuint16, ":uint16"); + DEFSYM (QCint32, ":int32"); + DEFSYM (QCuint32, ":uint32"); + DEFSYM (QCint64, ":int64"); + DEFSYM (QCuint64, ":uint64"); + DEFSYM (QCdouble, ":double"); + DEFSYM (QCstring, ":string"); + DEFSYM (QCobject_path, ":object-path"); + DEFSYM (QCsignature, ":signature"); #ifdef DBUS_TYPE_UNIX_FD - DEFSYM (QCdbus_type_unix_fd, ":unix-fd"); + DEFSYM (QCunix_fd, ":unix-fd"); #endif - DEFSYM (QCdbus_type_array, ":array"); - DEFSYM (QCdbus_type_variant, ":variant"); - DEFSYM (QCdbus_type_struct, ":struct"); - DEFSYM (QCdbus_type_dict_entry, ":dict-entry"); + DEFSYM (QCarray, ":array"); + DEFSYM (QCvariant, ":variant"); + DEFSYM (QCstruct, ":struct"); + DEFSYM (QCdict_entry, ":dict-entry"); /* Lisp symbols of objects in `dbus-registered-objects-table'. */ - DEFSYM (QCdbus_registered_serial, ":serial"); - DEFSYM (QCdbus_registered_method, ":method"); - DEFSYM (QCdbus_registered_signal, ":signal"); + DEFSYM (QCserial, ":serial"); + DEFSYM (QCmethod, ":method"); + DEFSYM (QCsignal, ":signal"); DEFVAR_LISP ("dbus-compiled-version", Vdbus_compiled_version, diff --git a/src/decompress.c b/src/decompress.c index 1213f482f77..6ebf74aaf5e 100644 --- a/src/decompress.c +++ b/src/decompress.c @@ -42,7 +42,7 @@ static bool zlib_initialized; static bool init_zlib_functions (void) { - HMODULE library = w32_delayed_load (Qzlib_dll); + HMODULE library = w32_delayed_load (Qzlib); if (!library) return false; @@ -91,7 +91,7 @@ DEFUN ("zlib-available-p", Fzlib_available_p, Szlib_available_p, 0, 0, 0, (void) { #ifdef WINDOWSNT - Lisp_Object found = Fassq (Qzlib_dll, Vlibrary_cache); + Lisp_Object found = Fassq (Qzlib, Vlibrary_cache); if (CONSP (found)) return XCDR (found); else @@ -99,7 +99,7 @@ DEFUN ("zlib-available-p", Fzlib_available_p, Szlib_available_p, 0, 0, 0, Lisp_Object status; zlib_initialized = init_zlib_functions (); status = zlib_initialized ? Qt : Qnil; - Vlibrary_cache = Fcons (Fcons (Qzlib_dll, status), Vlibrary_cache); + Vlibrary_cache = Fcons (Fcons (Qzlib, status), Vlibrary_cache); return status; } #else diff --git a/src/dired.c b/src/dired.c index dba575ce4c2..702917ea704 100644 --- a/src/dired.c +++ b/src/dired.c @@ -21,7 +21,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> -#include <sys/types.h> #include <sys/stat.h> #ifdef HAVE_PWD_H @@ -42,12 +41,15 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "buffer.h" #include "coding.h" #include "regex.h" -#include "blockinput.h" #ifdef MSDOS #include "msdos.h" /* for fstatat */ #endif +#ifdef WINDOWSNT +extern int is_slow_fs (const char *); +#endif + static ptrdiff_t scmp (const char *, const char *, ptrdiff_t); static Lisp_Object file_attributes (int, char const *, Lisp_Object); @@ -69,8 +71,6 @@ open_directory (Lisp_Object dirname, int *fdp) DIR *d; int fd, opendir_errno; - block_input (); - #ifdef DOS_NT /* Directories cannot be opened. The emulation assumes that any file descriptor other than AT_FDCWD corresponds to the most @@ -94,8 +94,6 @@ open_directory (Lisp_Object dirname, int *fdp) } #endif - unblock_input (); - if (!d) report_file_errno ("Opening directory", dirname, opendir_errno); *fdp = fd; @@ -103,7 +101,7 @@ open_directory (Lisp_Object dirname, int *fdp) } #ifdef WINDOWSNT -void +static void directory_files_internal_w32_unwind (Lisp_Object arg) { Vw32_get_true_file_attributes = arg; @@ -111,12 +109,9 @@ directory_files_internal_w32_unwind (Lisp_Object arg) #endif static void -directory_files_internal_unwind (void *dh) +directory_files_internal_unwind (void *d) { - DIR *d = dh; - block_input (); closedir (d); - unblock_input (); } /* Return the next directory entry from DIR; DIR's name is DIRNAME. @@ -214,8 +209,6 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, #ifdef WINDOWSNT if (attrs) { - extern int is_slow_fs (const char *); - /* Do this only once to avoid doing it (in w32.c:stat) for each file in the directory, when we call Ffile_attributes below. */ record_unwind_protect (directory_files_internal_w32_unwind, @@ -225,7 +218,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, { /* w32.c:stat will notice these bindings and avoid calling GetDriveType for each file. */ - if (is_slow_fs (SDATA (dirfilename))) + if (is_slow_fs (SSDATA (dirfilename))) Vw32_get_true_file_attributes = Qnil; else Vw32_get_true_file_attributes = Qt; @@ -307,9 +300,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, } } - block_input (); closedir (d); - unblock_input (); #ifdef WINDOWSNT if (attrs) Vw32_get_true_file_attributes = w32_save; @@ -860,6 +851,14 @@ below) - valid values are `string' and `integer'. The latter is the default, but we plan to change that, so you should specify a non-nil value for ID-FORMAT if you use the returned uid or gid. +To access the elements returned, the following access functions are +provided: `file-attribute-type', `file-attribute-link-number', +`file-attribute-user-id', `file-attribute-group-id', +`file-attribute-access-time', `file-attribute-modification-time', +`file-attribute-status-change-time', `file-attribute-size', +`file-attribute-modes', `file-attribute-inode-number', and +`file-attribute-device-number'. + Elements of the attribute list are: 0. t for directory, string (name linked to) for symbolic link, or nil. 1. Number of links to file. @@ -950,10 +949,8 @@ file_attributes (int fd, char const *name, Lisp_Object id_format) if (!(NILP (id_format) || EQ (id_format, Qinteger))) { - block_input (); uname = stat_uname (&s); gname = stat_gname (&s); - unblock_input (); } filemodestring (&s, modes); diff --git a/src/dispextern.h b/src/dispextern.h index 7b9ae78dcd3..4acf3362c69 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -82,6 +82,7 @@ typedef XImagePtr XImagePtr_or_DC; #ifdef HAVE_WINDOW_SYSTEM # include <time.h> +# include "fontset.h" #endif #ifndef HAVE_WINDOW_SYSTEM @@ -1275,7 +1276,6 @@ struct glyph_string /* X display and window for convenience. */ Display *display; - Window window; /* The glyph row for which this string was built. It determines the y-origin and height of the string. */ @@ -1812,36 +1812,46 @@ struct face_cache bool_bf menu_face_changed_p : 1; }; +/* Return a non-null pointer to the cached face with ID on frame F. */ + +#define FACE_FROM_ID(F, ID) \ + (eassert (UNSIGNED_CMP (ID, <, FRAME_FACE_CACHE (F)->used)), \ + FRAME_FACE_CACHE (F)->faces_by_id[ID]) + /* Return a pointer to the face with ID on frame F, or null if such a face doesn't exist. */ -#define FACE_FROM_ID(F, ID) \ - (UNSIGNED_CMP (ID, <, FRAME_FACE_CACHE (F)->used) \ - ? FRAME_FACE_CACHE (F)->faces_by_id[ID] \ - : NULL) +#define FACE_FROM_ID_OR_NULL(F, ID) \ + (UNSIGNED_CMP (ID, <, FRAME_FACE_CACHE (F)->used) \ + ? FRAME_FACE_CACHE (F)->faces_by_id[ID] \ + : NULL) +/* True if FACE is suitable for displaying ASCII characters. */ +INLINE bool +FACE_SUITABLE_FOR_ASCII_CHAR_P (struct face *face) +{ #ifdef HAVE_WINDOW_SYSTEM - -/* Non-zero if FACE is suitable for displaying character CHAR. */ - -#define FACE_SUITABLE_FOR_ASCII_CHAR_P(FACE, CHAR) \ - ((FACE) == (FACE)->ascii_face) + return face == face->ascii_face; +#else + return true; +#endif +} /* Return the id of the realized face on frame F that is like the face - FACE, but is suitable for displaying character CHAR at buffer or + FACE, but is suitable for displaying character CHARACTER at buffer or string position POS. OBJECT is the string object, or nil for buffer. This macro is only meaningful for multibyte character CHAR. */ - -#define FACE_FOR_CHAR(F, FACE, CHAR, POS, OBJECT) \ - face_for_char ((F), (FACE), (CHAR), (POS), (OBJECT)) - -#else /* not HAVE_WINDOW_SYSTEM */ - -#define FACE_SUITABLE_FOR_ASCII_CHAR_P(FACE, CHAR) true -#define FACE_FOR_CHAR(F, FACE, CHAR, POS, OBJECT) ((FACE)->id) - -#endif /* not HAVE_WINDOW_SYSTEM */ +INLINE int +FACE_FOR_CHAR (struct frame *f, struct face *face, int character, + ptrdiff_t pos, Lisp_Object object) +{ +#ifdef HAVE_WINDOW_SYSTEM + return face_for_char (f, face, character, pos, object); +#else + return face->id; +#endif +} /* Return true if G contains a valid character code. */ INLINE bool @@ -2226,7 +2236,7 @@ struct composition_it /* Indices of the glyphs for the current grapheme cluster. */ int from, to; /* Width of the current grapheme cluster in units of columns it will - occupy on display; see CHAR_WIDTH. */ + occupy on display; see CHARACTER_WIDTH. */ int width; }; @@ -3083,13 +3093,19 @@ struct image_cache }; +/* A non-null pointer to the image with id ID on frame F. */ + +#define IMAGE_FROM_ID(F, ID) \ + (eassert (UNSIGNED_CMP (ID, <, FRAME_IMAGE_CACHE (F)->used)), \ + FRAME_IMAGE_CACHE (F)->images[ID]) + /* Value is a pointer to the image with id ID on frame F, or null if no image with that id exists. */ -#define IMAGE_FROM_ID(F, ID) \ - (((ID) >= 0 && (ID) < (FRAME_IMAGE_CACHE (F)->used)) \ - ? FRAME_IMAGE_CACHE (F)->images[ID] \ - : NULL) +#define IMAGE_OPT_FROM_ID(F, ID) \ + (UNSIGNED_CMP (ID, <, FRAME_IMAGE_CACHE (F)->used) \ + ? FRAME_IMAGE_CACHE (F)->images[ID] \ + : NULL) /* Size of bucket vector of image caches. Should be prime. */ @@ -3340,6 +3356,8 @@ void x_cr_init_fringe (struct redisplay_interface *); extern unsigned row_hash (struct glyph_row *); +extern bool buffer_flipping_blocked_p (void); + /* Defined in image.c */ #ifdef HAVE_WINDOW_SYSTEM diff --git a/src/dispnew.c b/src/dispnew.c index 3a0532a693b..70d4de07aac 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include "sysstdio.h" +#include <stdlib.h> #include <unistd.h> #include "lisp.h" @@ -5177,8 +5178,8 @@ buffer_posn_from_coords (struct window *w, int *x, int *y, struct display_pos *p #ifdef HAVE_WINDOW_SYSTEM if (it.what == IT_IMAGE) { - if ((img = IMAGE_FROM_ID (it.f, it.image_id)) != NULL - && !NILP (img->spec)) + img = IMAGE_OPT_FROM_ID (it.f, it.image_id); + if (img && !NILP (img->spec)) *object = img->spec; } #endif @@ -5275,7 +5276,7 @@ mode_line_string (struct window *w, enum window_part part, if (glyph->type == IMAGE_GLYPH) { struct image *img; - img = IMAGE_FROM_ID (WINDOW_XFRAME (w), glyph->u.img_id); + img = IMAGE_OPT_FROM_ID (WINDOW_XFRAME (w), glyph->u.img_id); if (img != NULL) *object = img->spec; y0 -= row->ascent - glyph->ascent; @@ -5362,7 +5363,7 @@ marginal_area_string (struct window *w, enum window_part part, if (glyph->type == IMAGE_GLYPH) { struct image *img; - img = IMAGE_FROM_ID (WINDOW_XFRAME (w), glyph->u.img_id); + img = IMAGE_OPT_FROM_ID (WINDOW_XFRAME (w), glyph->u.img_id); if (img != NULL) *object = img->spec; y0 -= row->ascent - glyph->ascent; @@ -6038,11 +6039,11 @@ init_display (void) #endif /* If no window system has been specified, try to use the terminal. */ - if (! isatty (0)) + if (! isatty (STDIN_FILENO)) fatal ("standard input is not a tty"); #ifdef WINDOWSNT - terminal_type = "w32console"; + terminal_type = (char *)"w32console"; #else terminal_type = getenv ("TERM"); #endif diff --git a/src/doc.c b/src/doc.c index 36d18b99b05..6a78ed657c1 100644 --- a/src/doc.c +++ b/src/doc.c @@ -339,16 +339,7 @@ string is passed through `substitute-command-keys'. */) if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) fun = XCDR (fun); if (SUBRP (fun)) - { - if (XSUBR (fun)->doc == 0) - return Qnil; - /* FIXME: This is not portable, as it assumes that string - pointers have the top bit clear. */ - else if ((intptr_t) XSUBR (fun)->doc >= 0) - doc = build_string (XSUBR (fun)->doc); - else - doc = make_number ((intptr_t) XSUBR (fun)->doc); - } + doc = make_number (XSUBR (fun)->doc); else if (COMPILEDP (fun)) { if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_DOC_STRING) @@ -473,7 +464,7 @@ aren't strings. */) /* Scanning the DOC files and placing docstring offsets into functions. */ static void -store_function_docstring (Lisp_Object obj, ptrdiff_t offset) +store_function_docstring (Lisp_Object obj, EMACS_INT offset) { /* Don't use indirect_function here, or defaliases will apply their docstrings to the base functions (Bug#2603). */ @@ -481,15 +472,10 @@ store_function_docstring (Lisp_Object obj, ptrdiff_t offset) /* The type determines where the docstring is stored. */ - /* Lisp_Subrs have a slot for it. */ - if (SUBRP (fun)) - { - intptr_t negative_offset = - offset; - XSUBR (fun)->doc = (char *) negative_offset; - } - /* If it's a lisp form, stick it in the form. */ - else if (CONSP (fun)) + if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) + fun = XCDR (fun); + if (CONSP (fun)) { Lisp_Object tem; @@ -503,10 +489,12 @@ store_function_docstring (Lisp_Object obj, ptrdiff_t offset) correctness is quite delicate. */ XSETCAR (tem, make_number (offset)); } - else if (EQ (tem, Qmacro)) - store_function_docstring (XCDR (fun), offset); } + /* Lisp_Subrs have a slot for it. */ + else if (SUBRP (fun)) + XSUBR (fun)->doc = offset; + /* Bytecode objects sometimes have slots for it. */ else if (COMPILEDP (fun)) { @@ -726,13 +714,13 @@ summary). Each substring of the form \\=\\<MAPVAR> specifies the use of MAPVAR as the keymap for future \\=\\[COMMAND] substrings. -Each \\=‘ and \\=` is replaced by left quote, and each \\=’ and \\=' +Each grave accent \\=` is replaced by left quote, and each apostrophe \\=' is replaced by right quote. Left and right quote characters are specified by `text-quoting-style'. -\\=\\= quotes the following character and is discarded; thus, -\\=\\=\\=\\= puts \\=\\= into the output, \\=\\=\\=\\[ puts \\=\\[ into the output, and -\\=\\=\\=` puts \\=` into the output. +\\=\\= quotes the following character and is discarded; thus, \\=\\=\\=\\= puts \\=\\= +into the output, \\=\\=\\=\\[ puts \\=\\[ into the output, and \\=\\=\\=` puts \\=` into the +output. Return the original STRING if no substitutions are made. Otherwise, return a new string. */) @@ -750,25 +738,20 @@ Otherwise, return a new string. */) unsigned char const *start; ptrdiff_t length, length_byte; Lisp_Object name; - bool multibyte, pure_ascii; ptrdiff_t nchars; if (NILP (string)) return Qnil; - CHECK_STRING (string); - tem = Qnil; - keymap = Qnil; - name = Qnil; + /* If STRING contains non-ASCII unibyte data, process its + properly-encoded multibyte equivalent instead. This simplifies + the implementation and is OK since substitute-command-keys is + intended for use only on text strings. Keep STRING around, since + it will be returned if no changes occur. */ + Lisp_Object str = Fstring_make_multibyte (string); enum text_quoting_style quoting_style = text_quoting_style (); - multibyte = STRING_MULTIBYTE (string); - /* Pure-ASCII unibyte input strings should produce unibyte strings - if substitution doesn't yield non-ASCII bytes, otherwise they - should produce multibyte strings. */ - pure_ascii = SBYTES (string) == count_size_as_multibyte (SDATA (string), - SCHARS (string)); nchars = 0; /* KEYMAP is either nil (which means search all the active keymaps) @@ -777,59 +760,58 @@ Otherwise, return a new string. */) or from a \\<mapname> construct in STRING itself.. */ keymap = Voverriding_local_map; - bsize = SBYTES (string); + ptrdiff_t strbytes = SBYTES (str); + bsize = strbytes; + + /* Fixed-size stack buffer. */ + char sbuf[MAX_ALLOCA]; - /* Add some room for expansion due to quote replacement. */ - enum { EXTRA_ROOM = 20 }; - if (bsize <= STRING_BYTES_BOUND - EXTRA_ROOM) - bsize += EXTRA_ROOM; + /* Heap-allocated buffer, if any. */ + char *abuf; - bufp = buf = xmalloc (bsize); + /* Extra room for expansion due to replacing ‘\[]’ with ‘M-x ’. */ + enum { EXTRA_ROOM = sizeof "M-x " - sizeof "\\[]" }; - strp = SDATA (string); - while (strp < SDATA (string) + SBYTES (string)) + ptrdiff_t count = SPECPDL_INDEX (); + + if (bsize <= sizeof sbuf - EXTRA_ROOM) { - if (strp[0] == '\\' && strp[1] == '=') + abuf = NULL; + buf = sbuf; + bsize = sizeof sbuf; + } + else + { + buf = abuf = xpalloc (NULL, &bsize, EXTRA_ROOM, STRING_BYTES_BOUND, 1); + record_unwind_protect_ptr (xfree, abuf); + } + bufp = buf; + + strp = SDATA (str); + while (strp < SDATA (str) + strbytes) + { + unsigned char *close_bracket; + + if (strp[0] == '\\' && strp[1] == '=' + && strp + 2 < SDATA (str) + strbytes) { /* \= quotes the next character; thus, to put in \[ without its special meaning, use \=\[. */ changed = nonquotes_changed = true; strp += 2; - if (multibyte) - { - int len; - - STRING_CHAR_AND_LENGTH (strp, len); - if (len == 1) - *bufp = *strp; - else - memcpy (bufp, strp, len); - strp += len; - bufp += len; - nchars++; - } - else - *bufp++ = *strp++, nchars++; + /* Fall through to copy one char. */ } - else if (strp[0] == '\\' && strp[1] == '[') + else if (strp[0] == '\\' && strp[1] == '[' + && (close_bracket + = memchr (strp + 2, ']', + SDATA (str) + strbytes - (strp + 2)))) { - ptrdiff_t start_idx; bool follow_remap = 1; - strp += 2; /* skip \[ */ - start = strp; - start_idx = start - SDATA (string); - - while ((strp - SDATA (string) - < SBYTES (string)) - && *strp != ']') - strp++; - length_byte = strp - start; - - strp++; /* skip ] */ + start = strp + 2; + length_byte = close_bracket - start; + idx = close_bracket + 1 - SDATA (str); - /* Save STRP in IDX. */ - idx = strp - SDATA (string); name = Fintern (make_string ((char *) start, length_byte), Qnil); do_remap: @@ -844,25 +826,17 @@ Otherwise, return a new string. */) goto do_remap; } - /* Note the Fwhere_is_internal can GC, so we have to take - relocation of string contents into account. */ - strp = SDATA (string) + idx; - start = SDATA (string) + start_idx; + /* Fwhere_is_internal can GC, so take relocation of string + contents into account. */ + strp = SDATA (str) + idx; + start = strp - length_byte - 1; if (NILP (tem)) /* but not on any keys */ { - ptrdiff_t offset = bufp - buf; - if (STRING_BYTES_BOUND - 4 < bsize) - string_overflow (); - buf = xrealloc (buf, bsize += 4); - bufp = buf + offset; memcpy (bufp, "M-x ", 4); bufp += 4; nchars += 4; - if (multibyte) - length = multibyte_chars_in_text (start, length_byte); - else - length = length_byte; + length = multibyte_chars_in_text (start, length_byte); goto subst; } else @@ -873,28 +847,20 @@ Otherwise, return a new string. */) } /* \{foo} is replaced with a summary of the keymap (symbol-value foo). \<foo> just sets the keymap used for \[cmd]. */ - else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<')) + else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<') + && (close_bracket + = memchr (strp + 2, strp[1] == '{' ? '}' : '>', + SDATA (str) + strbytes - (strp + 2)))) { - struct buffer *oldbuf; - ptrdiff_t start_idx; + { + bool generate_summary = strp[1] == '{'; /* This is for computing the SHADOWS arg for describe_map_tree. */ Lisp_Object active_maps = Fcurrent_active_maps (Qnil, Qnil); - Lisp_Object earlier_maps; ptrdiff_t count = SPECPDL_INDEX (); - strp += 2; /* skip \{ or \< */ - start = strp; - start_idx = start - SDATA (string); - - while ((strp - SDATA (string) < SBYTES (string)) - && *strp != '}' && *strp != '>') - strp++; - - length_byte = strp - start; - strp++; /* skip } or > */ - - /* Save STRP in IDX. */ - idx = strp - SDATA (string); + start = strp + 2; + length_byte = close_bracket - start; + idx = close_bracket + 1 - SDATA (str); /* Get the value of the keymap in TEM, or nil if undefined. Do this while still in the user's current buffer @@ -905,16 +871,11 @@ Otherwise, return a new string. */) { tem = Fsymbol_value (name); if (! NILP (tem)) - { - tem = get_keymap (tem, 0, 1); - /* Note that get_keymap can GC. */ - strp = SDATA (string) + idx; - start = SDATA (string) + start_idx; - } + tem = get_keymap (tem, 0, 1); } /* Now switch to a temp buffer. */ - oldbuf = current_buffer; + struct buffer *oldbuf = current_buffer; set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); /* This is for an unusual case where some after-change function uses 'format' or 'prin1' or something else that @@ -931,15 +892,17 @@ Otherwise, return a new string. */) SBYTES (name), 1); AUTO_STRING (msg_suffix, "', which is not currently defined.\n"); insert1 (Fsubstitute_command_keys (msg_suffix)); - if (start[-1] == '<') keymap = Qnil; + if (!generate_summary) + keymap = Qnil; } - else if (start[-1] == '<') + else if (!generate_summary) keymap = tem; else { /* Get the list of active keymaps that precede this one. If this one's not active, get nil. */ - earlier_maps = Fcdr (Fmemq (tem, Freverse (active_maps))); + Lisp_Object earlier_maps + = Fcdr (Fmemq (tem, Freverse (active_maps))); describe_map_tree (tem, 1, Fnreverse (earlier_maps), Qnil, 0, 1, 0, 0, 1); } @@ -947,42 +910,57 @@ Otherwise, return a new string. */) Ferase_buffer (); set_buffer_internal (oldbuf); unbind_to (count, Qnil); + } subst_string: + /* Convert non-ASCII unibyte data to properly-encoded multibyte, + for the same reason STRING was converted to STR. */ + tem = Fstring_make_multibyte (tem); start = SDATA (tem); + length = SCHARS (tem); length_byte = SBYTES (tem); - if (multibyte || pure_ascii) - length = SCHARS (tem); - else - length = length_byte; subst: nonquotes_changed = true; subst_quote: changed = true; { ptrdiff_t offset = bufp - buf; - if (STRING_BYTES_BOUND - length_byte < bsize) + ptrdiff_t avail = bsize - offset; + ptrdiff_t need = strbytes - idx; + if (INT_ADD_WRAPV (need, length_byte + EXTRA_ROOM, &need)) string_overflow (); - buf = xrealloc (buf, bsize += length_byte); - bufp = buf + offset; + if (avail < need) + { + abuf = xpalloc (abuf, &bsize, need - avail, + STRING_BYTES_BOUND, 1); + if (buf == sbuf) + { + record_unwind_protect_ptr (xfree, abuf); + memcpy (abuf, sbuf, offset); + } + else + set_unwind_protect_ptr (count, xfree, abuf); + buf = abuf; + bufp = buf + offset; + } memcpy (bufp, start, length_byte); bufp += length_byte; nchars += length; - /* Check STRING again in case gc relocated it. */ - strp = SDATA (string) + idx; + + /* Some of the previous code can GC, so take relocation of + string contents into account. */ + strp = SDATA (str) + idx; + + continue; } } else if ((strp[0] == '`' || strp[0] == '\'') - && quoting_style == CURVE_QUOTING_STYLE - && (multibyte || pure_ascii)) + && quoting_style == CURVE_QUOTING_STYLE) { start = (unsigned char const *) (strp[0] == '`' ? uLSQM : uRSQM); + length = 1; length_byte = sizeof uLSQM - 1; - if (multibyte || pure_ascii) - length = 1; - else - length = length_byte; - idx = strp - SDATA (string) + 1; + idx = strp - SDATA (str) + 1; goto subst_quote; } else if (strp[0] == '`' && quoting_style == STRAIGHT_QUOTING_STYLE) @@ -991,31 +969,14 @@ Otherwise, return a new string. */) strp++; nchars++; changed = true; + continue; } - else if (! multibyte) - *bufp++ = *strp++, nchars++; - else - { - int len; - int ch = STRING_CHAR_AND_LENGTH (strp, len); - if ((ch == LEFT_SINGLE_QUOTATION_MARK - || ch == RIGHT_SINGLE_QUOTATION_MARK) - && quoting_style != CURVE_QUOTING_STYLE) - { - *bufp++ = ((ch == LEFT_SINGLE_QUOTATION_MARK - && quoting_style == GRAVE_QUOTING_STYLE) - ? '`' : '\''); - strp += len; - changed = true; - } - else - { - do - *bufp++ = *strp++; - while (--len != 0); - } - nchars++; - } + + /* Copy one char. */ + do + *bufp++ = *strp++; + while (! CHAR_HEAD_P (*strp)); + nchars++; } if (changed) /* don't bother if nothing substituted */ @@ -1037,8 +998,7 @@ Otherwise, return a new string. */) } else tem = string; - xfree (buf); - return tem; + return unbind_to (count, tem); } void @@ -1058,12 +1018,17 @@ syms_of_doc (void) DEFVAR_LISP ("text-quoting-style", Vtext_quoting_style, doc: /* Style to use for single quotes in help and messages. -Its value should be a symbol. -`curve' means quote with curved single quotes \\=‘like this\\=’. +Its value should be a symbol. It works by substituting certain single +quotes for grave accent and apostrophe. This is done in help output +and in functions like `message' and `format-message'. It is not done +in `format'. + +`curve' means quote with curved single quotes ‘like this’. `straight' means quote with straight apostrophes \\='like this\\='. -`grave' means quote with grave accent and apostrophe \\=`like this\\='. -The default value nil acts like `curve' if curved single quotes are -displayable, and like `grave' otherwise. */); +`grave' means quote with grave accent and apostrophe \\=`like this\\='; +i.e., do not alter quote marks. The default value nil acts like +`curve' if curved single quotes are displayable, and like `grave' +otherwise. */); Vtext_quoting_style = Qnil; DEFVAR_BOOL ("internal--text-quoting-flag", text_quoting_flag, diff --git a/src/doprnt.c b/src/doprnt.c index 9d8b783565f..73380050059 100644 --- a/src/doprnt.c +++ b/src/doprnt.c @@ -103,6 +103,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include <float.h> #include <unistd.h> #include <limits.h> @@ -133,8 +134,11 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, const char *fmt = format; /* Pointer into format string. */ char *bufptr = buffer; /* Pointer into output buffer. */ + /* Enough to handle floating point formats with large numbers. */ + enum { SIZE_BOUND_EXTRA = DBL_MAX_10_EXP + 50 }; + /* Use this for sprintf unless we need something really big. */ - char tembuf[DBL_MAX_10_EXP + 100]; + char tembuf[SIZE_BOUND_EXTRA + 50]; /* Size of sprintf_buffer. */ ptrdiff_t size_allocated = sizeof (tembuf); @@ -196,21 +200,19 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, This might be a field width or a precision; e.g. %1.1000f and %1000.1f both might need 1000+ bytes. Parse the width or precision, checking for overflow. */ - ptrdiff_t n = *fmt - '0'; + int n = *fmt - '0'; + bool overflow = false; while (fmt + 1 < format_end && '0' <= fmt[1] && fmt[1] <= '9') { - /* Avoid ptrdiff_t, size_t, and int overflow, as - many sprintfs mishandle widths greater than INT_MAX. - This test is simple but slightly conservative: e.g., - (INT_MAX - INT_MAX % 10) is reported as an overflow - even when it's not. */ - if (n >= min (INT_MAX, min (PTRDIFF_MAX, SIZE_MAX)) / 10) - error ("Format width or precision too large"); - n = n * 10 + fmt[1] - '0'; + overflow |= INT_MULTIPLY_WRAPV (n, 10, &n); + overflow |= INT_ADD_WRAPV (n, fmt[1] - '0', &n); *string++ = *++fmt; } + if (overflow + || min (PTRDIFF_MAX, SIZE_MAX) - SIZE_BOUND_EXTRA < n) + error ("Format width or precision too large"); if (size_bound < n) size_bound = n; } @@ -244,9 +246,7 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, /* Make the size bound large enough to handle floating point formats with large numbers. */ - if (size_bound > min (PTRDIFF_MAX, SIZE_MAX) - DBL_MAX_10_EXP - 50) - error ("Format width or precision too large"); - size_bound += DBL_MAX_10_EXP + 50; + size_bound += SIZE_BOUND_EXTRA; /* Make sure we have that much. */ if (size_bound > size_allocated) diff --git a/src/dynlib.c b/src/dynlib.c index 64f688ca800..ada58373801 100644 --- a/src/dynlib.c +++ b/src/dynlib.c @@ -52,6 +52,7 @@ typedef BOOL (WINAPI *GetModuleHandleExA_Proc) (DWORD,LPCSTR,HMODULE*); /* This needs to be called at startup to countermand any non-zero values recorded by temacs. */ +void dynlib_reset_last_error (void); void dynlib_reset_last_error (void) { diff --git a/src/editfns.c b/src/editfns.c index 5cc4a67ab19..ccc78e12758 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -49,6 +49,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <limits.h> #include <intprops.h> +#include <stdlib.h> #include <strftime.h> #include <verify.h> @@ -86,10 +87,6 @@ static timezone_t local_tz; static timezone_t wall_clock_tz; static timezone_t const utc_tz = 0; -/* A valid but unlikely setting for the TZ environment variable. - It is OK (though a bit slower) if the user chooses this value. */ -static char dump_tz_string[] = "TZ=UtC0"; - /* The cached value of Vsystem_name. This is used only to compare it to Vsystem_name, so it need not be visible to the GC. */ static Lisp_Object cached_system_name; @@ -146,8 +143,9 @@ xtzfree (timezone_t tz) static timezone_t tzlookup (Lisp_Object zone, bool settz) { - static char const tzbuf_format[] = "XXX%s%"pI"d:%02d:%02d"; - char tzbuf[sizeof tzbuf_format + INT_STRLEN_BOUND (EMACS_INT)]; + static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d"; + char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1; + char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)]; char const *zone_string; timezone_t new_tz; @@ -160,16 +158,50 @@ tzlookup (Lisp_Object zone, bool settz) } else { + bool plain_integer = INTEGERP (zone); + if (EQ (zone, Qwall)) zone_string = 0; else if (STRINGP (zone)) - zone_string = SSDATA (zone); - else if (INTEGERP (zone)) + zone_string = SSDATA (ENCODE_SYSTEM (zone)); + else if (plain_integer || (CONSP (zone) && INTEGERP (XCAR (zone)) + && CONSP (XCDR (zone)))) { + Lisp_Object abbr; + if (!plain_integer) + { + abbr = XCAR (XCDR (zone)); + zone = XCAR (zone); + } + EMACS_INT abszone = eabs (XINT (zone)), hour = abszone / (60 * 60); - int min = (abszone / 60) % 60, sec = abszone % 60; - sprintf (tzbuf, tzbuf_format, &"-"[XINT (zone) < 0], hour, min, sec); - zone_string = tzbuf; + int hour_remainder = abszone % (60 * 60); + int min = hour_remainder / 60, sec = hour_remainder % 60; + + if (plain_integer) + { + int prec = 2; + EMACS_INT numzone = hour; + if (hour_remainder != 0) + { + prec += 2, numzone = 100 * numzone + min; + if (sec != 0) + prec += 2, numzone = 100 * numzone + sec; + } + sprintf (tzbuf, tzbuf_format, prec, numzone, + &"-"[XINT (zone) < 0], hour, min, sec); + zone_string = tzbuf; + } + else + { + AUTO_STRING (leading, "<"); + AUTO_STRING_WITH_LEN (trailing, tzbuf, + sprintf (tzbuf, trailing_tzbuf_format, + &"-"[XINT (zone) < 0], + hour, min, sec)); + zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr), + trailing)); + } } else xsignal2 (Qerror, build_string ("Invalid time zone specification"), @@ -181,6 +213,7 @@ tzlookup (Lisp_Object zone, bool settz) { block_input (); emacs_setenv_TZ (zone_string); + tzset (); timezone_t old_tz = local_tz; local_tz = new_tz; tzfree (old_tz); @@ -193,6 +226,12 @@ tzlookup (Lisp_Object zone, bool settz) void init_editfns (bool dumping) { +#if !defined CANNOT_DUMP && defined HAVE_TZSET + /* A valid but unlikely setting for the TZ environment variable. + It is OK (though a bit slower) if the user chooses this value. */ + static char dump_tz_string[] = "TZ=UtC0"; +#endif + const char *user_name; register char *p; struct passwd *pw; /* password entry for the current user */ @@ -1487,17 +1526,8 @@ static EMACS_INT hi_time (time_t t) { time_t hi = t >> LO_TIME_BITS; - - /* Check for overflow, helping the compiler for common cases where - no runtime check is needed, and taking care not to convert - negative numbers to unsigned before comparing them. */ - if (! ((! TYPE_SIGNED (time_t) - || MOST_NEGATIVE_FIXNUM <= TIME_T_MIN >> LO_TIME_BITS - || MOST_NEGATIVE_FIXNUM <= hi) - && (TIME_T_MAX >> LO_TIME_BITS <= MOST_POSITIVE_FIXNUM - || hi <= MOST_POSITIVE_FIXNUM))) + if (FIXNUM_OVERFLOW_P (hi)) time_overflow (); - return hi; } @@ -1559,7 +1589,7 @@ time_arith (Lisp_Object a, Lisp_Object b, struct lisp_time ta = lisp_time_struct (a, &alen); struct lisp_time tb = lisp_time_struct (b, &blen); struct lisp_time t = op (ta, tb); - if (! (MOST_NEGATIVE_FIXNUM <= t.hi && t.hi <= MOST_POSITIVE_FIXNUM)) + if (FIXNUM_OVERFLOW_P (t.hi)) time_overflow (); Lisp_Object val = Qnil; @@ -1824,7 +1854,7 @@ decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec, if (result) { - if (! (MOST_NEGATIVE_FIXNUM <= hi && hi <= MOST_POSITIVE_FIXNUM)) + if (FIXNUM_OVERFLOW_P (hi)) return -1; result->hi = hi; result->lo = lo; @@ -1982,12 +2012,15 @@ emacs_nmemftime (char *s, size_t maxsize, const char *format, DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0, doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted or nil. TIME is specified as (HIGH LOW USEC PSEC), as returned by -`current-time' or `file-attributes'. -It can also be a single integer number of seconds since the epoch. -The obsolete form (HIGH . LOW) is also still accepted. -The optional ZONE is omitted or nil for Emacs local time, -t for Universal Time, `wall' for system wall clock time, -or a string as in the TZ environment variable. +`current-time' or `file-attributes'. It can also be a single integer +number of seconds since the epoch. The obsolete form (HIGH . LOW) is +also still accepted. + +The optional ZONE is omitted or nil for Emacs local time, t for +Universal Time, `wall' for system wall clock time, or a string as in +the TZ environment variable. It can also be a list (as from +`current-time-zone') or an integer (as from `decode-time') applied +without consideration for daylight saving time. The value is a copy of FORMAT-STRING, but with certain constructs replaced by text that describes the specified date and time in TIME: @@ -2007,6 +2040,7 @@ by text that describes the specified date and time in TIME: %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H only blank-padded, %l is like %I blank-padded. %p is the locale's equivalent of either AM or PM. +%q is the calendar quarter (1–4). %M is the minute. %S is the second. %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc. @@ -2058,7 +2092,6 @@ format_time_string (char const *format, ptrdiff_t formatlen, char *buf = buffer; ptrdiff_t size = sizeof buffer; size_t len; - Lisp_Object bufstring; int ns = t.tv_nsec; USE_SAFE_ALLOCA; @@ -2094,21 +2127,25 @@ format_time_string (char const *format, ptrdiff_t formatlen, } xtzfree (tz); - bufstring = make_unibyte_string (buf, len); + AUTO_STRING_WITH_LEN (bufstring, buf, len); + Lisp_Object result = code_convert_string_norecord (bufstring, + Vlocale_coding_system, 0); SAFE_FREE (); - return code_convert_string_norecord (bufstring, Vlocale_coding_system, 0); + return result; } DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0, doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF). -The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED), +The optional TIME should be a list of (HIGH LOW . IGNORED), as from `current-time' and `file-attributes', or nil to use the -current time. -It can also be a single integer number of seconds since the epoch. -The obsolete form (HIGH . LOW) is also still accepted. +current time. It can also be a single integer number of seconds since +the epoch. The obsolete form (HIGH . LOW) is also still accepted. + The optional ZONE is omitted or nil for Emacs local time, t for Universal Time, `wall' for system wall clock time, or a string as in -the TZ environment variable. +the TZ environment variable. It can also be a list (as from +`current-time-zone') or an integer (as from `decode-time') applied +without consideration for daylight saving time. The list has the following nine members: SEC is an integer between 0 and 60; SEC is 60 for a leap second, which only some operating systems @@ -2155,22 +2192,22 @@ usage: (decode-time &optional TIME ZONE) */) } /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that - the result is representable as an int. Assume OFFSET is small and - nonnegative. */ + the result is representable as an int. */ static int check_tm_member (Lisp_Object obj, int offset) { - EMACS_INT n; CHECK_NUMBER (obj); - n = XINT (obj); - if (! (INT_MIN + offset <= n && n - offset <= INT_MAX)) + EMACS_INT n = XINT (obj); + int result; + if (INT_SUBTRACT_WRAPV (n, offset, &result)) time_overflow (); - return n - offset; + return result; } DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0, doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time. This is the reverse operation of `decode-time', which see. + The optional ZONE is omitted or nil for Emacs local time, t for Universal Time, `wall' for system wall clock time, or a string as in the TZ environment variable. It can also be a list (as from @@ -2205,8 +2242,6 @@ usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */) tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE); tm.tm_isdst = -1; - if (CONSP (zone)) - zone = XCAR (zone); timezone_t tz = tzlookup (zone, false); value = emacs_mktime_z (tz, &tm); xtzfree (tz); @@ -2230,14 +2265,15 @@ which provide a much more powerful and general facility. If SPECIFIED-TIME is given, it is a time to format instead of the current time. The argument should have the form (HIGH LOW . IGNORED). Thus, you can use times obtained from `current-time' and from -`file-attributes'. SPECIFIED-TIME can also be a single integer -number of seconds since the epoch. -SPECIFIED-TIME can also have the form (HIGH . LOW), but this is -considered obsolete. +`file-attributes'. SPECIFIED-TIME can also be a single integer number +of seconds since the epoch. The obsolete form (HIGH . LOW) is also +still accepted. The optional ZONE is omitted or nil for Emacs local time, t for Universal Time, `wall' for system wall clock time, or a string as in -the TZ environment variable. */) +the TZ environment variable. It can also be a list (as from +`current-time-zone') or an integer (as from `decode-time') applied +without consideration for daylight saving time. */) (Lisp_Object specified_time, Lisp_Object zone) { time_t value = lisp_seconds_argument (specified_time); @@ -2312,10 +2348,14 @@ If SPECIFIED-TIME is given, the time zone offset is determined from it instead of using the current time. The argument should have the form \(HIGH LOW . IGNORED). Thus, you can use times obtained from `current-time' and from `file-attributes'. SPECIFIED-TIME can also be -a single integer number of seconds since the epoch. SPECIFIED-TIME can -also have the form (HIGH . LOW), but this is considered obsolete. -Optional second arg ZONE is omitted or nil for the local time zone, or -a string as in the TZ environment variable. +a single integer number of seconds since the epoch. The obsolete form +(HIGH . LOW) is also still accepted. + +The optional ZONE is omitted or nil for Emacs local time, t for +Universal Time, `wall' for system wall clock time, or a string as in +the TZ environment variable. It can also be a list (as from +`current-time-zone') or an integer (as from `decode-time') applied +without consideration for daylight saving time. Some operating systems cannot provide all this information to Emacs; in this case, `current-time-zone' returns a list containing nil for @@ -2342,15 +2382,18 @@ the data it can't find. */) zone_offset = make_number (offset); if (SCHARS (zone_name) == 0) { - /* No local time zone name is available; use "+-NNNN" instead. */ - long int m = offset / 60; - long int am = offset < 0 ? - m : m; - long int hour = am / 60; - int min = am % 60; - char buf[sizeof "+00" + INT_STRLEN_BOUND (long int)]; - zone_name = make_formatted_string (buf, "%c%02ld%02d", + /* No local time zone name is available; use numeric zone instead. */ + long int hour = offset / 3600; + int min_sec = offset % 3600; + int amin_sec = min_sec < 0 ? - min_sec : min_sec; + int min = amin_sec / 60; + int sec = amin_sec % 60; + int min_prec = min_sec ? 2 : 0; + int sec_prec = sec ? 2 : 0; + char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)]; + zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d", (offset < 0 ? '-' : '+'), - hour, min); + hour, min_prec, min, sec_prec, sec); } } @@ -2359,11 +2402,11 @@ the data it can't find. */) DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0, doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule. - If TZ is nil or `wall', use system wall clock time; this differs from the usual Emacs convention where nil means current local time. If TZ -is t, use Universal Time. If TZ is an integer, treat it as in -`encode-time'. +is t, use Universal Time. If TZ is a list (as from +`current-time-zone') or an integer (as from `decode-time'), use the +specified time zone without consideration for daylight saving time. Instead of calling this function, you typically want something else. To temporarily use a different time zone rule for just one invocation @@ -2436,23 +2479,24 @@ emacs_setenv_TZ (const char *tzstring) tzval[tzeqlen] = 0; } - if (new_tzvalbuf -#ifdef WINDOWSNT - /* MS-Windows implementation of 'putenv' copies the argument - string into a block it allocates, so modifying tzval string - does not change the environment. OTOH, the other threads run - by Emacs on MS-Windows never call 'xputenv' or 'putenv' or - 'unsetenv', so the original cause for the dicey in-place - modification technique doesn't exist there in the first - place. */ - || 1 + +#ifndef WINDOWSNT + /* Modifying *TZVAL merely requires calling tzset (which is the + caller's responsibility). However, modifying TZVAL requires + calling putenv; although this is not thread-safe, in practice this + runs only on startup when there is only one thread. */ + bool need_putenv = new_tzvalbuf; +#else + /* MS-Windows 'putenv' copies the argument string into a block it + allocates, so modifying *TZVAL will not change the environment. + However, the other threads run by Emacs on MS-Windows never call + 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the + dicey in-place modification technique doesn't exist there in the + first place. */ + bool need_putenv = true; #endif - ) - { - /* Although this is not thread-safe, in practice this runs only - on startup when there is only one thread. */ - xputenv (tzval); - } + if (need_putenv) + xputenv (tzval); return 0; } @@ -3344,7 +3388,7 @@ It returns the number of characters changed. */) ptrdiff_t size; /* Size of translate table. */ ptrdiff_t pos, pos_byte, end_pos; bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); - bool string_multibyte IF_LINT (= 0); + bool string_multibyte UNINIT; validate_region (&start, &end); if (CHAR_TABLE_P (table)) @@ -3866,6 +3910,9 @@ precision specifier says how many decimal places to show; if zero, the decimal point itself is omitted. For %s and %S, the precision specifier truncates the string to the given width. +Text properties, if any, are copied from the format-string to the +produced text. + usage: (format STRING &rest OBJECTS) */) (ptrdiff_t nargs, Lisp_Object *args) { @@ -3877,10 +3924,9 @@ DEFUN ("format-message", Fformat_message, Sformat_message, 1, MANY, 0, The first argument is a format control string. The other arguments are substituted into it to make the result, a string. -This acts like `format', except it also replaces each left single -quotation mark (\\=‘) and grave accent (\\=`) by a left quote, and each -right single quotation mark (\\=’) and apostrophe (\\=') by a right quote. -The left and right quote replacement characters are specified by +This acts like `format', except it also replaces each grave accent (\\=`) +by a left quote, and each apostrophe (\\=') by a right quote. The left +and right quote replacement characters are specified by `text-quoting-style'. usage: (format-message STRING &rest OBJECTS) */) @@ -3900,7 +3946,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) ptrdiff_t bufsize = sizeof initial_buffer; ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1; char *p; - ptrdiff_t buf_save_value_index IF_LINT (= 0); + ptrdiff_t buf_save_value_index UNINIT; char *format, *end; ptrdiff_t nchars; /* When we make a multibyte string, we must pay attention to the @@ -4159,6 +4205,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) p += padding; nchars += padding; } + info[n].start = nchars; if (p > buf && multibyte @@ -4171,9 +4218,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) nbytes, STRING_MULTIBYTE (args[n]), multibyte); - info[n].start = nchars; nchars += nchars_string; - info[n].end = nchars; if (minus_flag) { @@ -4181,6 +4226,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) p += padding; nchars += padding; } + info[n].end = nchars; /* If this argument has text properties, record where in the result string it appears. */ @@ -4398,6 +4444,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) exponent_bytes = src + sprintf_bytes - e; } + info[n].start = nchars; if (! minus_flag) { memset (p, ' ', padding); @@ -4420,9 +4467,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) memcpy (p, src, exponent_bytes); p += exponent_bytes; - info[n].start = nchars; nchars += leading_zeros + sprintf_bytes + trailing_zeros; - info[n].end = nchars; if (minus_flag) { @@ -4430,6 +4475,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) p += padding; nchars += padding; } + info[n].end = nchars; continue; } @@ -4437,14 +4483,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } else { - /* Named constants for the UTF-8 encodings of U+2018 LEFT SINGLE - QUOTATION MARK and U+2019 RIGHT SINGLE QUOTATION MARK. */ - enum - { - uLSQM0 = 0xE2, uLSQM1 = 0x80, uLSQM2 = 0x98, - /* uRSQM0 = 0xE2, uRSQM1 = 0x80, */ uRSQM2 = 0x99 - }; - unsigned char str[MAX_MULTIBYTE_LENGTH]; if ((format_char == '`' || format_char == '\'') @@ -4460,18 +4498,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } else if (format_char == '`' && quoting_style == STRAIGHT_QUOTING_STYLE) convsrc = "'"; - else if (format_char == uLSQM0 && CURVE_QUOTING_STYLE < quoting_style - && multibyte_format - && (unsigned char) format[0] == uLSQM1 - && ((unsigned char) format[1] == uLSQM2 - || (unsigned char) format[1] == uRSQM2)) - { - convsrc = (((unsigned char) format[1] == uLSQM2 - && quoting_style == GRAVE_QUOTING_STYLE) - ? "`" : "'"); - format += 2; - memset (&discarded[format0 + 1 - format_start], 2, 2); - } else { /* Copy a single character from format to buf. */ @@ -4629,7 +4655,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) len = make_number (SCHARS (args[i])); Lisp_Object new_len = make_number (info[i].end - info[i].start); props = text_property_list (args[i], make_number (0), len, Qnil); - props = extend_property_ranges (props, new_len); + props = extend_property_ranges (props, len, new_len); /* If successive arguments have properties, be sure that the value of `composition' property be the copy. */ if (1 < i && info[i - 1].end) @@ -5056,6 +5082,14 @@ Transposing beyond buffer boundaries is an error. */) start2_byte, start2_byte + len2_byte); fix_start_end_in_overlays (start1, end2); } + else + { + /* The character positions of the markers remain intact, but we + still need to update their byte positions, because the + transposed regions might include multibyte sequences which + make some original byte positions of the markers invalid. */ + adjust_markers_bytepos (start1, start1_byte, end2, end2_byte, 0); + } signal_after_change (start1, end2 - start1, end2 - start1); return Qnil; diff --git a/src/emacs-module.c b/src/emacs-module.c index a28fe57b12d..280c0550c9b 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -21,16 +21,17 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "emacs-module.h" -#include <stdbool.h> #include <stddef.h> #include <stdint.h> #include <stdio.h> -#include <string.h> #include "lisp.h" #include "dynlib.h" #include "coding.h" -#include "verify.h" +#include "syssignal.h" + +#include <intprops.h> +#include <verify.h> /* Feature tests. */ @@ -41,15 +42,9 @@ enum { module_has_cleanup = true }; enum { module_has_cleanup = false }; #endif -/* Handle to the main thread. Used to verify that modules call us in - the right thread. */ -#ifdef HAVE_PTHREAD -# include <pthread.h> -static pthread_t main_thread; -#elif defined WINDOWSNT +#ifdef WINDOWSNT #include <windows.h> #include "w32term.h" -static DWORD main_thread; #endif /* True if Lisp_Object and emacs_value have the same representation. @@ -64,6 +59,13 @@ enum && INTPTR_MAX == EMACS_INT_MAX) }; +/* Function prototype for the module init function. */ +typedef int (*emacs_init_function) (struct emacs_runtime *); + +/* Function prototype for the module Lisp functions. */ +typedef emacs_value (*emacs_subr) (emacs_env *, ptrdiff_t, + emacs_value [], void *); + /* Function prototype for module user-pointer finalizers. These should not throw C++ exceptions, so emacs-module.h declares the corresponding interfaces with EMACS_NOEXCEPT. There is only C code @@ -107,14 +109,12 @@ static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); static void check_main_thread (void); static void finalize_environment (struct emacs_env_private *); static void initialize_environment (emacs_env *, struct emacs_env_private *priv); -static void module_args_out_of_range (emacs_env *, Lisp_Object, Lisp_Object); static void module_handle_signal (emacs_env *, Lisp_Object); static void module_handle_throw (emacs_env *, Lisp_Object); static void module_non_local_exit_signal_1 (emacs_env *, Lisp_Object, Lisp_Object); static void module_non_local_exit_throw_1 (emacs_env *, Lisp_Object, Lisp_Object); static void module_out_of_memory (emacs_env *); static void module_reset_handlerlist (const int *); -static void module_wrong_type (emacs_env *, Lisp_Object, Lisp_Object); /* We used to return NULL when emacs_value was a different type from Lisp_Object, but nowadays we just use Qnil instead. Although they @@ -243,6 +243,12 @@ struct module_fun_env return error_retval; \ MODULE_HANDLE_NONLOCAL_EXIT (error_retval) +static void +CHECK_USER_PTR (Lisp_Object obj) +{ + CHECK_TYPE (USER_PTRP (obj), Quser_ptrp, obj); +} + /* Catch signals and throws only if the code can actually signal or throw. If checking is enabled, abort if the current thread is not the Emacs main thread. */ @@ -270,11 +276,8 @@ module_make_global_ref (emacs_env *env, emacs_value ref) { Lisp_Object value = HASH_VALUE (h, i); EMACS_INT refcount = XFASTINT (value) + 1; - if (refcount > MOST_POSITIVE_FIXNUM) - { - module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); - return module_nil; - } + if (MOST_POSITIVE_FIXNUM < refcount) + xsignal0 (Qoverflow_error); value = make_natnum (refcount); set_hash_value_slot (h, i, value); } @@ -387,17 +390,19 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, envptr->data = data; Lisp_Object envobj = make_save_ptr (envptr); - Lisp_Object doc - = (documentation - ? code_convert_string_norecord (build_unibyte_string (documentation), - Qutf_8, false) - : Qnil); + Lisp_Object doc = Qnil; + if (documentation) + { + AUTO_STRING (unibyte_doc, documentation); + doc = code_convert_string_norecord (unibyte_doc, Qutf_8, false); + } + /* FIXME: Use a bytecompiled object, or even better a subr. */ Lisp_Object ret = list4 (Qlambda, list2 (Qand_rest, Qargs), doc, list4 (Qapply, - list2 (Qfunction, Qinternal_module_call), + list2 (Qfunction, Qinternal__module_call), envobj, Qargs)); @@ -414,11 +419,14 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, first arg, because that's what Ffuncall takes. */ Lisp_Object *newargs; USE_SAFE_ALLOCA; - SAFE_ALLOCA_LISP (newargs, nargs + 1); + ptrdiff_t nargs1; + if (INT_ADD_WRAPV (nargs, 1, &nargs1)) + xsignal0 (Qoverflow_error); + SAFE_ALLOCA_LISP (newargs, nargs1); newargs[0] = value_to_lisp (fun); for (ptrdiff_t i = 0; i < nargs; i++) newargs[1 + i] = value_to_lisp (args[i]); - emacs_value result = lisp_to_value (Ffuncall (nargs + 1, newargs)); + emacs_value result = lisp_to_value (Ffuncall (nargs1, newargs)); SAFE_FREE (); return result; } @@ -460,11 +468,7 @@ module_extract_integer (emacs_env *env, emacs_value n) { MODULE_FUNCTION_BEGIN (0); Lisp_Object l = value_to_lisp (n); - if (! INTEGERP (l)) - { - module_wrong_type (env, Qintegerp, l); - return 0; - } + CHECK_NUMBER (l); return XINT (l); } @@ -472,11 +476,8 @@ static emacs_value module_make_integer (emacs_env *env, intmax_t n) { MODULE_FUNCTION_BEGIN (module_nil); - if (! (MOST_NEGATIVE_FIXNUM <= n && n <= MOST_POSITIVE_FIXNUM)) - { - module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); - return module_nil; - } + if (FIXNUM_OVERFLOW_P (n)) + xsignal0 (Qoverflow_error); return lisp_to_value (make_number (n)); } @@ -485,11 +486,7 @@ module_extract_float (emacs_env *env, emacs_value f) { MODULE_FUNCTION_BEGIN (0); Lisp_Object lisp = value_to_lisp (f); - if (! FLOATP (lisp)) - { - module_wrong_type (env, Qfloatp, lisp); - return 0; - } + CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp); return XFLOAT_DATA (lisp); } @@ -506,19 +503,10 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, { MODULE_FUNCTION_BEGIN (false); Lisp_Object lisp_str = value_to_lisp (value); - if (! STRINGP (lisp_str)) - { - module_wrong_type (env, Qstringp, lisp_str); - return false; - } + CHECK_STRING (lisp_str); Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str); ptrdiff_t raw_size = SBYTES (lisp_str_utf8); - if (raw_size == PTRDIFF_MAX) - { - module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); - return false; - } ptrdiff_t required_buf_size = raw_size + 1; eassert (length != NULL); @@ -534,8 +522,7 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, if (*length < required_buf_size) { *length = required_buf_size; - module_non_local_exit_signal_1 (env, Qargs_out_of_range, Qnil); - return false; + xsignal0 (Qargs_out_of_range); } *length = required_buf_size; @@ -548,12 +535,7 @@ static emacs_value module_make_string (emacs_env *env, const char *str, ptrdiff_t length) { MODULE_FUNCTION_BEGIN (module_nil); - if (length > STRING_BYTES_BOUND) - { - module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); - return module_nil; - } - Lisp_Object lstr = make_unibyte_string (str, length); + AUTO_STRING_WITH_LEN (lstr, str, length); return lisp_to_value (code_convert_string_norecord (lstr, Qutf_8, false)); } @@ -569,11 +551,7 @@ module_get_user_ptr (emacs_env *env, emacs_value uptr) { MODULE_FUNCTION_BEGIN (NULL); Lisp_Object lisp = value_to_lisp (uptr); - if (! USER_PTRP (lisp)) - { - module_wrong_type (env, Quser_ptr, lisp); - return NULL; - } + CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->p; } @@ -582,12 +560,8 @@ module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); - check_main_thread (); - if (module_non_local_exit_check (env) != emacs_funcall_exit_return) - return; Lisp_Object lisp = value_to_lisp (uptr); - if (! USER_PTRP (lisp)) - module_wrong_type (env, Quser_ptr, lisp); + CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->p = ptr; } @@ -596,11 +570,7 @@ module_get_user_finalizer (emacs_env *env, emacs_value uptr) { MODULE_FUNCTION_BEGIN (NULL); Lisp_Object lisp = value_to_lisp (uptr); - if (! USER_PTRP (lisp)) - { - module_wrong_type (env, Quser_ptr, lisp); - return NULL; - } + CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->finalizer; } @@ -611,30 +581,26 @@ module_set_user_finalizer (emacs_env *env, emacs_value uptr, /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); Lisp_Object lisp = value_to_lisp (uptr); - if (! USER_PTRP (lisp)) - module_wrong_type (env, Quser_ptr, lisp); + CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->finalizer = fin; } static void +check_vec_index (Lisp_Object lvec, ptrdiff_t i) +{ + CHECK_VECTOR (lvec); + if (! (0 <= i && i < ASIZE (lvec))) + args_out_of_range_3 (make_fixnum_or_float (i), + make_number (0), make_number (ASIZE (lvec) - 1)); +} + +static void module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); Lisp_Object lvec = value_to_lisp (vec); - if (! VECTORP (lvec)) - { - module_wrong_type (env, Qvectorp, lvec); - return; - } - if (! (0 <= i && i < ASIZE (lvec))) - { - if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) - module_args_out_of_range (env, lvec, make_number (i)); - else - module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); - return; - } + check_vec_index (lvec, i); ASET (lvec, i, value_to_lisp (val)); } @@ -643,19 +609,7 @@ module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) { MODULE_FUNCTION_BEGIN (module_nil); Lisp_Object lvec = value_to_lisp (vec); - if (! VECTORP (lvec)) - { - module_wrong_type (env, Qvectorp, lvec); - return module_nil; - } - if (! (0 <= i && i < ASIZE (lvec))) - { - if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) - module_args_out_of_range (env, lvec, make_number (i)); - else - module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); - return module_nil; - } + check_vec_index (lvec, i); return lisp_to_value (AREF (lvec, i)); } @@ -665,11 +619,7 @@ module_vec_size (emacs_env *env, emacs_value vec) /* FIXME: Return a sentinel value (e.g., -1) on error. */ MODULE_FUNCTION_BEGIN (0); Lisp_Object lvec = value_to_lisp (vec); - if (! VECTORP (lvec)) - { - module_wrong_type (env, Qvectorp, lvec); - return 0; - } + CHECK_VECTOR (lvec); return ASIZE (lvec); } @@ -711,7 +661,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, if (r != 0) { - if (! (MOST_NEGATIVE_FIXNUM <= r && r <= MOST_POSITIVE_FIXNUM)) + if (FIXNUM_OVERFLOW_P (r)) xsignal0 (Qoverflow_error); xsignal2 (Qmodule_load_failed, file, make_number (r)); } @@ -796,9 +746,9 @@ static void check_main_thread (void) { #ifdef HAVE_PTHREAD - eassert (pthread_equal (pthread_self (), main_thread)); + eassert (pthread_equal (pthread_self (), main_thread_id)); #elif defined WINDOWSNT - eassert (GetCurrentThreadId () == main_thread); + eassert (GetCurrentThreadId () == dwMainThreadId); #endif } @@ -828,14 +778,6 @@ module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag, } } -/* Module version of `wrong_type_argument'. */ -static void -module_wrong_type (emacs_env *env, Lisp_Object predicate, Lisp_Object value) -{ - module_non_local_exit_signal_1 (env, Qwrong_type_argument, - list2 (predicate, value)); -} - /* Signal an out-of-memory condition to the caller. */ static void module_out_of_memory (emacs_env *env) @@ -846,13 +788,6 @@ module_out_of_memory (emacs_env *env) XCDR (Vmemory_signal_data)); } -/* Signal arguments are out of range. */ -static void -module_args_out_of_range (emacs_env *env, Lisp_Object a1, Lisp_Object a2) -{ - module_non_local_exit_signal_1 (env, Qargs_out_of_range, list2 (a1, a2)); -} - /* Value conversion. */ @@ -1055,10 +990,12 @@ module_format_fun_env (const struct module_fun_env *env) ? exprintf (&buf, &bufsize, buffer, -1, "#<module function %s from %s>", sym, path) : sprintf (buffer, noaddr_format, env->subr)); - Lisp_Object unibyte_result = make_unibyte_string (buffer, size); + AUTO_STRING_WITH_LEN (unibyte_result, buffer, size); + Lisp_Object result = code_convert_string_norecord (unibyte_result, + Qutf_8, false); if (buf != buffer) xfree (buf); - return code_convert_string_norecord (unibyte_result, Qutf_8, false); + return result; } @@ -1117,23 +1054,6 @@ syms_of_module (void) defsubr (&Smodule_load); - DEFSYM (Qinternal_module_call, "internal--module-call"); + DEFSYM (Qinternal__module_call, "internal--module-call"); defsubr (&Sinternal_module_call); } - -/* Unlike syms_of_module, this initializer is called even from an - initialized (dumped) Emacs. */ - -void -module_init (void) -{ - /* It is not guaranteed that dynamic initializers run in the main thread, - therefore detect the main thread here. */ -#ifdef HAVE_PTHREAD - main_thread = pthread_self (); -#elif defined WINDOWSNT - /* The 'main' function already recorded the main thread's thread ID, - so we need just to use it . */ - main_thread = dwMainThreadId; -#endif -} diff --git a/src/emacs-module.h b/src/emacs-module.h index b4ae5ea7433..ae7311b05a7 100644 --- a/src/emacs-module.h +++ b/src/emacs-module.h @@ -41,7 +41,7 @@ typedef struct emacs_env_25 emacs_env; BEWARE: Do not assume NULL is a valid value! */ typedef struct emacs_value_tag *emacs_value; -enum emacs_arity { emacs_variadic_function = -2 }; +enum { emacs_variadic_function = -2 }; /* Struct passed to a module init function (emacs_module_init). */ struct emacs_runtime @@ -57,13 +57,6 @@ struct emacs_runtime }; -/* Function prototype for the module init function. */ -typedef int (*emacs_init_function) (struct emacs_runtime *ert); - -/* Function prototype for the module Lisp functions. */ -typedef emacs_value (*emacs_subr) (emacs_env *env, ptrdiff_t nargs, - emacs_value args[], void *data); - /* Possible Emacs function call outcomes. */ enum emacs_funcall_exit { diff --git a/src/emacs.c b/src/emacs.c index 16cf6cc0e4d..d461fe241c0 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -24,8 +24,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <errno.h> #include <fcntl.h> #include <stdio.h> +#include <stdlib.h> -#include <sys/types.h> #include <sys/file.h> #include <unistd.h> @@ -57,11 +57,15 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "dosfns.h" #endif +#ifdef HAVE_LIBSYSTEMD +# include <systemd/sd-daemon.h> +# include <sys/socket.h> +#endif + #ifdef HAVE_WINDOW_SYSTEM #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ -#include "coding.h" #include "intervals.h" #include "character.h" #include "buffer.h" @@ -80,11 +84,13 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "composite.h" #include "dispextern.h" #include "regex.h" +#include "sheap.h" #include "syntax.h" #include "sysselect.h" #include "systime.h" #include "puresize.h" +#include "getpagesize.h" #include "gnutls.h" #if (defined PROFILING \ @@ -106,10 +112,6 @@ extern void moncontrol (int mode); #include <sys/resource.h> #endif -#ifdef HAVE_PERSONALITY_LINUX32 -#include <sys/personality.h> -#endif - static const char emacs_version[] = PACKAGE_VERSION; static const char emacs_copyright[] = COPYRIGHT; static const char emacs_bugreport[] = PACKAGE_BUGREPORT; @@ -127,15 +129,20 @@ Lisp_Object Vlibrary_cache; on subsequent starts. */ bool initialized; +bool generating_ldefs_boot; + +#ifndef CANNOT_DUMP /* Set to true if this instance of Emacs might dump. */ +# ifndef DOUG_LEA_MALLOC +static +# endif bool might_dump; +#endif #ifdef DARWIN_OS extern void unexec_init_emacs_zone (void); #endif -extern void malloc_enable_thread (void); - /* If true, Emacs should not attempt to use a window-specific code, but instead should use the virtual terminal under which it was started. */ bool inhibit_window_system; @@ -149,17 +156,13 @@ bool running_asynch_code; bool display_arg; #endif -/* An address near the bottom of the stack. - Tells GC how to save a copy of the stack. */ -char *stack_bottom; - -#ifdef GNU_LINUX +#if defined GNU_LINUX && !defined CANNOT_DUMP /* The gap between BSS end and heap start as far as we can tell. */ static uprintmax_t heap_bss_diff; #endif -/* To run as a daemon under Cocoa or Windows, we must do a fork+exec, - not a simple fork. +/* To run as a background daemon under Cocoa or Windows, + we must do a fork+exec, not a simple fork. On Cocoa, CoreFoundation lib fails in forked process: http://developer.apple.com/ReleaseNotes/ @@ -180,13 +183,19 @@ bool noninteractive; /* True means remove site-lisp directories from load-path. */ bool no_site_lisp; +/* True means put details like time stamps into builds. */ +bool build_details; + /* Name for the server started by the daemon.*/ static char *daemon_name; +/* 0 not a daemon, 1 new-style (foreground), 2 old-style (background). */ +int daemon_type; + #ifndef WINDOWSNT -/* Pipe used to send exit notification to the daemon parent at - startup. */ -int daemon_pipe[2]; +/* Pipe used to send exit notification to the background daemon parent at + startup. On Windows, we use a kernel event instead. */ +static int daemon_pipe[2]; #else HANDLE w32_daemon_event; #endif @@ -216,11 +225,13 @@ Initialization options:\n\ "\ --batch do not do interactive display; implies -q\n\ --chdir DIR change to directory DIR\n\ ---daemon start a server in the background\n\ +--daemon, --old-daemon[=NAME] start a (named) server in the background\n\ +--new-daemon[=NAME] start a (named) server in the foreground\n\ --debug-init enable Emacs Lisp debugger for init file\n\ --display, -d DISPLAY use X server DISPLAY\n\ ", "\ +--no-build-details do not add build details such as time stamps\n\ --no-desktop do not load a saved desktop\n\ --no-init-file, -q load neither ~/.emacs nor default.el\n\ --no-loadup, -nl do not load loadup.el into bare Emacs\n\ @@ -353,17 +364,20 @@ terminate_due_to_signal (int sig, int backtrace_limit) { signal (sig, SIG_DFL); - /* If fatal error occurs in code below, avoid infinite recursion. */ - if (! fatal_error_in_progress) + if (attempt_orderly_shutdown_on_fatal_signal) { - fatal_error_in_progress = 1; + /* If fatal error occurs in code below, avoid infinite recursion. */ + if (! fatal_error_in_progress) + { + fatal_error_in_progress = 1; - totally_unblock_input (); - if (sig == SIGTERM || sig == SIGHUP || sig == SIGINT) - Fkill_emacs (make_number (sig)); + totally_unblock_input (); + if (sig == SIGTERM || sig == SIGHUP || sig == SIGINT) + Fkill_emacs (make_number (sig)); - shut_down_emacs (sig, Qnil); - emacs_backtrace (backtrace_limit); + shut_down_emacs (sig, Qnil); + emacs_backtrace (backtrace_limit); + } } /* Signal the same code; this time it will really be fatal. @@ -653,15 +667,11 @@ close_output_streams (void) int main (int argc, char **argv) { - Lisp_Object dummy; char stack_bottom_variable; bool do_initial_setlocale; bool dumping; int skip_args = 0; -#ifdef HAVE_SETRLIMIT - struct rlimit rlim; -#endif - bool no_loadup = 0; + bool no_loadup = false; char *junk = 0; char *dname_arg = 0; #ifdef DAEMON_MUST_EXEC @@ -672,38 +682,46 @@ main (int argc, char **argv) /* If we use --chdir, this records the original directory. */ char *original_pwd = 0; - stack_base = &dummy; + /* Record (approximately) where the stack begins. */ + stack_bottom = &stack_bottom_variable; + + dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0 + || strcmp (argv[argc - 1], "bootstrap") == 0 ); + + generating_ldefs_boot = getenv ("GENERATE_LDEFS_BOOT"); + -#if defined HAVE_PERSONALITY_LINUX32 && defined __PPC64__ - /* This code partly duplicates the HAVE_PERSONALITY_LINUX32 code - below. This duplication is planned to be fixed in a later - Emacs release. */ -# define ADD_NO_RANDOMIZE 0x0040000 - int pers = personality (0xffffffff); - if (! (pers & ADD_NO_RANDOMIZE) - && 0 <= personality (pers | ADD_NO_RANDOMIZE)) + /* True if address randomization interferes with memory allocation. */ +# ifdef __PPC64__ + bool disable_aslr = true; +# else + bool disable_aslr = dumping; +# endif + + if (disable_aslr && disable_address_randomization ()) { + /* Set this so the personality will be reverted before execs + after this one. */ + xputenv ("EMACS_HEAP_EXEC=true"); + /* Address randomization was enabled, but is now disabled. Re-execute Emacs to get a clean slate. */ execvp (argv[0], argv); - /* If the exec fails, warn the user and then try without a - clean slate. */ + /* If the exec fails, warn and then try anyway. */ perror (argv[0]); } -# undef ADD_NO_RANDOMIZE -#endif #ifndef CANNOT_DUMP might_dump = !initialized; -#endif -#ifdef GNU_LINUX +# ifdef GNU_LINUX if (!initialized) { char *heap_start = my_heap_start (); heap_bss_diff = heap_start - max (my_endbss, my_endbss_static); } +# endif #endif #if defined WINDOWSNT || defined HAVE_NTGUI @@ -720,8 +738,6 @@ main (int argc, char **argv) non-ASCII file names during startup. */ w32_init_file_name_codepage (); #endif - /* This has to be done before module_init is called below, so that - the latter could use the thread ID of the main thread. */ w32_init_main_thread (); #endif @@ -736,12 +752,9 @@ main (int argc, char **argv) unexec_init_emacs_zone (); #endif + init_standard_fds (); atexit (close_output_streams); -#ifdef HAVE_MODULES - module_init (); -#endif - sort_args (argc, argv); argc = 0; while (argv[argc]) argc++; @@ -795,7 +808,7 @@ main (int argc, char **argv) filename_from_ansi (ch_to_dir, newdir); ch_to_dir = newdir; #endif - original_pwd = get_current_dir_name (); + original_pwd = emacs_get_current_dir_name (); if (chdir (ch_to_dir) != 0) { fprintf (stderr, "%s: Can't chdir to %s: %s\n", @@ -804,28 +817,6 @@ main (int argc, char **argv) } } - dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0 - || strcmp (argv[argc - 1], "bootstrap") == 0); - -#if defined HAVE_PERSONALITY_LINUX32 && !defined __PPC64__ - if (dumping && ! getenv ("EMACS_HEAP_EXEC")) - { - /* Set this so we only do this once. */ - xputenv ("EMACS_HEAP_EXEC=true"); - - /* A flag to turn off address randomization which is introduced - in linux kernel shipped with fedora core 4 */ -#define ADD_NO_RANDOMIZE 0x0040000 - personality (PER_LINUX32 | ADD_NO_RANDOMIZE); -#undef ADD_NO_RANDOMIZE - - execvp (argv[0], argv); - - /* If the exec fails, try to dump anyway. */ - emacs_perror (argv[0]); - } -#endif - #if defined (HAVE_SETRLIMIT) && defined (RLIMIT_STACK) && !defined (CYGWIN) /* Extend the stack space available. Don't do that if dumping, since some systems (e.g. DJGPP) might define a smaller stack @@ -833,44 +824,57 @@ main (int argc, char **argv) is built with an 8MB stack. Moreover, the setrlimit call can cause problems on Cygwin (https://www.cygwin.com/ml/cygwin/2015-07/msg00096.html). */ - if (1 -#ifndef CANNOT_DUMP - && (!noninteractive || initialized) -#endif - && !getrlimit (RLIMIT_STACK, &rlim)) + struct rlimit rlim; + if (getrlimit (RLIMIT_STACK, &rlim) == 0 + && 0 <= rlim.rlim_cur && rlim.rlim_cur <= LONG_MAX) { - long newlim; - /* Approximate the amount regex.c needs per unit of re_max_failures. */ + rlim_t lim = rlim.rlim_cur; + + /* Approximate the amount regex.c needs per unit of + re_max_failures, then add 33% to cover the size of the + smaller stacks that regex.c successively allocates and + discards on its way to the maximum. */ int ratio = 20 * sizeof (char *); - /* Then add 33% to cover the size of the smaller stacks that regex.c - successively allocates and discards, on its way to the maximum. */ ratio += ratio / 3; - /* Add in some extra to cover - what we're likely to use for other reasons. */ - newlim = re_max_failures * ratio + 200000; -#ifdef __NetBSD__ - /* NetBSD (at least NetBSD 1.2G and former) has a bug in its - stack allocation routine for new process that the allocation - fails if stack limit is not on page boundary. So, round up the - new limit to page boundary. */ - newlim = (newlim + getpagesize () - 1) / getpagesize () * getpagesize (); -#endif - if (newlim > rlim.rlim_max) + + /* Extra space to cover what we're likely to use for other reasons. */ + int extra = 200000; + + bool try_to_grow_stack = true; +#ifndef CANNOT_DUMP + try_to_grow_stack = !noninteractive || initialized; +#endif + + if (try_to_grow_stack) { - newlim = rlim.rlim_max; - /* Don't let regex.c overflow the stack we have. */ - re_max_failures = (newlim - 200000) / ratio; + rlim_t newlim = re_max_failures * ratio + extra; + + /* Round the new limit to a page boundary; this is needed + for Darwin kernel 15.4.0 (see Bug#23622) and perhaps + other systems. Do not shrink the stack and do not exceed + rlim_max. Don't worry about exact values of + RLIM_INFINITY etc. since in practice when they are + nonnegative they are so large that the code does the + right thing anyway. */ + long pagesize = getpagesize (); + newlim += pagesize - 1; + if (0 <= rlim.rlim_max && rlim.rlim_max < newlim) + newlim = rlim.rlim_max; + newlim -= newlim % pagesize; + + if (pagesize <= newlim - lim) + { + rlim.rlim_cur = newlim; + if (setrlimit (RLIMIT_STACK, &rlim) == 0) + lim = newlim; + } } - if (rlim.rlim_cur < newlim) - rlim.rlim_cur = newlim; - setrlimit (RLIMIT_STACK, &rlim); + /* Don't let regex.c overflow the stack. */ + re_max_failures = lim < extra ? 0 : min (lim - extra, SIZE_MAX) / ratio; } #endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */ - /* Record (approximately) where the stack begins. */ - stack_bottom = &stack_bottom_variable; - clearerr (stdin); emacs_backtrace (-1); @@ -914,24 +918,25 @@ main (int argc, char **argv) char *term; if (argmatch (argv, argc, "-t", "--terminal", 4, &term, &skip_args)) { - int result; - emacs_close (0); - emacs_close (1); - result = emacs_open (term, O_RDWR, 0); - if (result < 0 || fcntl (0, F_DUPFD_CLOEXEC, 1) < 0) + emacs_close (STDIN_FILENO); + emacs_close (STDOUT_FILENO); + int result = emacs_open (term, O_RDWR, 0); + if (result != STDIN_FILENO + || (fcntl (STDIN_FILENO, F_DUPFD_CLOEXEC, STDOUT_FILENO) + != STDOUT_FILENO)) { char *errstring = strerror (errno); fprintf (stderr, "%s: %s: %s\n", argv[0], term, errstring); - exit (1); + exit (EXIT_FAILURE); } - if (! isatty (0)) + if (! isatty (STDIN_FILENO)) { fprintf (stderr, "%s: %s: not a tty\n", argv[0], term); - exit (1); + exit (EXIT_FAILURE); } fprintf (stderr, "Using %s\n", term); #ifdef HAVE_WINDOW_SYSTEM - inhibit_window_system = 1; /* -t => -nw */ + inhibit_window_system = true; /* -t => -nw */ #endif } else @@ -972,6 +977,8 @@ main (int argc, char **argv) exit (0); } + daemon_type = 0; + #ifndef WINDOWSNT /* Make sure IS_DAEMON starts up as false. */ daemon_pipe[1] = 0; @@ -979,132 +986,170 @@ main (int argc, char **argv) w32_daemon_event = NULL; #endif - if (argmatch (argv, argc, "-daemon", "--daemon", 5, NULL, &skip_args) - || argmatch (argv, argc, "-daemon", "--daemon", 5, &dname_arg, &skip_args)) + + int sockfd = -1; + + if (argmatch (argv, argc, "-new-daemon", "--new-daemon", 10, NULL, &skip_args) + || argmatch (argv, argc, "-new-daemon", "--new-daemon", 10, &dname_arg, &skip_args)) + { + daemon_type = 1; /* foreground */ + } + else if (argmatch (argv, argc, "-daemon", "--daemon", 5, NULL, &skip_args) + || argmatch (argv, argc, "-daemon", "--daemon", 5, &dname_arg, &skip_args) + || argmatch (argv, argc, "-old-daemon", "--old-daemon", 10, NULL, &skip_args) + || argmatch (argv, argc, "-old-daemon", "--old-daemon", 10, &dname_arg, &skip_args)) + { + daemon_type = 2; /* background */ + } + + + if (daemon_type > 0) { #ifndef DOS_NT - pid_t f; - - /* Start as a daemon: fork a new child process which will run the - rest of the initialization code, then exit. - - Detaching a daemon requires the following steps: - - fork - - setsid - - exit the parent - - close the tty file-descriptors - - We only want to do the last 2 steps once the daemon is ready to - serve requests, i.e. after loading .emacs (initialization). - OTOH initialization may start subprocesses (e.g. ispell) and these - should be run from the proper process (the one that will end up - running as daemon) and with the proper "session id" in order for - them to keep working after detaching, so fork and setsid need to be - performed before initialization. - - We want to avoid exiting before the server socket is ready, so - use a pipe for synchronization. The parent waits for the child - to close its end of the pipe (using `daemon-initialized') - before exiting. */ - if (emacs_pipe (daemon_pipe) != 0) - { - fprintf (stderr, "Cannot pipe!\n"); - exit (1); - } + if (daemon_type == 2) + { + /* Start as a background daemon: fork a new child process which + will run the rest of the initialization code, then exit. + + Detaching a daemon requires the following steps: + - fork + - setsid + - exit the parent + - close the tty file-descriptors + + We only want to do the last 2 steps once the daemon is ready to + serve requests, i.e. after loading .emacs (initialization). + OTOH initialization may start subprocesses (e.g. ispell) and these + should be run from the proper process (the one that will end up + running as daemon) and with the proper "session id" in order for + them to keep working after detaching, so fork and setsid need to be + performed before initialization. + + We want to avoid exiting before the server socket is ready, so + use a pipe for synchronization. The parent waits for the child + to close its end of the pipe (using `daemon-initialized') + before exiting. */ + if (emacs_pipe (daemon_pipe) != 0) + { + fprintf (stderr, "Cannot pipe!\n"); + exit (1); + } + } /* daemon_type == 2 */ + +#ifdef HAVE_LIBSYSTEMD + /* Read the number of sockets passed through by systemd. */ + int systemd_socket = sd_listen_fds (1); + + if (systemd_socket > 1) + fprintf (stderr, + ("\n" + "Warning: systemd passed more than one socket to Emacs.\n" + "Try 'Accept=false' in the Emacs socket unit file.\n")); + else if (systemd_socket == 1 + && (0 < sd_is_socket (SD_LISTEN_FDS_START, + AF_UNSPEC, SOCK_STREAM, 1))) + sockfd = SD_LISTEN_FDS_START; +#endif /* HAVE_LIBSYSTEMD */ -#ifndef DAEMON_MUST_EXEC #ifdef USE_GTK fprintf (stderr, "\nWarning: due to a long standing Gtk+ bug\nhttp://bugzilla.gnome.org/show_bug.cgi?id=85715\n\ Emacs might crash when run in daemon mode and the X11 connection is unexpectedly lost.\n\ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem.\n"); #endif /* USE_GTK */ - f = fork (); -#else /* DAEMON_MUST_EXEC */ - if (!dname_arg || !strchr (dname_arg, '\n')) - f = fork (); /* in orig */ - else - f = 0; /* in exec'd */ -#endif /* !DAEMON_MUST_EXEC */ - if (f > 0) - { - int retval; - char buf[1]; - /* Close unused writing end of the pipe. */ - emacs_close (daemon_pipe[1]); - - /* Just wait for the child to close its end of the pipe. */ - do - { - retval = read (daemon_pipe[0], &buf, 1); - } - while (retval == -1 && errno == EINTR); - - if (retval < 0) - { - fprintf (stderr, "Error reading status from child\n"); - exit (1); - } - else if (retval == 0) - { - fprintf (stderr, "Error: server did not start correctly\n"); - exit (1); - } + if (daemon_type == 2) + { + pid_t f; +#ifndef DAEMON_MUST_EXEC - emacs_close (daemon_pipe[0]); - exit (0); - } - if (f < 0) - { - emacs_perror ("fork"); - exit (EXIT_CANCELED); - } + f = fork (); +#else /* DAEMON_MUST_EXEC */ + if (!dname_arg || !strchr (dname_arg, '\n')) + f = fork (); /* in orig */ + else + f = 0; /* in exec'd */ +#endif /* !DAEMON_MUST_EXEC */ + if (f > 0) + { + int retval; + char buf[1]; + + /* Close unused writing end of the pipe. */ + emacs_close (daemon_pipe[1]); + + /* Just wait for the child to close its end of the pipe. */ + do + { + retval = read (daemon_pipe[0], &buf, 1); + } + while (retval == -1 && errno == EINTR); + + if (retval < 0) + { + fprintf (stderr, "Error reading status from child\n"); + exit (1); + } + else if (retval == 0) + { + fprintf (stderr, "Error: server did not start correctly\n"); + exit (1); + } + + emacs_close (daemon_pipe[0]); + exit (0); + } + if (f < 0) + { + emacs_perror ("fork"); + exit (EXIT_CANCELED); + } #ifdef DAEMON_MUST_EXEC - { - /* In orig process, forked as child, OR in exec'd. */ - if (!dname_arg || !strchr (dname_arg, '\n')) - { /* In orig, child: now exec w/special daemon name. */ - char fdStr[80]; - int fdStrlen = - snprintf (fdStr, sizeof fdStr, - "--daemon=\n%d,%d\n%s", daemon_pipe[0], - daemon_pipe[1], dname_arg ? dname_arg : ""); - - if (! (0 <= fdStrlen && fdStrlen < sizeof fdStr)) - { - fprintf (stderr, "daemon: child name too long\n"); - exit (EXIT_CANNOT_INVOKE); + { + /* In orig process, forked as child, OR in exec'd. */ + if (!dname_arg || !strchr (dname_arg, '\n')) + { /* In orig, child: now exec w/special daemon name. */ + char fdStr[80]; + int fdStrlen = + snprintf (fdStr, sizeof fdStr, + "--old-daemon=\n%d,%d\n%s", daemon_pipe[0], + daemon_pipe[1], dname_arg ? dname_arg : ""); + + if (! (0 <= fdStrlen && fdStrlen < sizeof fdStr)) + { + fprintf (stderr, "daemon: child name too long\n"); + exit (EXIT_CANNOT_INVOKE); + } + + argv[skip_args] = fdStr; + + fcntl (daemon_pipe[0], F_SETFD, 0); + fcntl (daemon_pipe[1], F_SETFD, 0); + execvp (argv[0], argv); + emacs_perror (argv[0]); + exit (errno == ENOENT ? EXIT_ENOENT : EXIT_CANNOT_INVOKE); } - argv[skip_args] = fdStr; - - fcntl (daemon_pipe[0], F_SETFD, 0); - fcntl (daemon_pipe[1], F_SETFD, 0); - execvp (argv[0], argv); - emacs_perror (argv[0]); - exit (errno == ENOENT ? EXIT_ENOENT : EXIT_CANNOT_INVOKE); - } - - /* In exec'd: parse special dname into pipe and name info. */ - if (!dname_arg || !strchr (dname_arg, '\n') - || strlen (dname_arg) < 1 || strlen (dname_arg) > 70) + /* In exec'd: parse special dname into pipe and name info. */ + if (!dname_arg || !strchr (dname_arg, '\n') + || strlen (dname_arg) < 1 || strlen (dname_arg) > 70) { fprintf (stderr, "emacs daemon: daemon name absent or too long\n"); exit (EXIT_CANNOT_INVOKE); } - dname_arg2[0] = '\0'; - sscanf (dname_arg, "\n%d,%d\n%s", &(daemon_pipe[0]), &(daemon_pipe[1]), - dname_arg2); - dname_arg = *dname_arg2 ? dname_arg2 : NULL; - fcntl (daemon_pipe[1], F_SETFD, FD_CLOEXEC); - } + dname_arg2[0] = '\0'; + sscanf (dname_arg, "\n%d,%d\n%s", &(daemon_pipe[0]), &(daemon_pipe[1]), + dname_arg2); + dname_arg = *dname_arg2 ? dname_arg2 : NULL; + fcntl (daemon_pipe[1], F_SETFD, FD_CLOEXEC); + } #endif /* DAEMON_MUST_EXEC */ - /* Close unused reading end of the pipe. */ - emacs_close (daemon_pipe[0]); + /* Close unused reading end of the pipe. */ + emacs_close (daemon_pipe[0]); - setsid (); + setsid (); + } /* daemon_type == 2 */ #elif defined(WINDOWSNT) /* Indicate that we want daemon mode. */ w32_daemon_event = CreateEvent (NULL, TRUE, FALSE, W32_DAEMON_EVENT); @@ -1115,7 +1160,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem exit (1); } #else /* MSDOS */ - fprintf (stderr, "This platform does not support the -daemon flag.\n"); + fprintf (stderr, "This platform does not support daemon mode.\n"); exit (1); #endif /* MSDOS */ if (dname_arg) @@ -1143,6 +1188,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (!initialized) { init_alloc_once (); + init_threads_once (); init_obarray (); init_eval_once (); init_charset_once (); @@ -1189,6 +1235,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem } init_alloc (); + init_threads (); if (do_initial_setlocale) { @@ -1208,6 +1255,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem no_site_lisp = argmatch (argv, argc, "-nsl", "--no-site-lisp", 11, NULL, &skip_args); + build_details = ! argmatch (argv, argc, "-no-build-details", + "--no-build-details", 7, NULL, &skip_args); + #ifdef HAVE_NS ns_pool = ns_alloc_autorelease_pool (); #ifdef NS_IMPL_GNUSTEP @@ -1221,7 +1271,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* Started from GUI? */ /* FIXME: Do the right thing if getenv returns NULL, or if chdir fails. */ - if (! inhibit_window_system && ! isatty (0) && ! ch_to_dir) + if (! inhibit_window_system && ! isatty (STDIN_FILENO) && ! ch_to_dir) chdir (getenv ("HOME")); if (skip_args < argc) { @@ -1324,16 +1374,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem globals_of_gfilenotify (); #endif -#ifdef WINDOWSNT - globals_of_w32 (); -#ifdef HAVE_W32NOTIFY - globals_of_w32notify (); -#endif - /* Initialize environment from registry settings. */ - init_environment (argv); - init_ntproc (dumping); /* must precede init_editfns. */ -#endif - #ifdef HAVE_NS /* Initialize the locale from user defaults. */ ns_init_locale (); @@ -1350,6 +1390,20 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (! dumping) set_initial_environment (); +#ifdef WINDOWSNT + globals_of_w32 (); +#ifdef HAVE_W32NOTIFY + globals_of_w32notify (); +#endif + /* Initialize environment from registry settings. Make sure to do + this only after calling set_initial_environment so that + Vinitial_environment and Vprocess_environment will contain only + variables from the parent process without modifications from + Emacs. */ + init_environment (argv); + init_ntproc (dumping); /* must precede init_editfns. */ +#endif + /* AIX crashes are reported in system versions 3.2.3 and 3.2.4 if this is not done. Do it after set_global_environment so that we don't pollute Vglobal_environment. */ @@ -1524,6 +1578,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif /* HAVE_W32NOTIFY */ #endif /* WINDOWSNT */ + syms_of_threads (); syms_of_profiler (); keys_of_casefiddle (); @@ -1565,7 +1620,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* This can create a thread that may call getenv, so it must follow all calls to putenv and setenv. Also, this sets up add_keyboard_wait_descriptor, which init_display uses. */ - init_process_emacs (); + init_process_emacs (sockfd); init_keyboard (); /* This too must precede init_sys_modes. */ if (!noninteractive) @@ -1654,9 +1709,12 @@ static const struct standard_args standard_args[] = { "-batch", "--batch", 100, 0 }, { "-script", "--script", 100, 1 }, { "-daemon", "--daemon", 99, 0 }, + { "-old-daemon", "--old-daemon", 99, 0 }, + { "-new-daemon", "--new-daemon", 99, 0 }, { "-help", "--help", 90, 0 }, { "-nl", "--no-loadup", 70, 0 }, { "-nsl", "--no-site-lisp", 65, 0 }, + { "-no-build-details", "--no-build-details", 63, 0 }, /* -d must come last before the options handled in startup.el. */ { "-d", "--display", 60, 1 }, { "-display", 0, 60, 1 }, @@ -1839,9 +1897,13 @@ sort_args (int argc, char **argv) fatal ("Option '%s' requires an argument\n", argv[from]); from += options[from]; } - /* FIXME When match < 0, shouldn't there be some error, - or at least indication to the user that there was a - problem? */ + else if (match == -2) + { + /* This is an internal error. + Eg if one long option is a prefix of another. */ + fprintf (stderr, "Option '%s' matched multiple standard arguments\n", argv[from]); + } + /* Should we not also warn if there was no match? */ } done: ; } @@ -2059,7 +2121,7 @@ You must run Emacs in batch mode in order to dump it. */) if (!might_dump) error ("Emacs can be dumped only once"); -#ifdef GNU_LINUX +#if defined GNU_LINUX && !defined CANNOT_DUMP /* Warn if the gap between BSS end and heap start is larger than this. */ # define MAX_HEAP_BSS_DIFF (1024*1024) @@ -2099,6 +2161,17 @@ You must run Emacs in batch mode in order to dump it. */) tem = Vpurify_flag; Vpurify_flag = Qnil; +#ifdef HYBRID_MALLOC + { + static char const fmt[] = "%d of %d static heap bytes used"; + char buf[sizeof fmt + 2 * (INT_STRLEN_BOUND (int) - 2)]; + int max_usage = max_bss_sbrk_ptr - bss_sbrk_buffer; + sprintf (buf, fmt, max_usage, STATIC_HEAP_SIZE); + /* Don't log messages, because at this point buffers cannot be created. */ + message1_nolog (buf); + } +#endif + fflush (stdout); /* Tell malloc where start of impure now is. */ /* Also arrange for warnings when nearly out of space. */ @@ -2186,6 +2259,15 @@ synchronize_system_messages_locale (void) #endif } #endif /* HAVE_SETLOCALE */ + +/* Return a diagnostic string for ERROR_NUMBER, in the wording + and encoding appropriate for the current locale. */ +char * +emacs_strerror (int error_number) +{ + synchronize_system_messages_locale (); + return strerror (error_number); +} Lisp_Object @@ -2352,27 +2434,33 @@ from the parent process and its tty file descriptors. */) if (NILP (Vafter_init_time)) error ("This function can only be called after loading the init files"); #ifndef WINDOWSNT - int nfd; - - /* Get rid of stdin, stdout and stderr. */ - nfd = emacs_open ("/dev/null", O_RDWR, 0); - err |= nfd < 0; - err |= dup2 (nfd, 0) < 0; - err |= dup2 (nfd, 1) < 0; - err |= dup2 (nfd, 2) < 0; - err |= emacs_close (nfd) != 0; - - /* Closing the pipe will notify the parent that it can exit. - FIXME: In case some other process inherited the pipe, closing it here - won't notify the parent because it's still open elsewhere, so we - additionally send a byte, just to make sure the parent really exits. - Instead, we should probably close the pipe in start-process and - call-process to make sure the pipe is never inherited by - subprocesses. */ - err |= write (daemon_pipe[1], "\n", 1) < 0; - err |= emacs_close (daemon_pipe[1]) != 0; + + if (daemon_type == 2) + { + int nfd; + + /* Get rid of stdin, stdout and stderr. */ + nfd = emacs_open ("/dev/null", O_RDWR, 0); + err |= nfd < 0; + err |= dup2 (nfd, STDIN_FILENO) < 0; + err |= dup2 (nfd, STDOUT_FILENO) < 0; + err |= dup2 (nfd, STDERR_FILENO) < 0; + err |= emacs_close (nfd) != 0; + + /* Closing the pipe will notify the parent that it can exit. + FIXME: In case some other process inherited the pipe, closing it here + won't notify the parent because it's still open elsewhere, so we + additionally send a byte, just to make sure the parent really exits. + Instead, we should probably close the pipe in start-process and + call-process to make sure the pipe is never inherited by + subprocesses. */ + err |= write (daemon_pipe[1], "\n", 1) < 0; + err |= emacs_close (daemon_pipe[1]) != 0; + } + /* Set it to an invalid value so we know we've already run this function. */ - daemon_pipe[1] = -1; + daemon_type = -1; + #else /* WINDOWSNT */ /* Signal the waiting emacsclient process. */ err |= SetEvent (w32_daemon_event) == 0; @@ -2419,8 +2507,8 @@ Special values: `ms-dos' compiled as an MS-DOS application. `windows-nt' compiled as a native W32 application. `cygwin' compiled using the Cygwin library. -Anything else (in Emacs 24.1, the possibilities are: aix, berkeley-unix, -hpux, irix, usg-unix-v) indicates some sort of Unix system. */); +Anything else (in Emacs 26, the possibilities are: aix, berkeley-unix, +hpux, usg-unix-v) indicates some sort of Unix system. */); Vsystem_type = intern_c_string (SYSTEM_TYPE); /* See configure.ac for the possible SYSTEM_TYPEs. */ diff --git a/src/emacsgtkfixed.c b/src/emacsgtkfixed.c index ca0bbfbb866..c04adf28b36 100644 --- a/src/emacsgtkfixed.c +++ b/src/emacsgtkfixed.c @@ -27,7 +27,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "emacsgtkfixed.h" /* Silence a bogus diagnostic; see GNOME bug 683906. */ -#if 4 < __GNUC__ + (7 <= __GNUC_MINOR__) && ! GLIB_CHECK_VERSION (2, 35, 7) +#if GNUC_PREREQ (4, 7, 0) && ! GLIB_CHECK_VERSION (2, 35, 7) # pragma GCC diagnostic push # pragma GCC diagnostic ignored "-Wunused-local-typedefs" #endif diff --git a/src/eval.c b/src/eval.c index 0380b115195..b1747387471 100644 --- a/src/eval.c +++ b/src/eval.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <limits.h> #include <stdio.h> +#include <stdlib.h> #include "lisp.h" #include "blockinput.h" #include "commands.h" @@ -31,7 +32,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* Chain of condition and catch handlers currently in effect. */ -struct handler *handlerlist; +/* struct handler *handlerlist; */ /* Non-nil means record all fset's and provide's, to be undone if the file being autoloaded is not fully loaded. @@ -45,23 +46,25 @@ Lisp_Object Vautoload_queue; is shutting down. */ Lisp_Object Vrun_hooks; +/* The commented-out variables below are macros defined in thread.h. */ + /* Current number of specbindings allocated in specpdl, not counting the dummy entry specpdl[-1]. */ -ptrdiff_t specpdl_size; +/* ptrdiff_t specpdl_size; */ /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists only so that its address can be taken. */ -union specbinding *specpdl; +/* union specbinding *specpdl; */ /* Pointer to first unused element in specpdl. */ -union specbinding *specpdl_ptr; +/* union specbinding *specpdl_ptr; */ /* Depth in Lisp evaluations and function calls. */ -static EMACS_INT lisp_eval_depth; +/* static EMACS_INT lisp_eval_depth; */ /* The value of num_nonmacro_input_events as of the last time we started to enter the debugger. If we decide to enter the debugger @@ -90,6 +93,7 @@ union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE; static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t); +static Lisp_Object lambda_arity (Lisp_Object); static Lisp_Object specpdl_symbol (union specbinding *pdl) @@ -98,6 +102,13 @@ specpdl_symbol (union specbinding *pdl) return pdl->let.symbol; } +static enum specbind_tag +specpdl_kind (union specbinding *pdl) +{ + eassert (pdl->kind >= SPECPDL_LET); + return pdl->let.kind; +} + static Lisp_Object specpdl_old_value (union specbinding *pdl) { @@ -120,6 +131,13 @@ specpdl_where (union specbinding *pdl) } static Lisp_Object +specpdl_saved_value (union specbinding *pdl) +{ + eassert (pdl->kind >= SPECPDL_LET); + return pdl->let.saved_value; +} + +static Lisp_Object specpdl_arg (union specbinding *pdl) { eassert (pdl->kind == SPECPDL_UNWIND); @@ -216,21 +234,21 @@ init_eval_once (void) Vrun_hooks = Qnil; } -static struct handler handlerlist_sentinel; +/* static struct handler handlerlist_sentinel; */ void init_eval (void) { - byte_stack_list = 0; specpdl_ptr = specpdl; { /* Put a dummy catcher at top-level so that handlerlist is never NULL. This is important since handlerlist->nextfree holds the freelist which would otherwise leak every time we unwind back to top-level. */ - handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel; + handlerlist_sentinel = xzalloc (sizeof (struct handler)); + handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel; struct handler *c = push_handler (Qunbound, CATCHER); - eassert (c == &handlerlist_sentinel); - handlerlist_sentinel.nextfree = NULL; - handlerlist_sentinel.next = NULL; + eassert (c == handlerlist_sentinel); + handlerlist_sentinel->nextfree = NULL; + handlerlist_sentinel->next = NULL; } Vquit_flag = Qnil; debug_on_next_call = 0; @@ -435,11 +453,10 @@ usage: (progn BODY...) */) return val; } -/* Evaluate BODY sequentially, discarding its value. Suitable for - record_unwind_protect. */ +/* Evaluate BODY sequentially, discarding its value. */ void -unwind_body (Lisp_Object body) +prog_ignore (Lisp_Object body) { Fprogn (body); } @@ -451,16 +468,8 @@ whose values are discarded. usage: (prog1 FIRST BODY...) */) (Lisp_Object args) { - Lisp_Object val; - Lisp_Object args_left; - - args_left = args; - val = args; - - val = eval_sub (XCAR (args_left)); - while (CONSP (args_left = XCDR (args_left))) - eval_sub (XCAR (args_left)); - + Lisp_Object val = eval_sub (XCAR (args)); + prog_ignore (XCDR (args)); return val; } @@ -592,12 +601,12 @@ The return value is BASE-VARIABLE. */) CHECK_SYMBOL (new_alias); CHECK_SYMBOL (base_variable); - sym = XSYMBOL (new_alias); - - if (sym->constant) - /* Not sure why, but why not? */ + if (SYMBOL_CONSTANT_P (new_alias)) + /* Making it an alias effectively changes its value. */ error ("Cannot make a constant an alias"); + sym = XSYMBOL (new_alias); + switch (sym->redirect) { case SYMBOL_FORWARDED: @@ -616,8 +625,8 @@ The return value is BASE-VARIABLE. */) so that old-code that affects n_a before the aliasing is setup still works. */ if (NILP (Fboundp (base_variable))) - set_internal (base_variable, find_symbol_value (new_alias), Qnil, 1); - + set_internal (base_variable, find_symbol_value (new_alias), + Qnil, SET_INTERNAL_BIND); { union specbinding *p; @@ -627,11 +636,14 @@ The return value is BASE-VARIABLE. */) error ("Don't know how to make a let-bound variable an alias"); } + if (sym->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (new_alias, base_variable, Qdefvaralias, Qnil); + sym->declared_special = 1; XSYMBOL (base_variable)->declared_special = 1; sym->redirect = SYMBOL_VARALIAS; SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); - sym->constant = SYMBOL_CONSTANT_P (base_variable); + sym->trapped_write = XSYMBOL (base_variable)->trapped_write; LOADHIST_ATTACH (new_alias); /* Even if docstring is nil: remove old docstring. */ Fput (new_alias, Qvariable_documentation, docstring); @@ -968,7 +980,7 @@ usage: (while TEST BODY...) */) while (!NILP (eval_sub (test))) { QUIT; - Fprogn (body); + prog_ignore (body); } return Qnil; @@ -1057,11 +1069,11 @@ usage: (catch TAG BODY...) */) return internal_catch (tag, Fprogn, XCDR (args)); } -/* Assert that E is true, as a comment only. Use this instead of +/* Assert that E is true, but do not evaluate E. Use this instead of eassert (E) when E contains variables that might be clobbered by a longjmp. */ -#define clobbered_eassert(E) ((void) 0) +#define clobbered_eassert(E) verify (sizeof (E) != 0) /* Set up a catch, then call C function FUNC on argument ARG. FUNC should return a Lisp_Object. @@ -1078,8 +1090,8 @@ internal_catch (Lisp_Object tag, if (! sys_setjmp (c->jmp)) { Lisp_Object val = func (arg); - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } else @@ -1135,8 +1147,7 @@ unwind_to_catch (struct handler *catch, Lisp_Object value) eassert (handlerlist == catch); - byte_stack_list = catch->byte_stack; - lisp_eval_depth = catch->lisp_eval_depth; + lisp_eval_depth = catch->f_lisp_eval_depth; sys_longjmp (catch->jmp, 1); } @@ -1172,7 +1183,7 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */) Lisp_Object val; ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (unwind_body, XCDR (args)); + record_unwind_protect (prog_ignore, XCDR (args)); val = eval_sub (XCAR (args)); return unbind_to (count, val); } @@ -1313,8 +1324,8 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, else { Lisp_Object val = bfun (); - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } } @@ -1337,8 +1348,8 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, else { Lisp_Object val = bfun (arg); - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } } @@ -1364,8 +1375,8 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), else { Lisp_Object val = bfun (arg1, arg2); - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } } @@ -1393,8 +1404,8 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), else { Lisp_Object val = bfun (nargs, args); - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } } @@ -1426,16 +1437,16 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype) c->tag_or_ch = tag_ch_val; c->val = Qnil; c->next = handlerlist; - c->lisp_eval_depth = lisp_eval_depth; + c->f_lisp_eval_depth = lisp_eval_depth; c->pdlcount = SPECPDL_INDEX (); c->poll_suppress_count = poll_suppress_count; c->interrupt_input_blocked = interrupt_input_blocked; - c->byte_stack = byte_stack_list; handlerlist = c; return c; } +static Lisp_Object signal_or_quit (Lisp_Object, Lisp_Object, bool); static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object); static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data); @@ -1449,7 +1460,7 @@ process_quit_flag (void) Fkill_emacs (Qnil); if (EQ (Vthrow_on_input, flag)) Fthrow (Vthrow_on_input, Qt); - Fsignal (Qquit, Qnil); + quit (); } DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0, @@ -1465,9 +1476,29 @@ DATA should be a list. Its elements are printed as part of the error message. See Info anchor `(elisp)Definition of signal' for some details on how this error message is constructed. If the signal is handled, DATA is made available to the handler. -See also the function `condition-case'. */) +See also the function `condition-case'. */ + attributes: noreturn) (Lisp_Object error_symbol, Lisp_Object data) { + signal_or_quit (error_symbol, data, false); + eassume (false); +} + +/* Quit, in response to a keyboard quit request. */ +Lisp_Object +quit (void) +{ + return signal_or_quit (Qquit, Qnil, true); +} + +/* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal. + If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be + Qquit and DATA should be Qnil, and this function may return. + Otherwise this function is like Fsignal and does not return. */ + +static Lisp_Object +signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit) +{ /* When memory is full, ERROR-SYMBOL is nil, and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). That is a special case--don't do this in other situations. */ @@ -1479,7 +1510,6 @@ See also the function `condition-case'. */) struct handler *h; immediate_quit = 0; - abort_on_gc = 0; if (gc_in_progress || waiting_for_input) emacs_abort (); @@ -1547,7 +1577,7 @@ See also the function `condition-case'. */) = maybe_call_debugger (conditions, error_symbol, data); /* We can't return values to code which signaled an error, but we can continue code which has signaled a quit. */ - if (debugger_called && EQ (real_error_symbol, Qquit)) + if (keyboard_quit && debugger_called && EQ (real_error_symbol, Qquit)) return Qnil; } @@ -1560,7 +1590,7 @@ See also the function `condition-case'. */) } else { - if (handlerlist != &handlerlist_sentinel) + if (handlerlist != handlerlist_sentinel) /* FIXME: This will come right back here if there's no `top-level' catcher. A better solution would be to abort here, and instead add a catch-all condition handler so we never come here. */ @@ -1574,16 +1604,6 @@ See also the function `condition-case'. */) fatal ("%s", SDATA (string)); } -/* Internal version of Fsignal that never returns. - Used for anything but Qquit (which can return from Fsignal). */ - -void -xsignal (Lisp_Object error_symbol, Lisp_Object data) -{ - Fsignal (error_symbol, data); - emacs_abort (); -} - /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */ void @@ -1757,9 +1777,9 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions) } -/* Dump an error message; called like vprintf. */ -void -verror (const char *m, va_list ap) +/* Format and return a string; called like vprintf. */ +Lisp_Object +vformat_string (const char *m, va_list ap) { char buf[4000]; ptrdiff_t size = sizeof buf; @@ -1773,7 +1793,14 @@ verror (const char *m, va_list ap) if (buffer != buf) xfree (buffer); - xsignal1 (Qerror, string); + return string; +} + +/* Dump an error message; called like vprintf. */ +void +verror (const char *m, va_list ap) +{ + xsignal1 (Qerror, vformat_string (m, ap)); } @@ -1930,6 +1957,28 @@ it defines a macro. */) if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef))) return fundef; + /* In the special case that we are generating ldefs-boot-auto.el, + then be noisy about the autoload. */ + if( generating_ldefs_boot ) + { + fprintf(stderr, "(autoload '"); + Fprin1(funname,Qexternal_debugging_output); + fprintf(stderr, " "); + Fprin1(Fcar (Fcdr (fundef)),Qexternal_debugging_output); + fprintf(stderr, " nil nil "); + + Lisp_Object kind = Fnth (make_number (4), fundef); + if (! (EQ (kind, Qt) || EQ (kind, Qmacro))) + { + fprintf(stderr, "nil"); + } + else + { + fprintf(stderr, "t"); + } + fprintf(stderr, ")\n"); + } + if (EQ (macro_only, Qmacro)) { Lisp_Object kind = Fnth (make_number (4), fundef); @@ -1973,7 +2022,8 @@ it defines a macro. */) Lisp_Object fun = Findirect_function (funname, Qnil); if (!NILP (Fequal (fun, fundef))) - error ("Autoloading failed to define function %s", + error ("Autoloading file %s failed to define function %s", + SDATA (Fcar (Fcar (Vload_history))), SDATA (SYMBOL_NAME (funname))); else return fun; @@ -2619,6 +2669,37 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, return Qnil; } +bool +FUNCTIONP (Lisp_Object object) +{ + if (SYMBOLP (object) && !NILP (Ffboundp (object))) + { + object = Findirect_function (object, Qt); + + if (CONSP (object) && EQ (XCAR (object), Qautoload)) + { + /* Autoloaded symbols are functions, except if they load + macros or keymaps. */ + for (int i = 0; i < 4 && CONSP (object); i++) + object = XCDR (object); + + return ! (CONSP (object) && !NILP (XCAR (object))); + } + } + + if (SUBRP (object)) + return XSUBR (object)->max_args != UNEVALLED; + else if (COMPILEDP (object)) + return true; + else if (CONSP (object)) + { + Lisp_Object car = XCAR (object); + return EQ (car, Qlambda) || EQ (car, Qclosure); + } + else + return false; +} + DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, doc: /* Call first argument as a function, passing remaining arguments to it. Return the value that function returns. @@ -2629,9 +2710,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) Lisp_Object fun, original_fun; Lisp_Object funcar; ptrdiff_t numargs = nargs - 1; - Lisp_Object lisp_numargs; Lisp_Object val; - Lisp_Object *internal_args; ptrdiff_t count; QUIT; @@ -2664,86 +2743,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) fun = indirect_function (fun); if (SUBRP (fun)) - { - if (numargs < XSUBR (fun)->min_args - || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) - { - XSETFASTINT (lisp_numargs, numargs); - xsignal2 (Qwrong_number_of_arguments, original_fun, lisp_numargs); - } - - else if (XSUBR (fun)->max_args == UNEVALLED) - xsignal1 (Qinvalid_function, original_fun); - - else if (XSUBR (fun)->max_args == MANY) - val = (XSUBR (fun)->function.aMANY) (numargs, args + 1); - else - { - Lisp_Object internal_argbuf[8]; - if (XSUBR (fun)->max_args > numargs) - { - eassert (XSUBR (fun)->max_args <= ARRAYELTS (internal_argbuf)); - internal_args = internal_argbuf; - memcpy (internal_args, args + 1, numargs * word_size); - memclear (internal_args + numargs, - (XSUBR (fun)->max_args - numargs) * word_size); - } - else - internal_args = args + 1; - switch (XSUBR (fun)->max_args) - { - case 0: - val = (XSUBR (fun)->function.a0 ()); - break; - case 1: - val = (XSUBR (fun)->function.a1 (internal_args[0])); - break; - case 2: - val = (XSUBR (fun)->function.a2 - (internal_args[0], internal_args[1])); - break; - case 3: - val = (XSUBR (fun)->function.a3 - (internal_args[0], internal_args[1], internal_args[2])); - break; - case 4: - val = (XSUBR (fun)->function.a4 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3])); - break; - case 5: - val = (XSUBR (fun)->function.a5 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4])); - break; - case 6: - val = (XSUBR (fun)->function.a6 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4], internal_args[5])); - break; - case 7: - val = (XSUBR (fun)->function.a7 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4], internal_args[5], - internal_args[6])); - break; - - case 8: - val = (XSUBR (fun)->function.a8 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4], internal_args[5], - internal_args[6], internal_args[7])); - break; - - default: - - /* If a subr takes more than 8 arguments without using MANY - or UNEVALLED, we need to extend this function to support it. - Until this is done, there is no way to call the function. */ - emacs_abort (); - } - } - } + val = funcall_subr (XSUBR (fun), numargs, args + 1); else if (COMPILEDP (fun)) val = funcall_lambda (fun, numargs, args + 1); else @@ -2775,6 +2775,89 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) return val; } + +/* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR + and return the result of evaluation. */ + +Lisp_Object +funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) +{ + if (numargs < subr->min_args + || (subr->max_args >= 0 && subr->max_args < numargs)) + { + Lisp_Object fun; + XSETSUBR (fun, subr); + xsignal2 (Qwrong_number_of_arguments, fun, make_number (numargs)); + } + + else if (subr->max_args == UNEVALLED) + { + Lisp_Object fun; + XSETSUBR (fun, subr); + xsignal1 (Qinvalid_function, fun); + } + + else if (subr->max_args == MANY) + return (subr->function.aMANY) (numargs, args); + else + { + Lisp_Object internal_argbuf[8]; + Lisp_Object *internal_args; + if (subr->max_args > numargs) + { + eassert (subr->max_args <= ARRAYELTS (internal_argbuf)); + internal_args = internal_argbuf; + memcpy (internal_args, args, numargs * word_size); + memclear (internal_args + numargs, + (subr->max_args - numargs) * word_size); + } + else + internal_args = args; + switch (subr->max_args) + { + case 0: + return (subr->function.a0 ()); + case 1: + return (subr->function.a1 (internal_args[0])); + case 2: + return (subr->function.a2 + (internal_args[0], internal_args[1])); + case 3: + return (subr->function.a3 + (internal_args[0], internal_args[1], internal_args[2])); + case 4: + return (subr->function.a4 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3])); + case 5: + return (subr->function.a5 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4])); + case 6: + return (subr->function.a6 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4], internal_args[5])); + case 7: + return (subr->function.a7 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4], internal_args[5], + internal_args[6])); + case 8: + return (subr->function.a8 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4], internal_args[5], + internal_args[6], internal_args[7])); + + default: + + /* If a subr takes more than 8 arguments without using MANY + or UNEVALLED, we need to extend this function to support it. + Until this is done, there is no way to call the function. */ + emacs_abort (); + } + } +} + static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { @@ -2847,14 +2930,14 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); if (INTEGERP (syms_left)) - /* A byte-code object with a non-nil `push args' slot means we + /* A byte-code object with an integer args template means we shouldn't bind any arguments, instead just call the byte-code interpreter directly; it will push arguments as necessary. - Byte-code objects with either a non-existent, or a nil value for - the `push args' slot (the default), have dynamically-bound - arguments, and use the argument-binding code below instead (as do - all interpreted functions, even lexically bound ones). */ + Byte-code objects with a nil args template (the default) + have dynamically-bound arguments, and use the + argument-binding code below instead (as do all interpreted + functions, even lexically bound ones). */ { /* If we have not actually read the bytecode string and constants vector yet, fetch them from the file. */ @@ -2872,6 +2955,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, emacs_abort (); i = optional = rest = 0; + bool previous_optional_or_rest = false; for (; CONSP (syms_left); syms_left = XCDR (syms_left)) { QUIT; @@ -2881,9 +2965,19 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, xsignal1 (Qinvalid_function, fun); if (EQ (next, Qand_rest)) - rest = 1; + { + if (rest || previous_optional_or_rest) + xsignal1 (Qinvalid_function, fun); + rest = 1; + previous_optional_or_rest = true; + } else if (EQ (next, Qand_optional)) - optional = 1; + { + if (optional || rest || previous_optional_or_rest) + xsignal1 (Qinvalid_function, fun); + optional = 1; + previous_optional_or_rest = true; + } else { Lisp_Object arg; @@ -2906,10 +3000,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else /* Dynamically bind NEXT. */ specbind (next, arg); + previous_optional_or_rest = false; } } - if (!NILP (syms_left)) + if (!NILP (syms_left) || previous_optional_or_rest) xsignal1 (Qinvalid_function, fun); else if (i < nargs) xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); @@ -2935,6 +3030,118 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, return unbind_to (count, val); } +DEFUN ("func-arity", Ffunc_arity, Sfunc_arity, 1, 1, 0, + doc: /* Return minimum and maximum number of args allowed for FUNCTION. +FUNCTION must be a function of some kind. +The returned value is a cons cell (MIN . MAX). MIN is the minimum number +of args. MAX is the maximum number, or the symbol `many', for a +function with `&rest' args, or `unevalled' for a special form. */) + (Lisp_Object function) +{ + Lisp_Object original; + Lisp_Object funcar; + Lisp_Object result; + + original = function; + + retry: + + /* Optimize for no indirection. */ + function = original; + if (SYMBOLP (function) && !NILP (function)) + { + function = XSYMBOL (function)->function; + if (SYMBOLP (function)) + function = indirect_function (function); + } + + if (CONSP (function) && EQ (XCAR (function), Qmacro)) + function = XCDR (function); + + if (SUBRP (function)) + result = Fsubr_arity (function); + else if (COMPILEDP (function)) + result = lambda_arity (function); + else + { + if (NILP (function)) + xsignal1 (Qvoid_function, original); + if (!CONSP (function)) + xsignal1 (Qinvalid_function, original); + funcar = XCAR (function); + if (!SYMBOLP (funcar)) + xsignal1 (Qinvalid_function, original); + if (EQ (funcar, Qlambda) + || EQ (funcar, Qclosure)) + result = lambda_arity (function); + else if (EQ (funcar, Qautoload)) + { + Fautoload_do_load (function, original, Qnil); + goto retry; + } + else + xsignal1 (Qinvalid_function, original); + } + return result; +} + +/* FUN must be either a lambda-expression or a compiled-code object. */ +static Lisp_Object +lambda_arity (Lisp_Object fun) +{ + Lisp_Object syms_left; + + if (CONSP (fun)) + { + if (EQ (XCAR (fun), Qclosure)) + { + fun = XCDR (fun); /* Drop `closure'. */ + CHECK_LIST_CONS (fun, fun); + } + syms_left = XCDR (fun); + if (CONSP (syms_left)) + syms_left = XCAR (syms_left); + else + xsignal1 (Qinvalid_function, fun); + } + else if (COMPILEDP (fun)) + { + ptrdiff_t size = ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK; + if (size <= COMPILED_STACK_DEPTH) + xsignal1 (Qinvalid_function, fun); + syms_left = AREF (fun, COMPILED_ARGLIST); + if (INTEGERP (syms_left)) + return get_byte_code_arity (syms_left); + } + else + emacs_abort (); + + EMACS_INT minargs = 0, maxargs = 0; + bool optional = false; + for (; CONSP (syms_left); syms_left = XCDR (syms_left)) + { + Lisp_Object next = XCAR (syms_left); + if (!SYMBOLP (next)) + xsignal1 (Qinvalid_function, fun); + + if (EQ (next, Qand_rest)) + return Fcons (make_number (minargs), Qmany); + else if (EQ (next, Qand_optional)) + optional = true; + else + { + if (!optional) + minargs++; + maxargs++; + } + } + + if (!NILP (syms_left)) + xsignal1 (Qinvalid_function, fun); + + return Fcons (make_number (minargs), make_number (maxargs)); +} + DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, 1, 1, 0, doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */) @@ -2999,6 +3206,36 @@ let_shadows_global_binding_p (Lisp_Object symbol) return 0; } +static void +do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, + Lisp_Object value, enum Set_Internal_Bind bindflag) +{ + switch (sym->redirect) + { + case SYMBOL_PLAINVAL: + if (!sym->trapped_write) + SET_SYMBOL_VAL (sym, value); + else + set_internal (specpdl_symbol (bind), value, Qnil, bindflag); + break; + + case SYMBOL_FORWARDED: + if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) + && specpdl_kind (bind) == SPECPDL_LET_DEFAULT) + { + set_default_internal (specpdl_symbol (bind), value, bindflag); + return; + } + /* FALLTHROUGH */ + case SYMBOL_LOCALIZED: + set_internal (specpdl_symbol (bind), value, Qnil, bindflag); + break; + + default: + emacs_abort (); + } +} + /* `specpdl_ptr' describes which variable is let-bound, so it can be properly undone when we unbind_to. It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT. @@ -3030,15 +3267,11 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->let.kind = SPECPDL_LET; specpdl_ptr->let.symbol = symbol; specpdl_ptr->let.old_value = SYMBOL_VAL (sym); + specpdl_ptr->let.saved_value = Qnil; grow_specpdl (); - if (!sym->constant) - SET_SYMBOL_VAL (sym, value); - else - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND); break; case SYMBOL_LOCALIZED: - if (SYMBOL_BLV (sym)->frame_local) - error ("Frame-local vars cannot be let-bound"); case SYMBOL_FORWARDED: { Lisp_Object ovalue = find_symbol_value (symbol); @@ -3046,6 +3279,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->let.symbol = symbol; specpdl_ptr->let.old_value = ovalue; specpdl_ptr->let.where = Fcurrent_buffer (); + specpdl_ptr->let.saved_value = Qnil; eassert (sym->redirect != SYMBOL_LOCALIZED || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ()))); @@ -3066,7 +3300,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) { specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT; grow_specpdl (); - Fset_default (symbol, value); + do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND); return; } } @@ -3074,7 +3308,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->let.kind = SPECPDL_LET; grow_specpdl (); - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND); break; } default: emacs_abort (); @@ -3118,6 +3352,85 @@ record_unwind_protect_void (void (*function) (void)) grow_specpdl (); } +void +rebind_for_thread_switch (void) +{ + union specbinding *bind; + + for (bind = specpdl; bind != specpdl_ptr; ++bind) + { + if (bind->kind >= SPECPDL_LET) + { + Lisp_Object value = specpdl_saved_value (bind); + Lisp_Object sym = specpdl_symbol (bind); + bind->let.saved_value = Qnil; + do_specbind (XSYMBOL (sym), bind, value, + SET_INTERNAL_THREAD_SWITCH); + } + } +} + +static void +do_one_unbind (union specbinding *this_binding, bool unwinding, + enum Set_Internal_Bind bindflag) +{ + eassert (unwinding || this_binding->kind >= SPECPDL_LET); + switch (this_binding->kind) + { + case SPECPDL_UNWIND: + this_binding->unwind.func (this_binding->unwind.arg); + break; + case SPECPDL_UNWIND_PTR: + this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg); + break; + case SPECPDL_UNWIND_INT: + this_binding->unwind_int.func (this_binding->unwind_int.arg); + break; + case SPECPDL_UNWIND_VOID: + this_binding->unwind_void.func (); + break; + case SPECPDL_BACKTRACE: + break; + case SPECPDL_LET: + { /* If variable has a trivial value (no forwarding), and isn't + trapped, we can just set it. */ + Lisp_Object sym = specpdl_symbol (this_binding); + if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL) + { + if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE) + SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding)); + else + set_internal (sym, specpdl_old_value (this_binding), + Qnil, bindflag); + break; + } + else + { /* FALLTHROUGH!! + NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + } + } + case SPECPDL_LET_DEFAULT: + set_default_internal (specpdl_symbol (this_binding), + specpdl_old_value (this_binding), + bindflag); + break; + case SPECPDL_LET_LOCAL: + { + Lisp_Object symbol = specpdl_symbol (this_binding); + Lisp_Object where = specpdl_where (this_binding); + Lisp_Object old_value = specpdl_old_value (this_binding); + eassert (BUFFERP (where)); + + /* If this was a local binding, reset the value in the appropriate + buffer, but only if that buffer's binding still exists. */ + if (!NILP (Flocal_variable_p (symbol, where))) + set_internal (symbol, old_value, where, bindflag); + } + break; + } +} + static void do_nothing (void) {} @@ -3177,64 +3490,16 @@ unbind_to (ptrdiff_t count, Lisp_Object value) while (specpdl_ptr != specpdl + count) { - /* Decrement specpdl_ptr before we do the work to unbind it, so - that an error in unbinding won't try to unbind the same entry - again. Take care to copy any parts of the binding needed - before invoking any code that can make more bindings. */ - - specpdl_ptr--; + /* Copy the binding, and decrement specpdl_ptr, before we do + the work to unbind it. We decrement first + so that an error in unbinding won't try to unbind + the same entry again, and we copy the binding first + in case more bindings are made during some of the code we run. */ - switch (specpdl_ptr->kind) - { - case SPECPDL_UNWIND: - specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg); - break; - case SPECPDL_UNWIND_PTR: - specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg); - break; - case SPECPDL_UNWIND_INT: - specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg); - break; - case SPECPDL_UNWIND_VOID: - specpdl_ptr->unwind_void.func (); - break; - case SPECPDL_BACKTRACE: - break; - case SPECPDL_LET: - { /* If variable has a trivial value (no forwarding), we can - just set it. No need to check for constant symbols here, - since that was already done by specbind. */ - Lisp_Object sym = specpdl_symbol (specpdl_ptr); - if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL) - { - SET_SYMBOL_VAL (XSYMBOL (sym), - specpdl_old_value (specpdl_ptr)); - break; - } - else - { /* FALLTHROUGH!! - NOTE: we only ever come here if make_local_foo was used for - the first time on this var within this let. */ - } - } - case SPECPDL_LET_DEFAULT: - Fset_default (specpdl_symbol (specpdl_ptr), - specpdl_old_value (specpdl_ptr)); - break; - case SPECPDL_LET_LOCAL: - { - Lisp_Object symbol = specpdl_symbol (specpdl_ptr); - Lisp_Object where = specpdl_where (specpdl_ptr); - Lisp_Object old_value = specpdl_old_value (specpdl_ptr); - eassert (BUFFERP (where)); + union specbinding this_binding; + this_binding = *--specpdl_ptr; - /* If this was a local binding, reset the value in the appropriate - buffer, but only if that buffer's binding still exists. */ - if (!NILP (Flocal_variable_p (symbol, where))) - set_internal (symbol, old_value, where, 1); - } - break; - } + do_one_unbind (&this_binding, true, SET_INTERNAL_UNBIND); } if (NILP (Vquit_flag) && !NILP (quitf)) @@ -3243,6 +3508,22 @@ unbind_to (ptrdiff_t count, Lisp_Object value) return value; } +void +unbind_for_thread_switch (struct thread_state *thr) +{ + union specbinding *bind; + + for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;) + { + if ((--bind)->kind >= SPECPDL_LET) + { + Lisp_Object sym = specpdl_symbol (bind); + bind->let.saved_value = find_symbol_value (sym); + do_one_unbind (bind, false, SET_INTERNAL_THREAD_SWITCH); + } + } +} + DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0, doc: /* Return non-nil if SYMBOL's global binding has been declared special. A special variable is one that will be bound dynamically, even in a @@ -3254,83 +3535,29 @@ context where binding is lexical by default. */) } -DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, - doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. -The debugger is entered when that frame exits, if the flag is non-nil. */) - (Lisp_Object level, Lisp_Object flag) -{ - union specbinding *pdl = backtrace_top (); - register EMACS_INT i; - - CHECK_NUMBER (level); - - for (i = 0; backtrace_p (pdl) && i < XINT (level); i++) - pdl = backtrace_next (pdl); - - if (backtrace_p (pdl)) - set_backtrace_debug_on_exit (pdl, !NILP (flag)); - - return flag; -} - -DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "", - doc: /* Print a trace of Lisp function calls currently active. -Output stream used is value of `standard-output'. */) - (void) +static union specbinding * +get_backtrace_starting_at (Lisp_Object base) { union specbinding *pdl = backtrace_top (); - Lisp_Object tem; - Lisp_Object old_print_level = Vprint_level; - - if (NILP (Vprint_level)) - XSETFASTINT (Vprint_level, 8); - while (backtrace_p (pdl)) - { - write_string (backtrace_debug_on_exit (pdl) ? "* " : " "); - if (backtrace_nargs (pdl) == UNEVALLED) - { - Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)), - Qnil); - write_string ("\n"); - } - else - { - tem = backtrace_function (pdl); - Fprin1 (tem, Qnil); /* This can QUIT. */ - write_string ("("); - { - ptrdiff_t i; - for (i = 0; i < backtrace_nargs (pdl); i++) - { - if (i) write_string (" "); - Fprin1 (backtrace_args (pdl)[i], Qnil); - } - } - write_string (")\n"); - } - pdl = backtrace_next (pdl); + if (!NILP (base)) + { /* Skip up to `base'. */ + base = Findirect_function (base, Qt); + while (backtrace_p (pdl) + && !EQ (base, Findirect_function (backtrace_function (pdl), Qt))) + pdl = backtrace_next (pdl); } - Vprint_level = old_print_level; - return Qnil; + return pdl; } static union specbinding * get_backtrace_frame (Lisp_Object nframes, Lisp_Object base) { - union specbinding *pdl = backtrace_top (); register EMACS_INT i; CHECK_NATNUM (nframes); - - if (!NILP (base)) - { /* Skip up to `base'. */ - base = Findirect_function (base, Qt); - while (backtrace_p (pdl) - && !EQ (base, Findirect_function (backtrace_function (pdl), Qt))) - pdl = backtrace_next (pdl); - } + union specbinding *pdl = get_backtrace_starting_at (base); /* Find the frame requested. */ for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--) @@ -3339,33 +3566,71 @@ get_backtrace_frame (Lisp_Object nframes, Lisp_Object base) return pdl; } -DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 2, NULL, - doc: /* Return the function and arguments NFRAMES up from current execution point. -If that frame has not evaluated the arguments yet (or is a special form), -the value is (nil FUNCTION ARG-FORMS...). -If that frame has evaluated its arguments and called its function already, -the value is (t FUNCTION ARG-VALUES...). -A &rest arg is represented as the tail of the list ARG-VALUES. -FUNCTION is whatever was supplied as car of evaluated list, -or a lambda expression for macro calls. -If NFRAMES is more than the number of frames, the value is nil. -If BASE is non-nil, it should be a function and NFRAMES counts from its -nearest activation frame. */) - (Lisp_Object nframes, Lisp_Object base) +static Lisp_Object +backtrace_frame_apply (Lisp_Object function, union specbinding *pdl) { - union specbinding *pdl = get_backtrace_frame (nframes, base); - if (!backtrace_p (pdl)) return Qnil; + + Lisp_Object flags = Qnil; + if (backtrace_debug_on_exit (pdl)) + flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil)); + if (backtrace_nargs (pdl) == UNEVALLED) - return Fcons (Qnil, - Fcons (backtrace_function (pdl), *backtrace_args (pdl))); + return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags); else { Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl)); + return call4 (function, Qt, backtrace_function (pdl), tem, flags); + } +} - return Fcons (Qt, Fcons (backtrace_function (pdl), tem)); +DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, + doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. +The debugger is entered when that frame exits, if the flag is non-nil. */) + (Lisp_Object level, Lisp_Object flag) +{ + CHECK_NUMBER (level); + union specbinding *pdl = get_backtrace_frame(level, Qnil); + + if (backtrace_p (pdl)) + set_backtrace_debug_on_exit (pdl, !NILP (flag)); + + return flag; +} + +DEFUN ("mapbacktrace", Fmapbacktrace, Smapbacktrace, 1, 2, 0, + doc: /* Call FUNCTION for each frame in backtrace. +If BASE is non-nil, it should be a function and iteration will start +from its nearest activation frame. +FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If +a frame has not evaluated its arguments yet or is a special form, +EVALD is nil and ARGS is a list of forms. If a frame has evaluated +its arguments and called its function already, EVALD is t and ARGS is +a list of values. +FLAGS is a plist of properties of the current frame: currently, the +only supported property is :debug-on-exit. `mapbacktrace' always +returns nil. */) + (Lisp_Object function, Lisp_Object base) +{ + union specbinding *pdl = get_backtrace_starting_at (base); + + while (backtrace_p (pdl)) + { + backtrace_frame_apply (function, pdl); + pdl = backtrace_next (pdl); } + + return Qnil; +} + +DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal, + Sbacktrace_frame_internal, 3, 3, NULL, + doc: /* Call FUNCTION on stack frame NFRAMES away from BASE. +Return the result of FUNCTION, or nil if no matching frame could be found. */) + (Lisp_Object function, Lisp_Object nframes, Lisp_Object base) +{ + return backtrace_frame_apply (function, get_backtrace_frame (nframes, base)); } /* For backtrace-eval, we want to temporarily unwind the last few elements of @@ -3452,7 +3717,7 @@ backtrace_eval_unrewind (int distance) { set_specpdl_old_value (tmp, Fbuffer_local_value (symbol, where)); - set_internal (symbol, old_value, where, 1); + set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND); } } break; @@ -3561,10 +3826,10 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. void -mark_specpdl (void) +mark_specpdl (union specbinding *first, union specbinding *ptr) { union specbinding *pdl; - for (pdl = specpdl; pdl != specpdl_ptr; pdl++) + for (pdl = first; pdl != ptr; pdl++) { switch (pdl->kind) { @@ -3590,6 +3855,7 @@ mark_specpdl (void) case SPECPDL_LET: mark_object (specpdl_symbol (pdl)); mark_object (specpdl_old_value (pdl)); + mark_object (specpdl_saved_value (pdl)); break; case SPECPDL_UNWIND_PTR: @@ -3726,6 +3992,10 @@ This is nil when the debugger is called under circumstances where it might not be safe to continue. */); debugger_may_continue = 1; + DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list, + doc: /* Non-nil means display call stack frames as lists. */); + debugger_stack_frame_as_list = 0; + DEFVAR_LISP ("debugger", Vdebugger, doc: /* Function to call to invoke debugger. If due to frame exit, args are `exit' and the value being returned; @@ -3792,6 +4062,7 @@ alist of active lexical bindings. */); defsubr (&Sset_default_toplevel_value); defsubr (&Sdefvar); defsubr (&Sdefvaralias); + DEFSYM (Qdefvaralias, "defvaralias"); defsubr (&Sdefconst); defsubr (&Smake_var_non_special); defsubr (&Slet); @@ -3809,6 +4080,7 @@ alist of active lexical bindings. */); defsubr (&Seval); defsubr (&Sapply); defsubr (&Sfuncall); + defsubr (&Sfunc_arity); defsubr (&Srun_hooks); defsubr (&Srun_hook_with_args); defsubr (&Srun_hook_with_args_until_success); @@ -3816,8 +4088,9 @@ alist of active lexical bindings. */); defsubr (&Srun_hook_wrapped); defsubr (&Sfetch_bytecode); defsubr (&Sbacktrace_debug); - defsubr (&Sbacktrace); - defsubr (&Sbacktrace_frame); + DEFSYM (QCdebug_on_exit, ":debug-on-exit"); + defsubr (&Smapbacktrace); + defsubr (&Sbacktrace_frame_internal); defsubr (&Sbacktrace_eval); defsubr (&Sbacktrace__locals); defsubr (&Sspecial_variable_p); diff --git a/src/fileio.c b/src/fileio.c index d94805f316b..1a744e02e28 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -25,6 +25,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <sys/stat.h> #include <unistd.h> +#ifdef DARWIN_OS +#include <sys/attr.h> +#endif + #ifdef HAVE_PWD_H #include <pwd.h> #endif @@ -52,9 +56,18 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "region-cache.h" #include "frame.h" +#ifdef HAVE_LINUX_FS_H +# include <sys/ioctl.h> +# include <linux/fs.h> +#endif + #ifdef WINDOWSNT #define NOMINMAX 1 #include <windows.h> +/* The redundant #ifdef is to avoid compiler warning about unused macro. */ +#ifdef NOMINMAX +#undef NOMINMAX +#endif #include <sys/file.h> #include "w32.h" #endif /* not WINDOWSNT */ @@ -185,17 +198,17 @@ void report_file_errno (char const *string, Lisp_Object name, int errorno) { Lisp_Object data = CONSP (name) || NILP (name) ? name : list1 (name); - synchronize_system_messages_locale (); - char *str = strerror (errorno); + char *str = emacs_strerror (errorno); + AUTO_STRING (unibyte_str, str); Lisp_Object errstring - = code_convert_string_norecord (build_unibyte_string (str), - Vlocale_coding_system, 0); + = code_convert_string_norecord (unibyte_str, Vlocale_coding_system, 0); Lisp_Object errdata = Fcons (errstring, data); if (errorno == EEXIST) xsignal (Qfile_already_exists, errdata); else - xsignal (Qfile_error, Fcons (build_string (string), errdata)); + xsignal (errorno == ENOENT ? Qfile_missing : Qfile_error, + Fcons (build_string (string), errdata)); } /* Signal a file-access failure that set errno. STRING describes the @@ -214,12 +227,11 @@ report_file_error (char const *string, Lisp_Object name) void report_file_notify_error (const char *string, Lisp_Object name) { - Lisp_Object data = CONSP (name) || NILP (name) ? name : list1 (name); - synchronize_system_messages_locale (); - char *str = strerror (errno); + char *str = emacs_strerror (errno); + AUTO_STRING (unibyte_str, str); Lisp_Object errstring - = code_convert_string_norecord (build_unibyte_string (str), - Vlocale_coding_system, 0); + = code_convert_string_norecord (unibyte_str, Vlocale_coding_system, 0); + Lisp_Object data = CONSP (name) || NILP (name) ? name : list1 (name); Lisp_Object errdata = Fcons (errstring, data); xsignal (Qfile_notify_error, Fcons (build_string (string), errdata)); @@ -510,7 +522,8 @@ This operation exists because a directory is also a file, but its name as a directory is different from its name as a file. The result can be used as the value of `default-directory' or passed as second argument to `expand-file-name'. -For a Unix-syntax file name, just appends a slash. */) +For a Unix-syntax file name, just appends a slash unless a trailing slash +is already present. */) (Lisp_Object file) { char *buf; @@ -871,6 +884,11 @@ filesystem tree, not (expand-file-name ".." dirname). */) /* Detect MSDOS file names with drive specifiers. */ && ! (IS_DRIVE (o[0]) && IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2])) + /* Detect escaped file names without drive spec after "/:". + These should not be recursively expanded, to avoid + including the default directory twice in the expanded + result. */ + && ! (o[0] == '/' && o[1] == ':') #ifdef WINDOWSNT /* Detect Windows file names in UNC format. */ && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1])) @@ -1015,11 +1033,9 @@ filesystem tree, not (expand-file-name ".." dirname). */) /* Drive must be set, so this is okay. */ if (strcmp (nm - 2, SSDATA (name)) != 0) { - char temp[] = " :"; - name = make_specified_string (nm, -1, p - nm, multibyte); - temp[0] = DRIVE_LETTER (drive); - AUTO_STRING (drive_prefix, temp); + char temp[] = { DRIVE_LETTER (drive), ':', 0 }; + AUTO_STRING_WITH_LEN (drive_prefix, temp, 2); name = concat2 (drive_prefix, name); } #ifdef WINDOWSNT @@ -1053,7 +1069,11 @@ filesystem tree, not (expand-file-name ".." dirname). */) newdir = newdirlim = 0; - if (nm[0] == '~') /* prefix ~ */ + if (nm[0] == '~' /* prefix ~ */ +#ifdef DOS_NT + && !is_escaped /* don't expand ~ in escaped file names */ +#endif + ) { if (IS_DIRECTORY_SEP (nm[1]) || nm[1] == 0) /* ~ by itself */ @@ -1832,6 +1852,18 @@ barf_or_query_if_file_exists (Lisp_Object absname, bool known_to_exist, } } +#ifndef WINDOWSNT +/* Copy data to DEST from SOURCE if possible. Return true if OK. */ +static bool +clone_file (int dest, int source) +{ +#ifdef FICLONE + return ioctl (dest, FICLONE, source) == 0; +#endif + return false; +} +#endif + DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 6, "fCopy file: \nGCopy %s to file: \np\nP", doc: /* Copy FILE to NEWNAME. Both args must be strings. @@ -1978,7 +2010,7 @@ permissions. */) record_unwind_protect_int (close_file_unwind, ofd); - off_t oldsize = 0, newsize = 0; + off_t oldsize = 0, newsize; if (already_exists) { @@ -1994,17 +2026,19 @@ permissions. */) immediate_quit = 1; QUIT; - while (true) + + if (clone_file (ofd, ifd)) + newsize = st.st_size; + else { char buf[MAX_ALLOCA]; - ptrdiff_t n = emacs_read (ifd, buf, sizeof buf); + ptrdiff_t n; + for (newsize = 0; 0 < (n = emacs_read (ifd, buf, sizeof buf)); + newsize += n) + if (emacs_write_sig (ofd, buf, n) != n) + report_file_error ("Write error", newname); if (n < 0) report_file_error ("Read error", file); - if (n == 0) - break; - if (emacs_write_sig (ofd, buf, n) != n) - report_file_error ("Write error", newname); - newsize += n; } /* Truncate any existing output file after writing the data. This @@ -2211,6 +2245,105 @@ internal_delete_file (Lisp_Object filename) return NILP (tem); } +/* Filesystems are case-sensitive on all supported systems except + MS-Windows, MS-DOS, Cygwin, and Mac OS X. They are always + case-insensitive on the first two, but they may or may not be + case-insensitive on Cygwin and OS X. The following function + attempts to provide a runtime test on those two systems. If the + test is not conclusive, we assume case-insensitivity on Cygwin and + case-sensitivity on Mac OS X. + + FIXME: Mounted filesystems on Posix hosts, like Samba shares or + NFS-mounted Windows volumes, might be case-insensitive. Can we + detect this? */ + +static bool +file_name_case_insensitive_p (const char *filename) +{ + /* Use pathconf with _PC_CASE_INSENSITIVE or _PC_CASE_SENSITIVE if + those flags are available. As of this writing (2016-11-14), + Cygwin is the only platform known to support the former (starting + with Cygwin-2.6.1), and Mac OS X is the only platform known to + support the latter. + + There have been reports that pathconf with _PC_CASE_SENSITIVE + does not work reliably on Mac OS X. If you have a problem, + please recompile Emacs with -D DARWIN_OS_CASE_SENSITIVE_FIXME=1 or + -D DARWIN_OS_CASE_SENSITIVE_FIXME=2, and file a bug report saying + whether this fixed your problem. */ + +#ifdef _PC_CASE_INSENSITIVE + int res = pathconf (filename, _PC_CASE_INSENSITIVE); + if (res >= 0) + return res > 0; +#elif defined _PC_CASE_SENSITIVE && !defined DARWIN_OS_CASE_SENSITIVE_FIXME + int res = pathconf (filename, _PC_CASE_SENSITIVE); + if (res >= 0) + return res == 0; +#endif + +#ifdef DARWIN_OS +# ifndef DARWIN_OS_CASE_SENSITIVE_FIXME + int DARWIN_OS_CASE_SENSITIVE_FIXME = 0; +# endif + + if (DARWIN_OS_CASE_SENSITIVE_FIXME == 1) + { + /* This is based on developer.apple.com's getattrlist man page. */ + struct attrlist alist = {.volattr = ATTR_VOL_CAPABILITIES}; + vol_capabilities_attr_t vcaps; + if (getattrlist (filename, &alist, &vcaps, sizeof vcaps, 0) == 0) + { + if (vcaps.valid[VOL_CAPABILITIES_FORMAT] & VOL_CAP_FMT_CASE_SENSITIVE) + return ! (vcaps.capabilities[VOL_CAPABILITIES_FORMAT] + & VOL_CAP_FMT_CASE_SENSITIVE); + } + } + else if (DARWIN_OS_CASE_SENSITIVE_FIXME == 2) + { + /* The following is based on + http://lists.apple.com/archives/darwin-dev/2007/Apr/msg00010.html. */ + struct attrlist alist; + unsigned char buffer[sizeof (vol_capabilities_attr_t) + sizeof (size_t)]; + + memset (&alist, 0, sizeof (alist)); + alist.volattr = ATTR_VOL_CAPABILITIES; + if (getattrlist (filename, &alist, buffer, sizeof (buffer), 0) + || !(alist.volattr & ATTR_VOL_CAPABILITIES)) + return 0; + vol_capabilities_attr_t *vcaps = buffer; + return !(vcaps->capabilities[0] & VOL_CAP_FMT_CASE_SENSITIVE); + } +#endif /* DARWIN_OS */ + +#if defined CYGWIN || defined DOS_NT + return true; +#else + return false; +#endif +} + +DEFUN ("file-name-case-insensitive-p", Ffile_name_case_insensitive_p, + Sfile_name_case_insensitive_p, 1, 1, 0, + doc: /* Return t if file FILENAME is on a case-insensitive filesystem. +The arg must be a string. */) + (Lisp_Object filename) +{ + Lisp_Object handler; + + CHECK_STRING (filename); + filename = Fexpand_file_name (filename, Qnil); + + /* If the file name has special constructs in it, + call the corresponding file handler. */ + handler = Ffind_file_name_handler (filename, Qfile_name_case_insensitive_p); + if (!NILP (handler)) + return call2 (handler, Qfile_name_case_insensitive_p, filename); + + filename = ENCODE_FILE (filename); + return file_name_case_insensitive_p (SSDATA (filename)) ? Qt : Qnil; +} + DEFUN ("rename-file", Frename_file, Srename_file, 2, 3, "fRename file: \nGRename %s to file: \np", doc: /* Rename FILE as NEWNAME. Both args must be strings. @@ -2230,12 +2363,11 @@ This is what happens in interactive use with M-x. */) file = Fexpand_file_name (file, Qnil); if ((!NILP (Ffile_directory_p (newname))) -#ifdef DOS_NT - /* If the file names are identical but for the case, - don't attempt to move directory to itself. */ - && (NILP (Fstring_equal (Fdowncase (file), Fdowncase (newname)))) -#endif - ) + /* If the filesystem is case-insensitive and the file names are + identical but for the case, don't attempt to move directory + to itself. */ + && (NILP (Ffile_name_case_insensitive_p (file)) + || NILP (Fstring_equal (Fdowncase (file), Fdowncase (newname))))) { Lisp_Object fname = (NILP (Ffile_directory_p (file)) ? file : Fdirectory_file_name (file)); @@ -2256,14 +2388,12 @@ This is what happens in interactive use with M-x. */) encoded_file = ENCODE_FILE (file); encoded_newname = ENCODE_FILE (newname); -#ifdef DOS_NT - /* If the file names are identical but for the case, don't ask for - confirmation: they simply want to change the letter-case of the - file name. */ - if (NILP (Fstring_equal (Fdowncase (file), Fdowncase (newname)))) -#endif - if (NILP (ok_if_already_exists) - || INTEGERP (ok_if_already_exists)) + /* If the filesystem is case-insensitive and the file names are + identical but for the case, don't ask for confirmation: they + simply want to change the letter-case of the file name. */ + if ((!(file_name_case_insensitive_p (SSDATA (encoded_file))) + || NILP (Fstring_equal (Fdowncase (file), Fdowncase (newname)))) + && ((NILP (ok_if_already_exists) || INTEGERP (ok_if_already_exists)))) barf_or_query_if_file_exists (newname, false, "rename to it", INTEGERP (ok_if_already_exists), false); if (rename (SSDATA (encoded_file), SSDATA (encoded_newname)) < 0) @@ -2544,7 +2674,7 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, /* The read-only attribute of the parent directory doesn't affect whether a file or directory can be created within it. Some day we should check ACLs though, which do affect this. */ - return file_directory_p (SDATA (dir)) ? Qt : Qnil; + return file_directory_p (SSDATA (dir)) ? Qt : Qnil; #else return check_writable (SSDATA (dir), W_OK | X_OK) ? Qt : Qnil; #endif @@ -2775,7 +2905,7 @@ See `file-symlink-p' to distinguish symlinks. */) /* Tell stat to use expensive method to get accurate info. */ Vw32_get_true_file_attributes = Qt; - result = stat (SDATA (absname), &st); + result = stat (SSDATA (absname), &st); Vw32_get_true_file_attributes = tem; if (result < 0) @@ -3363,6 +3493,21 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted, } } +/* Make sure the gap is at Z_BYTE. This is required to treat buffer + text as a linear C char array. */ +static void +maybe_move_gap (struct buffer *b) +{ + if (BUF_GPT_BYTE (b) != BUF_Z_BYTE (b)) + { + struct buffer *cb = current_buffer; + + set_buffer_internal (b); + move_gap_both (Z, Z_BYTE); + set_buffer_internal (cb); + } +} + /* FIXME: insert-file-contents should be split with the top-level moved to Elisp and only the core kept in C. */ @@ -3436,9 +3581,6 @@ by calling `format-decode', which see. */) if (!NILP (BVAR (current_buffer, read_only))) Fbarf_if_buffer_read_only (Qnil); - if (!NILP (Ffboundp (Qundo_auto__undoable_change_no_timer))) - call0 (Qundo_auto__undoable_change_no_timer); - val = Qnil; p = Qnil; orig_filename = Qnil; @@ -3830,6 +3972,7 @@ by calling `format-decode', which see. */) if (! giveup_match_end) { ptrdiff_t temp; + ptrdiff_t this_count = SPECPDL_INDEX (); /* We win! We can handle REPLACE the optimized way. */ @@ -3859,13 +4002,19 @@ by calling `format-decode', which see. */) beg_offset += same_at_start - BEGV_BYTE; end_offset -= ZV_BYTE - same_at_end; - invalidate_buffer_caches (current_buffer, - BYTE_TO_CHAR (same_at_start), - same_at_end_charpos); - del_range_byte (same_at_start, same_at_end, 0); + /* This binding is to avoid ask-user-about-supersession-threat + being called in insert_from_buffer or del_range_bytes (via + prepare_to_modify_buffer). + AFAICT we could avoid ask-user-about-supersession-threat by setting + current_buffer->modtime earlier, but we could still end up calling + ask-user-about-supersession-threat if the file is modified while + we read it, so we bind buffer-file-name instead. */ + specbind (intern ("buffer-file-name"), Qnil); + del_range_byte (same_at_start, same_at_end); /* Insert from the file at the proper position. */ temp = BYTE_TO_CHAR (same_at_start); SET_PT_BOTH (temp, same_at_start); + unbind_to (this_count, Qnil); /* If display currently starts at beginning of line, keep it that way. */ @@ -3949,6 +4098,7 @@ by calling `format-decode', which see. */) coding_system = CODING_ID_NAME (coding.id); set_coding_system = true; + maybe_move_gap (XBUFFER (conversion_buffer)); decoded = BUF_BEG_ADDR (XBUFFER (conversion_buffer)); inserted = (BUF_Z_BYTE (XBUFFER (conversion_buffer)) - BUF_BEG_BYTE (XBUFFER (conversion_buffer))); @@ -3969,10 +4119,9 @@ by calling `format-decode', which see. */) /* Truncate the buffer to the size of the file. */ if (same_at_start != same_at_end) { - invalidate_buffer_caches (current_buffer, - BYTE_TO_CHAR (same_at_start), - BYTE_TO_CHAR (same_at_end)); - del_range_byte (same_at_start, same_at_end, 0); + /* See previous specbind for the reason behind this. */ + specbind (intern ("buffer-file-name"), Qnil); + del_range_byte (same_at_start, same_at_end); } inserted = 0; @@ -4020,12 +4169,11 @@ by calling `format-decode', which see. */) we are taking from the decoded string. */ inserted -= (ZV_BYTE - same_at_end) + (same_at_start - BEGV_BYTE); + /* See previous specbind for the reason behind this. */ + specbind (intern ("buffer-file-name"), Qnil); if (same_at_end != same_at_start) { - invalidate_buffer_caches (current_buffer, - BYTE_TO_CHAR (same_at_start), - same_at_end_charpos); - del_range_byte (same_at_start, same_at_end, 0); + del_range_byte (same_at_start, same_at_end); temp = GPT; eassert (same_at_start == GPT_BYTE); same_at_start = GPT_BYTE; @@ -4046,10 +4194,6 @@ by calling `format-decode', which see. */) same_at_start + inserted - BEGV_BYTE + BUF_BEG_BYTE (XBUFFER (conversion_buffer))) - same_at_start_charpos); - /* This binding is to avoid ask-user-about-supersession-threat - being called in insert_from_buffer (via in - prepare_to_modify_buffer). */ - specbind (intern ("buffer-file-name"), Qnil); insert_from_buffer (XBUFFER (conversion_buffer), same_at_start_charpos, inserted_chars, 0); /* Set `inserted' to the number of inserted characters. */ @@ -4504,7 +4648,7 @@ by calling `format-decode', which see. */) PT - BEG, Z - PT - inserted); if (read_quit) - Fsignal (Qquit, Qnil); + quit (); /* Retval needs to be dealt with in all cases consistently. */ if (NILP (val)) @@ -4614,8 +4758,7 @@ choose_write_coding_system (Lisp_Object start, Lisp_Object end, Lisp_Object file } /* If the decided coding-system doesn't specify end-of-line - format, we use that of - `default-buffer-file-coding-system'. */ + format, we use that of `buffer-file-coding-system'. */ if (! using_default_coding) { Lisp_Object dflt = BVAR (&buffer_defaults, buffer_file_coding_system); @@ -4693,7 +4836,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, { int open_flags; int mode; - off_t offset IF_LINT (= 0); + off_t offset UNINIT; bool open_and_close_file = desc < 0; bool ok; int save_errno = 0; @@ -4701,7 +4844,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, struct stat st; struct timespec modtime; ptrdiff_t count = SPECPDL_INDEX (); - ptrdiff_t count1 IF_LINT (= 0); + ptrdiff_t count1 UNINIT; Lisp_Object handler; Lisp_Object visit_file; Lisp_Object annotations; @@ -4810,7 +4953,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, encoded_filename = ENCODE_FILE (filename); fn = SSDATA (encoded_filename); - open_flags = O_WRONLY | O_BINARY | O_CREAT; + open_flags = O_WRONLY | O_CREAT; open_flags |= EQ (mustbenew, Qexcl) ? O_EXCL : !NILP (append) ? 0 : O_TRUNC; if (NUMBERP (append)) offset = file_offset (append); @@ -4929,7 +5072,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, if (timespec_valid_p (modtime) && ! (valid_timestamp_file_system && st.st_dev == timestamp_file_system)) { - int desc1 = emacs_open (fn, O_WRONLY | O_BINARY, 0); + int desc1 = emacs_open (fn, O_WRONLY, 0); if (desc1 >= 0) { struct stat st1; @@ -5382,25 +5525,15 @@ An argument specifies the modification time value to use static Lisp_Object auto_save_error (Lisp_Object error_val) { - Lisp_Object msg; - int i; - auto_save_error_occurred = 1; ring_bell (XFRAME (selected_frame)); AUTO_STRING (format, "Auto-saving %s: %s"); - msg = CALLN (Fformat, format, BVAR (current_buffer, name), - Ferror_message_string (error_val)); - - for (i = 0; i < 3; ++i) - { - if (i == 0) - message3 (msg); - else - message3_nolog (msg); - Fsleep_for (make_number (1), Qnil); - } + Lisp_Object msg = CALLN (Fformat, format, BVAR (current_buffer, name), + Ferror_message_string (error_val)); + call3 (intern ("display-warning"), + intern ("auto-save"), msg, intern ("error")); return Qnil; } @@ -5801,8 +5934,6 @@ syms_of_fileio (void) which gives a list of operations it handles. */ DEFSYM (Qoperations, "operations"); - DEFSYM (Qundo_auto__undoable_change_no_timer, "undo-auto--undoable-change-no-timer"); - DEFSYM (Qexpand_file_name, "expand-file-name"); DEFSYM (Qsubstitute_in_file_name, "substitute-in-file-name"); DEFSYM (Qdirectory_file_name, "directory-file-name"); @@ -5814,6 +5945,7 @@ syms_of_fileio (void) DEFSYM (Qmake_directory_internal, "make-directory-internal"); DEFSYM (Qmake_directory, "make-directory"); DEFSYM (Qdelete_file, "delete-file"); + DEFSYM (Qfile_name_case_insensitive_p, "file-name-case-insensitive-p"); DEFSYM (Qrename_file, "rename-file"); DEFSYM (Qadd_name_to_file, "add-name-to-file"); DEFSYM (Qmake_symbolic_link, "make-symbolic-link"); @@ -5852,6 +5984,7 @@ syms_of_fileio (void) DEFSYM (Qfile_error, "file-error"); DEFSYM (Qfile_already_exists, "file-already-exists"); DEFSYM (Qfile_date_error, "file-date-error"); + DEFSYM (Qfile_missing, "file-missing"); DEFSYM (Qfile_notify_error, "file-notify-error"); DEFSYM (Qexcl, "excl"); @@ -5904,6 +6037,11 @@ behaves as if file names were encoded in `utf-8'. */); Fput (Qfile_date_error, Qerror_message, build_pure_c_string ("Cannot set file date")); + Fput (Qfile_missing, Qerror_conditions, + Fpurecopy (list3 (Qfile_missing, Qfile_error, Qerror))); + Fput (Qfile_missing, Qerror_message, + build_pure_c_string ("File is missing")); + Fput (Qfile_notify_error, Qerror_conditions, Fpurecopy (list3 (Qfile_notify_error, Qfile_error, Qerror))); Fput (Qfile_notify_error, Qerror_message, @@ -6071,6 +6209,7 @@ This includes interactive calls to `delete-file' and defsubr (&Smake_directory_internal); defsubr (&Sdelete_directory_internal); defsubr (&Sdelete_file); + defsubr (&Sfile_name_case_insensitive_p); defsubr (&Srename_file); defsubr (&Sadd_name_to_file); defsubr (&Smake_symbolic_link); diff --git a/src/filelock.c b/src/filelock.c index 6c60c3e8e1c..a4b742abb5d 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -27,6 +27,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <sys/stat.h> #include <signal.h> #include <stdio.h> +#include <stdlib.h> #ifdef HAVE_PWD_H #include <pwd.h> @@ -65,7 +66,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #define BOOT_TIME_FILE "/var/run/random-seed" #endif -#ifndef WTMP_FILE +#if !defined WTMP_FILE && !defined WINDOWSNT #define WTMP_FILE "/var/log/wtmp" #endif @@ -192,14 +193,11 @@ get_boot_time (void) /* If we did not find a boot time in wtmp, look at wtmp, and so on. */ for (counter = 0; counter < 20 && ! boot_time; counter++) { + Lisp_Object filename = Qnil; + bool delete_flag = false; char cmd_string[sizeof WTMP_FILE ".19.gz"]; - Lisp_Object tempname, filename; - bool delete_flag = 0; - - filename = Qnil; - - tempname = make_formatted_string - (cmd_string, "%s.%d", WTMP_FILE, counter); + AUTO_STRING_WITH_LEN (tempname, cmd_string, + sprintf (cmd_string, "%s.%d", WTMP_FILE, counter)); if (! NILP (Ffile_exists_p (tempname))) filename = tempname; else @@ -219,7 +217,7 @@ get_boot_time (void) CALLN (Fcall_process, build_string ("gzip"), Qnil, list2 (QCfile, filename), Qnil, build_string ("-cd"), tempname); - delete_flag = 1; + delete_flag = true; } } @@ -254,14 +252,7 @@ get_boot_time_1 (const char *filename, bool newest) struct utmp ut, *utp; if (filename) - { - /* On some versions of IRIX, opening a nonexistent file name - is likely to crash in the utmp routines. */ - if (faccessat (AT_FDCWD, filename, R_OK, AT_EACCESS) != 0) - return; - - utmpname (filename); - } + utmpname (filename); setutent (); @@ -496,7 +487,7 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1]) while ((nbytes = readlinkat (AT_FDCWD, lfname, lfinfo, MAX_LFINFO + 1)) < 0 && errno == EINVAL) { - int fd = emacs_open (lfname, O_RDONLY | O_BINARY | O_NOFOLLOW, 0); + int fd = emacs_open (lfname, O_RDONLY | O_NOFOLLOW, 0); if (0 <= fd) { /* Use read, not emacs_read, since FD isn't unwind-protected. */ @@ -703,7 +694,7 @@ lock_file (Lisp_Object fn) if (!NILP (subject_buf) && NILP (Fverify_visited_file_modtime (subject_buf)) && !NILP (Ffile_exists_p (fn))) - call1 (intern ("ask-user-about-supersession-threat"), fn); + call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); } diff --git a/src/firstfile.c b/src/firstfile.c index 188d4f81b5c..962d6f6c7f6 100644 --- a/src/firstfile.c +++ b/src/firstfile.c @@ -26,7 +26,7 @@ char my_begbss[1]; /* Do not initialize this variable. */ static char _my_begbss[1]; char * my_begbss_static = _my_begbss; -/* Add a dummy reference to ensure emacs.obj is linked in. */ +/* Add a dummy reference to ensure emacs.o is linked in. */ extern int main (int, char **); -static int (*dummy) (int, char **) = main; +int (*dummy_main_reference) (int, char **) = main; #endif diff --git a/src/fns.c b/src/fns.c index d5a1f74d0d8..dfc78424dda 100644 --- a/src/fns.c +++ b/src/fns.c @@ -20,9 +20,12 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> +#include <stdlib.h> #include <unistd.h> +#include <filevercmp.h> #include <intprops.h> #include <vla.h> +#include <errno.h> #include "lisp.h" #include "character.h" @@ -331,6 +334,50 @@ Symbols are also allowed; their print names are used instead. */) return i1 < SCHARS (string2) ? Qt : Qnil; } +DEFUN ("string-version-lessp", Fstring_version_lessp, + Sstring_version_lessp, 2, 2, 0, + doc: /* Return non-nil if S1 is less than S2, as version strings. + +This function compares version strings S1 and S2: + 1) By prefix lexicographically. + 2) Then by version (similarly to version comparison of Debian's dpkg). + Leading zeros in version numbers are ignored. + 3) If both prefix and version are equal, compare as ordinary strings. + +For example, \"foo2.png\" compares less than \"foo12.png\". +Case is significant. +Symbols are also allowed; their print names are used instead. */) + (Lisp_Object string1, Lisp_Object string2) +{ + if (SYMBOLP (string1)) + string1 = SYMBOL_NAME (string1); + if (SYMBOLP (string2)) + string2 = SYMBOL_NAME (string2); + CHECK_STRING (string1); + CHECK_STRING (string2); + + char *p1 = SSDATA (string1); + char *p2 = SSDATA (string2); + char *lim1 = p1 + SBYTES (string1); + char *lim2 = p2 + SBYTES (string2); + int cmp; + + while ((cmp = filevercmp (p1, p2)) == 0) + { + /* If the strings are identical through their first null bytes, + skip past identical prefixes and try again. */ + ptrdiff_t size = strlen (p1) + 1; + p1 += size; + p2 += size; + if (lim1 < p1) + return lim2 < p2 ? Qnil : Qt; + if (lim2 < p2) + return Qnil; + } + + return cmp < 0 ? Qt : Qnil; +} + DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0, doc: /* Return t if first arg string is less than second in collation order. Symbols are also allowed; their print names are used instead. @@ -1348,7 +1395,7 @@ The value is actually the tail of LIST whose car is ELT. */) (register Lisp_Object elt, Lisp_Object list) { register Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + for (tail = list; !NILP (tail); tail = XCDR (tail)) { register Lisp_Object tem; CHECK_LIST_CONS (tail, list); @@ -1396,7 +1443,7 @@ The value is actually the tail of LIST whose car is ELT. */) if (!FLOATP (elt)) return Fmemq (elt, list); - for (tail = list; CONSP (tail); tail = XCDR (tail)) + for (tail = list; !NILP (tail); tail = XCDR (tail)) { register Lisp_Object tem; CHECK_LIST_CONS (tail, list); @@ -1709,7 +1756,7 @@ changing the value of a sequence `foo'. */) { Lisp_Object tail, prev; - for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail)) + for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail)) { CHECK_LIST_CONS (tail, seq); @@ -2470,11 +2517,13 @@ usage: (nconc &rest LISTS) */) } /* This is the guts of all mapping functions. - Apply FN to each element of SEQ, one by one, - storing the results into elements of VALS, a C vector of Lisp_Objects. - LENI is the length of VALS, which should also be the length of SEQ. */ + Apply FN to each element of SEQ, one by one, storing the results + into elements of VALS, a C vector of Lisp_Objects. LENI is the + length of VALS, which should also be the length of SEQ. Return the + number of results; although this is normally LENI, it can be less + if SEQ is made shorter as a side effect of FN. */ -static void +static EMACS_INT mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) { Lisp_Object tail, dummy; @@ -2517,14 +2566,18 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) else /* Must be a list, since Flength did not get an error */ { tail = seq; - for (i = 0; i < leni && CONSP (tail); i++) + for (i = 0; i < leni; i++) { + if (! CONSP (tail)) + return i; dummy = call1 (fn, XCAR (tail)); if (vals) vals[i] = dummy; tail = XCDR (tail); } } + + return leni; } DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0, @@ -2534,34 +2587,26 @@ SEPARATOR results in spaces between the values returned by FUNCTION. SEQUENCE may be a list, a vector, a bool-vector, or a string. */) (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator) { - Lisp_Object len; - EMACS_INT leni; - EMACS_INT nargs; - ptrdiff_t i; - Lisp_Object *args; - Lisp_Object ret; USE_SAFE_ALLOCA; - - len = Flength (sequence); + EMACS_INT leni = XFASTINT (Flength (sequence)); if (CHAR_TABLE_P (sequence)) wrong_type_argument (Qlistp, sequence); - leni = XINT (len); - nargs = leni + leni - 1; - if (nargs < 0) return empty_unibyte_string; - - SAFE_ALLOCA_LISP (args, nargs); - - mapcar1 (leni, args, function, sequence); + EMACS_INT args_alloc = 2 * leni - 1; + if (args_alloc < 0) + return empty_unibyte_string; + Lisp_Object *args; + SAFE_ALLOCA_LISP (args, args_alloc); + ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence); + ptrdiff_t nargs = 2 * nmapped - 1; - for (i = leni - 1; i > 0; i--) + for (ptrdiff_t i = nmapped - 1; i > 0; i--) args[i + i] = args[i]; - for (i = 1; i < nargs; i += 2) + for (ptrdiff_t i = 1; i < nargs; i += 2) args[i] = separator; - ret = Fconcat (nargs, args); + Lisp_Object ret = Fconcat (nargs, args); SAFE_FREE (); - return ret; } @@ -2571,24 +2616,15 @@ The result is a list just as long as SEQUENCE. SEQUENCE may be a list, a vector, a bool-vector, or a string. */) (Lisp_Object function, Lisp_Object sequence) { - register Lisp_Object len; - register EMACS_INT leni; - register Lisp_Object *args; - Lisp_Object ret; USE_SAFE_ALLOCA; - - len = Flength (sequence); + EMACS_INT leni = XFASTINT (Flength (sequence)); if (CHAR_TABLE_P (sequence)) wrong_type_argument (Qlistp, sequence); - leni = XFASTINT (len); - + Lisp_Object *args; SAFE_ALLOCA_LISP (args, leni); - - mapcar1 (leni, args, function, sequence); - - ret = Flist (leni, args); + ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence); + Lisp_Object ret = Flist (nmapped, args); SAFE_FREE (); - return ret; } @@ -2607,6 +2643,24 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */) return sequence; } + +DEFUN ("mapcan", Fmapcan, Smapcan, 2, 2, 0, + doc: /* Apply FUNCTION to each element of SEQUENCE, and concatenate +the results by altering them (using `nconc'). +SEQUENCE may be a list, a vector, a bool-vector, or a string. */) + (Lisp_Object function, Lisp_Object sequence) +{ + USE_SAFE_ALLOCA; + EMACS_INT leni = XFASTINT (Flength (sequence)); + if (CHAR_TABLE_P (sequence)) + wrong_type_argument (Qlistp, sequence); + Lisp_Object *args; + SAFE_ALLOCA_LISP (args, leni); + ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence); + Lisp_Object ret = Fnconc (nmapped, args); + SAFE_FREE (); + return ret; +} /* This is how C code calls `yes-or-no-p' and allows the user to redefine it. */ @@ -2959,7 +3013,6 @@ The data read from the system are decoded using `locale-coding-system'. */) { char *str = NULL; #ifdef HAVE_LANGINFO_CODESET - Lisp_Object val; if (EQ (item, Qcodeset)) { str = nl_langinfo (CODESET); @@ -2975,7 +3028,7 @@ The data read from the system are decoded using `locale-coding-system'. */) for (i = 0; i < 7; i++) { str = nl_langinfo (days[i]); - val = build_unibyte_string (str); + AUTO_STRING (val, str); /* Fixme: Is this coding system necessarily right, even if it is consistent with CODESET? If not, what to do? */ ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system, @@ -2995,7 +3048,7 @@ The data read from the system are decoded using `locale-coding-system'. */) for (i = 0; i < 12; i++) { str = nl_langinfo (months[i]); - val = build_unibyte_string (str); + AUTO_STRING (val, str); ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system, 0)); } @@ -3140,7 +3193,7 @@ into shorter lines. */) SET_PT_BOTH (XFASTINT (beg), ibeg); insert (encoded, encoded_length); SAFE_FREE (); - del_range_byte (ibeg + encoded_length, iend + encoded_length, 1); + del_range_byte (ibeg + encoded_length, iend + encoded_length); /* If point was outside of the region, restore it exactly; else just move to the beginning of the region. */ @@ -3628,8 +3681,6 @@ larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max) Low-level Functions ***********************************************************************/ -struct hash_table_test hashtest_eq, hashtest_eql, hashtest_equal; - /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code HASH2 in hash table H using `eql'. Value is true if KEY1 and KEY2 are the same. */ @@ -3670,7 +3721,6 @@ cmpfn_user_defined (struct hash_table_test *ht, return !NILP (call2 (ht->user_cmp_function, key1, key2)); } - /* Value is a hash code for KEY for use in hash table H which uses `eq' to compare keys. The hash code returned is guaranteed to fit in a Lisp integer. */ @@ -3678,34 +3728,27 @@ cmpfn_user_defined (struct hash_table_test *ht, static EMACS_UINT hashfn_eq (struct hash_table_test *ht, Lisp_Object key) { - EMACS_UINT hash = XHASH (key) ^ XTYPE (key); - return hash; + return XHASH (key) ^ XTYPE (key); } /* Value is a hash code for KEY for use in hash table H which uses - `eql' to compare keys. The hash code returned is guaranteed to fit + `equal' to compare keys. The hash code returned is guaranteed to fit in a Lisp integer. */ static EMACS_UINT -hashfn_eql (struct hash_table_test *ht, Lisp_Object key) +hashfn_equal (struct hash_table_test *ht, Lisp_Object key) { - EMACS_UINT hash; - if (FLOATP (key)) - hash = sxhash (key, 0); - else - hash = XHASH (key) ^ XTYPE (key); - return hash; + return sxhash (key, 0); } /* Value is a hash code for KEY for use in hash table H which uses - `equal' to compare keys. The hash code returned is guaranteed to fit + `eql' to compare keys. The hash code returned is guaranteed to fit in a Lisp integer. */ static EMACS_UINT -hashfn_equal (struct hash_table_test *ht, Lisp_Object key) +hashfn_eql (struct hash_table_test *ht, Lisp_Object key) { - EMACS_UINT hash = sxhash (key, 0); - return hash; + return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key); } /* Value is a hash code for KEY for use in hash table H which uses as @@ -3719,6 +3762,14 @@ hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key) return hashfn_eq (ht, hash); } +struct hash_table_test const + hashtest_eq = { LISPSYM_INITIALLY (Qeq), LISPSYM_INITIALLY (Qnil), + LISPSYM_INITIALLY (Qnil), 0, hashfn_eq }, + hashtest_eql = { LISPSYM_INITIALLY (Qeql), LISPSYM_INITIALLY (Qnil), + LISPSYM_INITIALLY (Qnil), cmpfn_eql, hashfn_eql }, + hashtest_equal = { LISPSYM_INITIALLY (Qequal), LISPSYM_INITIALLY (Qnil), + LISPSYM_INITIALLY (Qnil), cmpfn_equal, hashfn_equal }; + /* Allocate basically initialized hash table. */ static struct Lisp_Hash_Table * @@ -4408,15 +4459,29 @@ sxhash (Lisp_Object obj, int depth) Lisp Interface ***********************************************************************/ +DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0, + doc: /* Return an integer hash code for OBJ suitable for `eq'. +If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */) + (Lisp_Object obj) +{ + return make_number (hashfn_eq (NULL, obj)); +} -DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0, - doc: /* Compute a hash code for OBJ and return it as integer. */) +DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0, + doc: /* Return an integer hash code for OBJ suitable for `eql'. +If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */) (Lisp_Object obj) { - EMACS_UINT hash = sxhash (obj, 0); - return make_number (hash); + return make_number (hashfn_eql (NULL, obj)); } +DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0, + doc: /* Return an integer hash code for OBJ suitable for `equal'. +If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */) + (Lisp_Object obj) +{ + return make_number (hashfn_equal (NULL, obj)); +} DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0, doc: /* Create and return a new hash table. @@ -4697,6 +4762,21 @@ returns nil, then (funcall TEST x1 x2) also returns nil. */) #include "sha256.h" #include "sha512.h" +static Lisp_Object +make_digest_string (Lisp_Object digest, int digest_size) +{ + unsigned char *p = SDATA (digest); + + for (int i = digest_size - 1; i >= 0; i--) + { + static char const hexdigit[16] = "0123456789abcdef"; + int p_i = p[i]; + p[2 * i] = hexdigit[p_i >> 4]; + p[2 * i + 1] = hexdigit[p_i & 0xf]; + } + return digest; +} + /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */ static Lisp_Object @@ -4704,7 +4784,6 @@ secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror, Lisp_Object binary) { - int i; ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte; register EMACS_INT b, e; register struct buffer *bp; @@ -4896,17 +4975,7 @@ secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, SSDATA (digest)); if (NILP (binary)) - { - unsigned char *p = SDATA (digest); - for (i = digest_size - 1; i >= 0; i--) - { - static char const hexdigit[16] = "0123456789abcdef"; - int p_i = p[i]; - p[2 * i] = hexdigit[p_i >> 4]; - p[2 * i + 1] = hexdigit[p_i & 0xf]; - } - return digest; - } + return make_digest_string (digest, digest_size); else return make_unibyte_string (SSDATA (digest), digest_size); } @@ -4957,6 +5026,45 @@ If BINARY is non-nil, returns a string in binary form. */) { return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary); } + +DEFUN ("buffer-hash", Fbuffer_hash, Sbuffer_hash, 0, 1, 0, + doc: /* Return a hash of the contents of BUFFER-OR-NAME. +This hash is performed on the raw internal format of the buffer, +disregarding any coding systems. +If nil, use the current buffer." */ ) + (Lisp_Object buffer_or_name) +{ + Lisp_Object buffer; + struct buffer *b; + struct sha1_ctx ctx; + + if (NILP (buffer_or_name)) + buffer = Fcurrent_buffer (); + else + buffer = Fget_buffer (buffer_or_name); + if (NILP (buffer)) + nsberror (buffer_or_name); + + b = XBUFFER (buffer); + sha1_init_ctx (&ctx); + + /* Process the first part of the buffer. */ + sha1_process_bytes (BUF_BEG_ADDR (b), + BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b), + &ctx); + + /* If the gap is before the end of the buffer, process the last half + of the buffer. */ + if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b)) + sha1_process_bytes (BUF_GAP_END_ADDR (b), + BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b), + &ctx); + + Lisp_Object digest = make_uninit_string (SHA1_DIGEST_SIZE * 2); + sha1_finish_ctx (&ctx, SSDATA (digest)); + return make_digest_string (digest, SHA1_DIGEST_SIZE); +} + void syms_of_fns (void) @@ -4984,7 +5092,9 @@ syms_of_fns (void) DEFSYM (Qkey_or_value, "key-or-value"); DEFSYM (Qkey_and_value, "key-and-value"); - defsubr (&Ssxhash); + defsubr (&Ssxhash_eq); + defsubr (&Ssxhash_eql); + defsubr (&Ssxhash_equal); defsubr (&Smake_hash_table); defsubr (&Scopy_hash_table); defsubr (&Shash_table_count); @@ -5020,6 +5130,9 @@ syms_of_fns (void) doc: /* A list of symbols which are the features of the executing Emacs. Used by `featurep' and `require', and altered by `provide'. */); Vfeatures = list1 (Qemacs); + DEFSYM (Qfeatures, "features"); + /* Let people use lexically scoped vars named `features'. */ + Fmake_var_non_special (Qfeatures); DEFSYM (Qsubfeatures, "subfeatures"); DEFSYM (Qfuncall, "funcall"); @@ -5055,6 +5168,7 @@ this variable. */); defsubr (&Sstring_equal); defsubr (&Scompare_strings); defsubr (&Sstring_lessp); + defsubr (&Sstring_version_lessp); defsubr (&Sstring_collate_lessp); defsubr (&Sstring_collate_equalp); defsubr (&Sappend); @@ -5099,6 +5213,7 @@ this variable. */); defsubr (&Snconc); defsubr (&Smapcar); defsubr (&Smapc); + defsubr (&Smapcan); defsubr (&Smapconcat); defsubr (&Syes_or_no_p); defsubr (&Sload_average); @@ -5115,23 +5230,6 @@ this variable. */); defsubr (&Sbase64_decode_string); defsubr (&Smd5); defsubr (&Ssecure_hash); + defsubr (&Sbuffer_hash); defsubr (&Slocale_info); - - hashtest_eq.name = Qeq; - hashtest_eq.user_hash_function = Qnil; - hashtest_eq.user_cmp_function = Qnil; - hashtest_eq.cmpfn = 0; - hashtest_eq.hashfn = hashfn_eq; - - hashtest_eql.name = Qeql; - hashtest_eql.user_hash_function = Qnil; - hashtest_eql.user_cmp_function = Qnil; - hashtest_eql.cmpfn = cmpfn_eql; - hashtest_eql.hashfn = hashfn_eql; - - hashtest_equal.name = Qequal; - hashtest_equal.user_hash_function = Qnil; - hashtest_equal.user_cmp_function = Qnil; - hashtest_equal.cmpfn = cmpfn_equal; - hashtest_equal.hashfn = hashfn_equal; } diff --git a/src/font.c b/src/font.c index b85956f225c..36e71669453 100644 --- a/src/font.c +++ b/src/font.c @@ -23,6 +23,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <float.h> #include <stdio.h> +#include <stdlib.h> #include <c-ctype.h> @@ -131,7 +132,7 @@ static struct font_driver_list *font_driver_list; /* Used to catch bogus pointers in font objects. */ bool -valid_font_driver (struct font_driver *drv) +valid_font_driver (struct font_driver const *drv) { Lisp_Object tail, frame; struct font_driver_list *fdl; @@ -264,14 +265,13 @@ font_intern_prop (const char *str, ptrdiff_t len, bool force_symbol) break; if (i == len) { - EMACS_INT n; - i = 0; - for (n = 0; (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; n *= 10) + for (EMACS_INT n = 0; + (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; ) { if (i == len) return make_number (n); - if (MOST_POSITIVE_FIXNUM / 10 < n) + if (INT_MULTIPLY_WRAPV (n, 10, &n)) break; } @@ -1771,7 +1771,8 @@ font_parse_family_registry (Lisp_Object family, Lisp_Object registry, Lisp_Objec p1 = strchr (p0, '-'); if (! p1) { - AUTO_STRING (extra, (&"*-*"[len && p0[len - 1] == '*'])); + bool asterisk = len && p0[len - 1] == '*'; + AUTO_STRING_WITH_LEN (extra, &"*-*"[asterisk], 3 - asterisk); registry = concat2 (registry, extra); } registry = Fdowncase (registry); @@ -2233,7 +2234,8 @@ font_sort_entities (Lisp_Object list, Lisp_Object prefer, struct font_sort_data *data; unsigned best_score; Lisp_Object best_entity; - Lisp_Object tail, vec IF_LINT (= Qnil); + Lisp_Object tail; + Lisp_Object vec UNINIT; USE_SAFE_ALLOCA; for (i = FONT_WEIGHT_INDEX; i <= FONT_AVGWIDTH_INDEX; i++) @@ -2541,14 +2543,11 @@ font_match_p (Lisp_Object spec, Lisp_Object font) is a number frames sharing this cache, and FONT-CACHE-DATA is a cons (FONT-SPEC . [FONT-ENTITY ...]). */ -static void font_prepare_cache (struct frame *, struct font_driver *); -static void font_finish_cache (struct frame *, struct font_driver *); -static Lisp_Object font_get_cache (struct frame *, struct font_driver *); static void font_clear_cache (struct frame *, Lisp_Object, - struct font_driver *); + struct font_driver const *); static void -font_prepare_cache (struct frame *f, struct font_driver *driver) +font_prepare_cache (struct frame *f, struct font_driver const *driver) { Lisp_Object cache, val; @@ -2570,7 +2569,7 @@ font_prepare_cache (struct frame *f, struct font_driver *driver) static void -font_finish_cache (struct frame *f, struct font_driver *driver) +font_finish_cache (struct frame *f, struct font_driver const *driver) { Lisp_Object cache, val, tmp; @@ -2591,7 +2590,7 @@ font_finish_cache (struct frame *f, struct font_driver *driver) static Lisp_Object -font_get_cache (struct frame *f, struct font_driver *driver) +font_get_cache (struct frame *f, struct font_driver const *driver) { Lisp_Object val = driver->get_cache (f); Lisp_Object type = driver->type; @@ -2606,7 +2605,8 @@ font_get_cache (struct frame *f, struct font_driver *driver) static void -font_clear_cache (struct frame *f, Lisp_Object cache, struct font_driver *driver) +font_clear_cache (struct frame *f, Lisp_Object cache, + struct font_driver const *driver) { Lisp_Object tail, elt; Lisp_Object entity; @@ -2861,7 +2861,7 @@ font_open_entity (struct frame *f, Lisp_Object entity, int pixel_size) struct font_driver_list *driver_list; Lisp_Object objlist, size, val, font_object; struct font *font; - int min_width, height, psize; + int height, psize; eassert (FONT_ENTITY_P (entity)); size = AREF (entity, FONT_SIZE_INDEX); @@ -2905,10 +2905,12 @@ font_open_entity (struct frame *f, Lisp_Object entity, int pixel_size) Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX))); font = XFONT_OBJECT (font_object); - min_width = (font->min_width ? font->min_width - : font->average_width ? font->average_width - : font->space_width ? font->space_width - : 1); +#ifdef HAVE_WINDOW_SYSTEM + int min_width = (font->min_width ? font->min_width + : font->average_width ? font->average_width + : font->space_width ? font->space_width + : 1); +#endif int font_ascent, font_descent; get_font_ascent_descent (font, &font_ascent, &font_descent); @@ -3459,7 +3461,7 @@ font_open_by_name (struct frame *f, Lisp_Object name) (e.g. syms_of_xfont). */ void -register_font_driver (struct font_driver *driver, struct frame *f) +register_font_driver (struct font_driver const *driver, struct frame *f) { struct font_driver_list *root = f ? f->font_driver_list : font_driver_list; struct font_driver_list *prev, *list; @@ -3520,7 +3522,7 @@ font_update_drivers (struct frame *f, Lisp_Object new_drivers) drivers. */ for (list = f->font_driver_list; list; list = list->next) { - struct font_driver *driver = list->driver; + struct font_driver const *driver = list->driver; if ((EQ (new_drivers, Qt) || ! NILP (Fmemq (driver->type, new_drivers))) != list->on) { @@ -3583,7 +3585,7 @@ font_update_drivers (struct frame *f, Lisp_Object new_drivers) and then use it under w32 or ns. */ for (list = f->font_driver_list; list; list = list->next) { - struct font_driver *driver = list->driver; + struct font_driver const *driver = list->driver; eassert (! list->on); if (! driver->start_for_frame || driver->start_for_frame (f) == 0) @@ -5271,6 +5273,16 @@ font_deferred_log (const char *action, Lisp_Object arg, Lisp_Object result) } void +font_drop_xrender_surfaces (struct frame *f) +{ + struct font_driver_list *list; + + for (list = f->font_driver_list; list; list = list->next) + if (list->on && list->driver->drop_xrender_surfaces) + list->driver->drop_xrender_surfaces (f); +} + +void syms_of_font (void) { sort_shift_bits[FONT_TYPE_INDEX] = 0; @@ -5403,19 +5415,19 @@ Each element has the form: [NUMERIC-VALUE SYMBOLIC-NAME ALIAS-NAME ...] NUMERIC-VALUE is an integer, and SYMBOLIC-NAME and ALIAS-NAME are symbols. */); Vfont_weight_table = BUILD_STYLE_TABLE (weight_table); - XSYMBOL (intern_c_string ("font-weight-table"))->constant = 1; + make_symbol_constant (intern_c_string ("font-weight-table")); DEFVAR_LISP_NOPRO ("font-slant-table", Vfont_slant_table, doc: /* Vector of font slant symbols vs the corresponding numeric values. See `font-weight-table' for the format of the vector. */); Vfont_slant_table = BUILD_STYLE_TABLE (slant_table); - XSYMBOL (intern_c_string ("font-slant-table"))->constant = 1; + make_symbol_constant (intern_c_string ("font-slant-table")); DEFVAR_LISP_NOPRO ("font-width-table", Vfont_width_table, doc: /* Alist of font width symbols vs the corresponding numeric values. See `font-weight-table' for the format of the vector. */); Vfont_width_table = BUILD_STYLE_TABLE (width_table); - XSYMBOL (intern_c_string ("font-width-table"))->constant = 1; + make_symbol_constant (intern_c_string ("font-width-table")); staticpro (&font_style_table); font_style_table = make_uninit_vector (3); diff --git a/src/font.h b/src/font.h index cf477290d06..af0214c3f23 100644 --- a/src/font.h +++ b/src/font.h @@ -380,7 +380,7 @@ struct font #endif /* HAVE_WINDOW_SYSTEM */ /* Font-driver for the font. */ - struct font_driver *driver; + struct font_driver const *driver; /* There are more members in this structure, but they are private to the font-driver. */ @@ -763,6 +763,13 @@ struct font_driver Return non-nil if the driver support rendering of combining characters for FONT according to Unicode combining class. */ Lisp_Object (*combining_capability) (struct font *font); + + /* Optional + + Called when frame F is double-buffered and its size changes; Xft + relies on this hook to throw away its old XftDraw (which won't + work after the size change) and get a new one. */ + void (*drop_xrender_surfaces) (struct frame *f); }; @@ -776,7 +783,7 @@ struct font_driver_list font driver list.*/ bool on; /* Pointer to the font driver. */ - struct font_driver *driver; + struct font_driver const *driver; /* Pointer to the next element of the chain. */ struct font_driver_list *next; }; @@ -834,13 +841,13 @@ extern void font_parse_family_registry (Lisp_Object family, extern int font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font); extern ptrdiff_t font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int bytes); -extern void register_font_driver (struct font_driver *driver, struct frame *f); +extern void register_font_driver (struct font_driver const *, struct frame *); extern void free_font_driver_list (struct frame *f); #ifdef ENABLE_CHECKING -extern bool valid_font_driver (struct font_driver *); +extern bool valid_font_driver (struct font_driver const *); #else INLINE bool -valid_font_driver (struct font_driver *d) +valid_font_driver (struct font_driver const *d) { return true; } @@ -862,21 +869,42 @@ extern void *font_get_frame_data (struct frame *f, Lisp_Object); extern void font_filter_properties (Lisp_Object font, Lisp_Object alist, const char *const boolean_properties[], - const char *const non_boolean_properties[]); + const char *const non_boolean_properties[]); + +extern void font_drop_xrender_surfaces (struct frame *f); #ifdef HAVE_FREETYPE -extern struct font_driver ftfont_driver; +extern int ftfont_anchor_point (struct font *, unsigned int, int, + int *, int *); +extern int ftfont_get_bitmap (struct font *, unsigned int, + struct font_bitmap *, int); +extern int ftfont_has_char (Lisp_Object, int); +extern int ftfont_variation_glyphs (struct font *, int, unsigned[256]); +extern Lisp_Object ftfont_combining_capability (struct font *); +extern Lisp_Object ftfont_get_cache (struct frame *); +extern Lisp_Object ftfont_list (struct frame *, Lisp_Object); +extern Lisp_Object ftfont_list_family (struct frame *); +extern Lisp_Object ftfont_match (struct frame *, Lisp_Object); +extern Lisp_Object ftfont_open (struct frame *, Lisp_Object, int); +extern Lisp_Object ftfont_otf_capability (struct font *); +extern Lisp_Object ftfont_shape (Lisp_Object); +extern unsigned ftfont_encode_char (struct font *, int); +extern void ftfont_close (struct font *); +extern void ftfont_filter_properties (Lisp_Object, Lisp_Object); +extern void ftfont_text_extents (struct font *, unsigned *, int, + struct font_metrics *); extern void syms_of_ftfont (void); #endif /* HAVE_FREETYPE */ #ifdef HAVE_X_WINDOWS -extern struct font_driver xfont_driver; +extern struct font_driver const xfont_driver; +extern Lisp_Object xfont_get_cache (struct frame *); extern void syms_of_xfont (void); extern void syms_of_ftxfont (void); #ifdef HAVE_XFT -extern struct font_driver xftfont_driver; +extern struct font_driver const xftfont_driver; #endif #if defined HAVE_FREETYPE || defined HAVE_XFT -extern struct font_driver ftxfont_driver; +extern struct font_driver const ftxfont_driver; extern void syms_of_xftfont (void); #endif #ifdef HAVE_BDFFONT @@ -889,12 +917,12 @@ extern struct font_driver uniscribe_font_driver; extern void syms_of_w32font (void); #endif /* HAVE_NTGUI */ #ifdef HAVE_NS -extern struct font_driver nsfont_driver; +extern struct font_driver const nsfont_driver; extern void syms_of_nsfont (void); extern void syms_of_macfont (void); #endif /* HAVE_NS */ #ifdef USE_CAIRO -extern struct font_driver ftcrfont_driver; +extern struct font_driver const ftcrfont_driver; extern void syms_of_ftcrfont (void); #endif diff --git a/src/fontset.c b/src/fontset.c index 74e7df5ae09..38ff780ccba 100644 --- a/src/fontset.c +++ b/src/fontset.c @@ -26,6 +26,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include "lisp.h" #include "blockinput.h" @@ -63,17 +64,26 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ An element of a base fontset is a vector of FONT-DEFs which themselves are vectors of the form [ FONT-SPEC ENCODING REPERTORY ]. - An element of a realized fontset is nil, t, 0, or a vector of this - form: + An element of a realized fontset is nil, t, 0, or a cons that has + this from: - [ PREFERRED-RFONT-DEF RFONT-DEF0 RFONT-DEF1 ... ] + (CHARSET-ORDERED-LIST-TICK . FONT-GROUP) + + CHARSET_ORDERED_LIST_TICK is the same as charset_ordered_list_tick or -1. + + FONT-GROUP is a vector of elements that have this form: + + [ RFONT-DEF0 RFONT-DEF1 ... ] Each RFONT-DEFn (i.e. Realized FONT-DEF) has this form: [ FACE-ID FONT-DEF FONT-OBJECT SORTING-SCORE ] - RFONT-DEFn are automatically reordered by the current charset - priority list. + RFONT-DEFn are automatically reordered considering the current + charset priority list, the current language environment, and + priorities determined by font-backends. + + RFONT-DEFn may not be a vector in the following cases. The value nil means that we have not yet generated the above vector from the base of the fontset. @@ -83,7 +93,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ The value 0 means that no font is available for the corresponding range of characters in this fontset, but may be available in the - default fontset. + fallback font-group or in the default fontset. A fontset has 8 extra slots. @@ -407,6 +417,9 @@ reorder_font_vector (Lisp_Object font_group, struct font *font) if (! NILP (encoding)) { + /* This spec specifies an encoding by a charset set + name. Reflect the preference order of that charset + in the upper bits of SCORE. */ Lisp_Object tail; for (tail = Vcharset_ordered_list; @@ -419,6 +432,10 @@ reorder_font_vector (Lisp_Object font_group, struct font *font) } else { + /* This spec does not specify an encoding. If the spec + specifies a language, and the language is not for the + current language environment, make the score + larger. */ Lisp_Object lang = Ffont_get (font_spec, QClang); if (! NILP (lang) @@ -442,11 +459,11 @@ reorder_font_vector (Lisp_Object font_group, struct font *font) XSETCAR (font_group, make_number (low_tick_bits)); } -/* Return a font-group (actually a cons (-1 . FONT-GROUP-VECTOR)) for - character C in FONTSET. If C is -1, return a fallback font-group. - If C is not -1, the value may be Qt (FONTSET doesn't have a font - for C even in the fallback group), or 0 (a font for C may be found - only in the fallback group). */ +/* Return a font-group (actually a cons (CHARSET_ORDERED_LIST_TICK + . FONT-GROUP)) for character C or a fallback font-group in the + realized fontset FONTSET. The elements of FONT-GROUP are + RFONT-DEFs. The value may not be a cons. See the comment at the + head of this file for the detail of the return value. */ static Lisp_Object fontset_get_font_group (Lisp_Object fontset, int c) @@ -461,23 +478,37 @@ fontset_get_font_group (Lisp_Object fontset, int c) else font_group = FONTSET_FALLBACK (fontset); if (! NILP (font_group)) + /* We have already realized FONT-DEFs of this font group for C or + for fallback (FONT_GROUP is a cons), or we have already found + that no appropriate font was found (FONT_GROUP is t or 0). */ return font_group; base_fontset = FONTSET_BASE (fontset); if (NILP (base_fontset)) + /* Actually we never come here because FONTSET is a realized one, + and thus it should have a base. */ font_group = Qnil; else if (c >= 0) font_group = char_table_ref_and_range (base_fontset, c, &from, &to); else font_group = FONTSET_FALLBACK (base_fontset); + + /* FONT_GROUP not being a vector means that no fonts are specified + for C, or the fontset does not have fallback fonts. */ if (NILP (font_group)) { font_group = make_number (0); if (c >= 0) + /* Record that FONTSET does not specify fonts for C. As + there's a possibility that a font is found in a fallback + font group, we set 0 at the moment. */ char_table_set_range (fontset, from, to, font_group); return font_group; } if (!VECTORP (font_group)) return font_group; + + /* Now realize FONT-DEFs of this font group, and update the realized + fontset FONTSET. */ font_group = Fcopy_sequence (font_group); for (i = 0; i < ASIZE (font_group); i++) if (! NILP (AREF (font_group, i))) @@ -498,21 +529,21 @@ fontset_get_font_group (Lisp_Object fontset, int c) } /* Return RFONT-DEF (vector) in the realized fontset FONTSET for the - character C. If no font is found, return Qnil if there's a + character C. If no font is found, return Qnil or 0 if there's a possibility that the default fontset or the fallback font groups have a proper font, and return Qt if not. If a font is found but is not yet opened, open it (if FACE is not NULL) or return Qnil (if FACE is NULL). - ID is a charset-id that must be preferred, or -1 meaning no + CHARSET_ID is a charset-id that must be preferred, or -1 meaning no preference. If FALLBACK, search only fallback fonts. */ static Lisp_Object -fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, - bool fallback) +fontset_find_font (Lisp_Object fontset, int c, struct face *face, + int charset_id, bool fallback) { Lisp_Object vec, font_group; int i, charset_matched = 0, found_index; @@ -534,8 +565,8 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, /* We have just created the font-group, or the charset priorities were changed. */ reorder_font_vector (font_group, face->ascii_face->font); - if (id >= 0) - /* Find a spec matching with the charset ID to try at + if (charset_id >= 0) + /* Find a spec matching with CHARSET_ID to try it at first. */ for (i = 0; i < ASIZE (vec); i++) { @@ -546,7 +577,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, break; repertory = FONT_DEF_REPERTORY (RFONT_DEF_FONT_DEF (rfont_def)); - if (XINT (repertory) == id) + if (XINT (repertory) == charset_id) { charset_matched = i; break; @@ -554,7 +585,9 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, } } - /* Find the first available font in the vector of RFONT-DEF. */ + /* Find the first available font in the vector of RFONT-DEF. If + CHARSET_MATCHED > 0, try the corresponding RFONT-DEF first, then + try the rest. */ for (i = 0; i < ASIZE (vec); i++) { Lisp_Object font_def; @@ -565,13 +598,13 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, { if (charset_matched > 0) { - /* Try the element matching with the charset ID at first. */ + /* Try the element matching with CHARSET_ID at first. */ found_index = charset_matched; /* Make this negative so that we don't come here in the next loop. */ charset_matched = - charset_matched; /* We must try the first element in the next loop. */ - i--; + i = -1; } } else if (i == - charset_matched) @@ -630,10 +663,10 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, if (NILP (font_object)) { /* Something strange happened, perhaps because of a - Font-backend problem. Too avoid crashing, record + Font-backend problem. To avoid crashing, record that this spec is unusable. It may be better to find another font of the same spec, but currently we don't - have such an API. */ + have such an API in font-backend. */ RFONT_DEF_SET_FACE (rfont_def, -1); continue; } @@ -693,6 +726,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, i = found_index; } + /* Record that no font in this font group supports C. */ FONTSET_SET (fontset, make_number (c), make_number (0)); return Qnil; @@ -711,10 +745,14 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, int id, } +/* Return RFONT-DEF (vector) corresponding to the font for character + C. The value is not a vector if no font is found for C. */ + static Lisp_Object fontset_font (Lisp_Object fontset, int c, struct face *face, int id) { - Lisp_Object rfont_def, default_rfont_def IF_LINT (= Qnil); + Lisp_Object rfont_def; + Lisp_Object default_rfont_def UNINIT; Lisp_Object base_fontset; /* Try a font-group of FONTSET. */ @@ -1269,7 +1307,7 @@ free_realized_fontsets (Lisp_Object base) { struct frame *f = XFRAME (FONTSET_FRAME (this)); int face_id = XINT (XCDR (XCAR (tail))); - struct face *face = FACE_FROM_ID (f, face_id); + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); /* Face THIS itself is also freed by the following call. */ free_realized_face (f, face); @@ -1601,7 +1639,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */) continue; if (fontset_id != FRAME_FONTSET (f)) continue; - face = FACE_FROM_ID (f, DEFAULT_FACE_ID); + face = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); if (face) font_object = font_load_for_lface (f, face->lface, font_spec); else diff --git a/src/frame.c b/src/frame.c index 854f72e64b4..70ae309fe20 100644 --- a/src/frame.c +++ b/src/frame.c @@ -20,6 +20,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include <errno.h> #include <limits.h> @@ -106,31 +107,32 @@ decode_any_frame (register Lisp_Object frame) } #ifdef HAVE_WINDOW_SYSTEM - bool -window_system_available (struct frame *f) +display_available (void) { - return f ? FRAME_WINDOW_P (f) || FRAME_MSDOS_P (f) : x_display_list != NULL; + return x_display_list != NULL; } - -#endif /* HAVE_WINDOW_SYSTEM */ +#endif struct frame * decode_window_system_frame (Lisp_Object frame) { struct frame *f = decode_live_frame (frame); - - if (!window_system_available (f)) - error ("Window system frame should be used"); + check_window_system (f); +#ifdef HAVE_WINDOW_SYSTEM return f; +#endif } void check_window_system (struct frame *f) { - if (!window_system_available (f)) - error (f ? "Window system frame should be used" - : "Window system is not in use or not initialized"); +#ifdef HAVE_WINDOW_SYSTEM + if (window_system_available (f)) + return; +#endif + error (f ? "Window system frame should be used" + : "Window system is not in use or not initialized"); } /* Return the value of frame parameter PROP in frame FRAME. */ @@ -500,8 +502,8 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit, && new_lines == old_lines) /* No change. Sanitize window sizes and return. */ { - sanitize_window_sizes (frame, Qt); - sanitize_window_sizes (frame, Qnil); + sanitize_window_sizes (Qt); + sanitize_window_sizes (Qnil); return; } @@ -537,7 +539,7 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit, #endif } else if (new_cols != old_cols) - call2 (Qwindow_pixel_to_total, frame, Qt); + call2 (Qwindow__pixel_to_total, frame, Qt); if (new_windows_height != old_windows_height /* When the top margin has changed we have to recalculate the top @@ -553,7 +555,7 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit, FrameRows (FRAME_TTY (f)) = new_lines + FRAME_TOP_MARGIN (f); } else if (new_lines != old_lines) - call2 (Qwindow_pixel_to_total, frame, Qnil); + call2 (Qwindow__pixel_to_total, frame, Qnil); frame_size_history_add (f, Qadjust_frame_size_3, new_text_width, new_text_height, @@ -581,8 +583,8 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit, } /* Sanitize window sizes. */ - sanitize_window_sizes (frame, Qt); - sanitize_window_sizes (frame, Qnil); + sanitize_window_sizes (Qt); + sanitize_window_sizes (Qnil); adjust_frame_glyphs (f); calculate_costs (f); @@ -594,8 +596,6 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit, || new_pixel_height != old_pixel_height); unblock_input (); - - run_window_configuration_change_hook (f); } /* Allocate basically initialized frame. */ @@ -611,7 +611,7 @@ make_frame (bool mini_p) { Lisp_Object frame; struct frame *f; - struct window *rw, *mw IF_LINT (= NULL); + struct window *rw, *mw UNINIT; Lisp_Object root_window; Lisp_Object mini_window; @@ -659,6 +659,7 @@ make_frame (bool mini_p) mw->mini = 1; wset_frame (mw, frame); fset_minibuffer_window (f, mini_window); + store_frame_param (f, Qminibuffer, Qt); } else { @@ -771,6 +772,7 @@ make_frame_without_minibuffer (Lisp_Object mini_window, KBOARD *kb, } fset_minibuffer_window (f, mini_window); + store_frame_param (f, Qminibuffer, mini_window); /* Make the chosen minibuffer window display the proper minibuffer, unless it is already showing a minibuffer. */ @@ -808,6 +810,7 @@ make_minibuffer_frame (void) mini_window = f->root_window; fset_minibuffer_window (f, mini_window); + store_frame_param (f, Qminibuffer, Qonly); XWINDOW (mini_window)->mini = 1; wset_next (XWINDOW (mini_window), Qnil); wset_prev (XWINDOW (mini_window), Qnil); @@ -1064,6 +1067,10 @@ affects all frames on the same terminal device. */) (t->display_info.tty->name ? build_string (t->display_info.tty->name) : Qnil)); + /* On terminal frames the `minibuffer' frame parameter is always + virtually t. Avoid that a different value in parms causes + complaints, see Bug#24758. */ + store_in_alist (&parms, Qminibuffer, Qt); Fmodify_frame_parameters (frame, parms); /* Make the frame face alist be frame-specific, so that each @@ -1157,7 +1164,12 @@ do_switch_frame (Lisp_Object frame, int track, int for_deletion, Lisp_Object nor if (FRAMEP (xfocus)) { focus = FRAME_FOCUS_FRAME (XFRAME (xfocus)); - if (FRAMEP (focus) && XFRAME (focus) == SELECTED_FRAME ()) + if ((FRAMEP (focus) && XFRAME (focus) == SELECTED_FRAME ()) + /* Redirect frame focus also when FRAME has its minibuffer + window on the selected frame (see Bug#24500). */ + || (NILP (focus) + && EQ (FRAME_MINIBUF_WINDOW (XFRAME (frame)), + sf->selected_window))) Fredirect_frame_focus (xfocus, frame); } } @@ -1824,7 +1836,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force) DEFUN ("delete-frame", Fdelete_frame, Sdelete_frame, 0, 2, "", doc: /* Delete FRAME, permanently eliminating it from use. -FRAME defaults to the selected frame. +FRAME must be a live frame and defaults to the selected one. A frame may not be deleted if its minibuffer serves as surrogate minibuffer for another frame. Normally, you may not delete a frame if @@ -2137,10 +2149,12 @@ If omitted, FRAME defaults to the currently selected frame. */) check_minibuf_window (frame, EQ (minibuf_window, selected_window)); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (f)) + { +#ifdef HAVE_WINDOW_SYSTEM x_iconify_frame (f); #endif + } /* Make menu bar update for the Buffers and Frames menus. */ windows_or_buffers_changed = 17; @@ -2403,6 +2417,46 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val) { register Lisp_Object old_alist_elt; + if (EQ (prop, Qminibuffer)) + { + if (WINDOWP (val)) + { + if (!MINI_WINDOW_P (XWINDOW (val))) + error ("The `minibuffer' parameter does not specify a valid minibuffer window"); + else if (FRAME_MINIBUF_ONLY_P (f)) + { + if (EQ (val, FRAME_MINIBUF_WINDOW (f))) + val = Qonly; + else + error ("Can't change the minibuffer window of a minibuffer-only frame"); + } + else if (FRAME_HAS_MINIBUF_P (f)) + { + if (EQ (val, FRAME_MINIBUF_WINDOW (f))) + val = Qt; + else + error ("Can't change the minibuffer window of a frame with its own minibuffer"); + } + else + /* Store the chosen minibuffer window. */ + fset_minibuffer_window (f, val); + } + else + { + Lisp_Object old_val = Fcdr (Fassq (Qminibuffer, f->param_alist)); + + if (!NILP (old_val)) + { + if (WINDOWP (old_val) && NILP (val)) + /* Don't change the value for a minibuffer-less frame if + only nil was specified as new value. */ + val = old_val; + else if (!EQ (old_val, val)) + error ("Can't change the `minibuffer' parameter of this frame"); + } + } + } + /* The buffer-list parameters are stored in a special place and not in the alist. All buffers must be live. */ if (EQ (prop, Qbuffer_list)) @@ -2424,28 +2478,6 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val) return; } - /* If PROP is a symbol which is supposed to have frame-local values, - and it is set up based on this frame, switch to the global - binding. That way, we can create or alter the frame-local binding - without messing up the symbol's status. */ - if (SYMBOLP (prop)) - { - struct Lisp_Symbol *sym = XSYMBOL (prop); - start: - switch (sym->redirect) - { - case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; - case SYMBOL_PLAINVAL: case SYMBOL_FORWARDED: break; - case SYMBOL_LOCALIZED: - { struct Lisp_Buffer_Local_Value *blv = sym->val.blv; - if (blv->frame_local && blv_found (blv) && XFRAME (blv->where) == f) - swap_in_global_binding (sym); - break; - } - default: emacs_abort (); - } - } - /* The tty color needed to be set before the frame's parameter alist was updated with the new value. This is not true any more, but we still do this test early on. */ @@ -2474,19 +2506,6 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val) else if (EQ (prop, Qname)) set_term_frame_name (f, val); } - - if (EQ (prop, Qminibuffer) && WINDOWP (val)) - { - if (! MINI_WINDOW_P (XWINDOW (val))) - error ("Surrogate minibuffer windows must be minibuffer windows"); - - if ((FRAME_HAS_MINIBUF_P (f) || FRAME_MINIBUF_ONLY_P (f)) - && !EQ (val, f->minibuffer_window)) - error ("Can't change the surrogate minibuffer of a frame with its own minibuffer"); - - /* Install the chosen minibuffer window, with proper buffer. */ - fset_minibuffer_window (f, val); - } } /* Return color matches UNSPEC on frame F or nil if UNSPEC @@ -2564,10 +2583,6 @@ If FRAME is omitted or nil, return information on the currently selected frame. : FRAME_COLS (f)); store_in_alist (&alist, Qwidth, make_number (width)); store_in_alist (&alist, Qmodeline, (FRAME_WANTS_MODELINE_P (f) ? Qt : Qnil)); - store_in_alist (&alist, Qminibuffer, - (! FRAME_HAS_MINIBUF_P (f) ? Qnil - : FRAME_MINIBUF_ONLY_P (f) ? Qonly - : FRAME_MINIBUF_WINDOW (f))); store_in_alist (&alist, Qunsplittable, (FRAME_NO_SPLIT_P (f) ? Qt : Qnil)); store_in_alist (&alist, Qbuffer_list, f->buffer_list); store_in_alist (&alist, Qburied_buffer_list, f->buried_buffer_list); @@ -2606,6 +2621,22 @@ If FRAME is nil, describe the currently selected frame. */) /* Avoid consing in frequent cases. */ if (EQ (parameter, Qname)) value = f->name; +#ifdef HAVE_WINDOW_SYSTEM + /* These are used by vertical motion commands. */ + else if (EQ (parameter, Qvertical_scroll_bars)) + value = (f->vertical_scroll_bar_type == vertical_scroll_bar_none + ? Qnil + : (f->vertical_scroll_bar_type == vertical_scroll_bar_left + ? Qleft : Qright)); + else if (EQ (parameter, Qhorizontal_scroll_bars)) + value = f->horizontal_scroll_bars ? Qt : Qnil; + else if (EQ (parameter, Qline_spacing) && f->extra_line_spacing == 0) + /* If this is non-zero, we can't determine whether the user specified + an integer or float value without looking through 'param_alist'. */ + value = make_number (0); + else if (EQ (parameter, Qfont) && FRAME_X_P (f)) + value = FRAME_FONT (f)->props[FONT_NAME_INDEX]; +#endif /* HAVE_WINDOW_SYSTEM */ #ifdef HAVE_X_WINDOWS else if (EQ (parameter, Qdisplay) && FRAME_X_P (f)) value = XCAR (FRAME_DISPLAY_INFO (f)->name_list_element); @@ -2656,13 +2687,7 @@ The meaningful parameters are acted upon, i.e. the frame is changed according to their new values, and are also stored in the frame's parameter list so that `frame-parameters' will return them. PARMs that are not meaningful are still stored in the frame's parameter -list, but are otherwise ignored. - -The value of frame parameter FOO can also be accessed -as a frame-local binding for the variable FOO, if you have -enabled such bindings for that variable with `make-variable-frame-local'. -Note that this functionality is obsolete as of Emacs 22.2, and its -use is not recommended. Explicitly check for a frame-parameter instead. */) +list, but are otherwise ignored. */) (Lisp_Object frame, Lisp_Object alist) { struct frame *f = decode_live_frame (frame); @@ -3003,16 +3028,18 @@ or bottom edge of the outer frame of FRAME relative to the right or bottom edge of FRAME's display. */) (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { - register struct frame *f = decode_live_frame (frame); + struct frame *f = decode_live_frame (frame); CHECK_TYPE_RANGED_INTEGER (int, x); CHECK_TYPE_RANGED_INTEGER (int, y); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (f)) - x_set_offset (f, XINT (x), XINT (y), 1); + { +#ifdef HAVE_WINDOW_SYSTEM + x_set_offset (f, XINT (x), XINT (y), 1); #endif + } return Qt; } @@ -3073,6 +3100,7 @@ static const struct frame_parm_table frame_parms[] = {"alpha", SYMBOL_INDEX (Qalpha)}, {"sticky", SYMBOL_INDEX (Qsticky)}, {"tool-bar-position", SYMBOL_INDEX (Qtool_bar_position)}, + {"inhibit-double-buffering", SYMBOL_INDEX (Qinhibit_double_buffering)}, }; #ifdef HAVE_WINDOW_SYSTEM @@ -3091,8 +3119,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) /* If both of these parameters are present, it's more efficient to set them both at once. So we wait until we've looked at the entire list before we set them. */ - int width IF_LINT (= 0), height IF_LINT (= 0); - bool width_change = false, height_change = false; + int width = -1, height = -1; /* -1 denotes they were not changed. */ /* Same here. */ Lisp_Object left, top; @@ -3107,70 +3134,58 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) /* Record in these vectors all the parms specified. */ Lisp_Object *parms; Lisp_Object *values; - ptrdiff_t i, p; + ptrdiff_t i, j, size; bool left_no_change = 0, top_no_change = 0; #ifdef HAVE_X_WINDOWS bool icon_left_no_change = 0, icon_top_no_change = 0; #endif - i = 0; - for (tail = alist; CONSP (tail); tail = XCDR (tail)) - i++; + for (size = 0, tail = alist; CONSP (tail); tail = XCDR (tail)) + size++; USE_SAFE_ALLOCA; - SAFE_ALLOCA_LISP (parms, 2 * i); - values = parms + i; + SAFE_ALLOCA_LISP (parms, 2 * size); + values = parms + size; /* Extract parm names and values into those vectors. */ - i = 0; + i = 0, j = size - 1; for (tail = alist; CONSP (tail); tail = XCDR (tail)) { - Lisp_Object elt; - - elt = XCAR (tail); - parms[i] = Fcar (elt); - values[i] = Fcdr (elt); - i++; - } - /* TAIL and ALIST are not used again below here. */ - alist = tail = Qnil; + Lisp_Object elt = XCAR (tail), prop = Fcar (elt), val = Fcdr (elt); - top = left = Qunbound; - icon_left = icon_top = Qunbound; - - /* Process foreground_color and background_color before anything else. - They are independent of other properties, but other properties (e.g., - cursor_color) are dependent upon them. */ - /* Process default font as well, since fringe widths depends on it. */ - for (p = 0; p < i; p++) - { - Lisp_Object prop, val; + /* Some properties are independent of other properties, but other + properties are dependent upon them. These special properties + are foreground_color, background_color (affects cursor_color) + and font (affects fringe widths); they're recorded starting + from the end of PARMS and VALUES to process them first by using + reverse iteration. */ - prop = parms[p]; - val = values[p]; if (EQ (prop, Qforeground_color) || EQ (prop, Qbackground_color) || EQ (prop, Qfont)) { - register Lisp_Object param_index, old_value; - - old_value = get_frame_param (f, prop); - if (NILP (Fequal (val, old_value))) - { - store_frame_param (f, prop, val); - - param_index = Fget (prop, Qx_frame_parameter); - if (NATNUMP (param_index) - && XFASTINT (param_index) < ARRAYELTS (frame_parms) - && FRAME_RIF (f)->frame_parm_handlers[XINT (param_index)]) - (*(FRAME_RIF (f)->frame_parm_handlers[XINT (param_index)])) (f, val, old_value); - } + parms[j] = prop; + values[j] = val; + j--; + } + else + { + parms[i] = prop; + values[i] = val; + i++; } } - /* Now process them in reverse of specified order. */ - while (i-- != 0) + /* TAIL and ALIST are not used again below here. */ + alist = tail = Qnil; + + top = left = Qunbound; + icon_left = icon_top = Qunbound; + + /* Reverse order is used to make sure that special + properties noticed above are processed first. */ + for (i = size - 1; i >= 0; i--) { Lisp_Object prop, val; @@ -3180,30 +3195,18 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) if (EQ (prop, Qwidth)) { if (RANGED_INTEGERP (0, val, INT_MAX)) - { - width = XFASTINT (val) * FRAME_COLUMN_WIDTH (f) ; - width_change = true; - } + width = XFASTINT (val) * FRAME_COLUMN_WIDTH (f) ; else if (CONSP (val) && EQ (XCAR (val), Qtext_pixels) && RANGED_INTEGERP (0, XCDR (val), INT_MAX)) - { - width = XFASTINT (XCDR (val)); - width_change = true; - } + width = XFASTINT (XCDR (val)); } else if (EQ (prop, Qheight)) { if (RANGED_INTEGERP (0, val, INT_MAX)) - { - height = XFASTINT (val) * FRAME_LINE_HEIGHT (f); - height_change = true; - } + height = XFASTINT (val) * FRAME_LINE_HEIGHT (f); else if (CONSP (val) && EQ (XCAR (val), Qtext_pixels) && RANGED_INTEGERP (0, XCDR (val), INT_MAX)) - { - height = XFASTINT (XCDR (val)); - height_change = true; - } + height = XFASTINT (XCDR (val)); } else if (EQ (prop, Qtop)) top = val; @@ -3218,11 +3221,6 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) fullscreen = val; fullscreen_change = true; } - else if (EQ (prop, Qforeground_color) - || EQ (prop, Qbackground_color) - || EQ (prop, Qfont)) - /* Processed above. */ - continue; else { register Lisp_Object param_index, old_value; @@ -3290,16 +3288,15 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) XSETFRAME (frame, f); - if ((width_change && width != FRAME_TEXT_WIDTH (f)) - || (height_change && height != FRAME_TEXT_HEIGHT (f))) + if ((width != -1 && width != FRAME_TEXT_WIDTH (f)) + || (height != -1 && height != FRAME_TEXT_HEIGHT (f))) /* We could consider checking f->after_make_frame here, but I don't have the faintest idea why the following is needed at all. With the old setting it can get a Heisenbug when EmacsFrameResize intermittently provokes a delayed change_frame_size in the middle of adjust_frame_size. */ /** || (f->can_x_set_window_size && (f->new_height || f->new_width))) **/ - adjust_frame_size (f, width_change ? width : -1, - height_change ? height : -1, 1, 0, Qx_set_frame_parameters); + adjust_frame_size (f, width, height, 1, 0, Qx_set_frame_parameters); if ((!NILP (left) || !NILP (top)) && ! (left_no_change && top_no_change) @@ -3646,7 +3643,7 @@ x_set_font (struct frame *f, Lisp_Object arg, Lisp_Object oldval) x_new_font (f, font_object, fontset); store_frame_param (f, Qfont, arg); #ifdef HAVE_X_WINDOWS - store_frame_param (f, Qfont_param, font_param); + store_frame_param (f, Qfont_parameter, font_param); #endif /* Recalculate toolbar height. */ f->n_tool_bar_rows = 0; @@ -3741,8 +3738,8 @@ x_set_left_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_value if (new_width != old_width) { - FRAME_LEFT_FRINGE_WIDTH (f) = new_width; - FRAME_FRINGE_COLS (f) /* Round up. */ + f->left_fringe_width = new_width; + f->fringe_cols /* Round up. */ = (new_width + FRAME_RIGHT_FRINGE_WIDTH (f) + unit - 1) / unit; if (FRAME_X_WINDOW (f) != 0) @@ -3765,8 +3762,8 @@ x_set_right_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu if (new_width != old_width) { - FRAME_RIGHT_FRINGE_WIDTH (f) = new_width; - FRAME_FRINGE_COLS (f) /* Round up. */ + f->right_fringe_width = new_width; + f->fringe_cols /* Round up. */ = (new_width + FRAME_LEFT_FRINGE_WIDTH (f) + unit - 1) / unit; if (FRAME_X_WINDOW (f) != 0) @@ -3795,13 +3792,11 @@ void x_set_right_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old = FRAME_RIGHT_DIVIDER_WIDTH (f); - CHECK_TYPE_RANGED_INTEGER (int, arg); - FRAME_RIGHT_DIVIDER_WIDTH (f) = XINT (arg); - if (FRAME_RIGHT_DIVIDER_WIDTH (f) < 0) - FRAME_RIGHT_DIVIDER_WIDTH (f) = 0; - if (FRAME_RIGHT_DIVIDER_WIDTH (f) != old) + int new = max (0, XINT (arg)); + if (new != old) { + f->right_divider_width = new; adjust_frame_size (f, -1, -1, 4, 0, Qright_divider_width); adjust_frame_glyphs (f); SET_FRAME_GARBAGED (f); @@ -3813,13 +3808,11 @@ void x_set_bottom_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old = FRAME_BOTTOM_DIVIDER_WIDTH (f); - CHECK_TYPE_RANGED_INTEGER (int, arg); - FRAME_BOTTOM_DIVIDER_WIDTH (f) = XINT (arg); - if (FRAME_BOTTOM_DIVIDER_WIDTH (f) < 0) - FRAME_BOTTOM_DIVIDER_WIDTH (f) = 0; - if (FRAME_BOTTOM_DIVIDER_WIDTH (f) != old) + int new = max (0, XINT (arg)); + if (new != old) { + f->bottom_divider_width = new; adjust_frame_size (f, -1, -1, 4, 0, Qbottom_divider_width); adjust_frame_glyphs (f); SET_FRAME_GARBAGED (f); @@ -4423,8 +4416,8 @@ XParseGeometry (char *string, { int mask = NoValue; char *strind; - unsigned long tempWidth, tempHeight; - long int tempX, tempY; + unsigned long tempWidth UNINIT, tempHeight UNINIT; + long int tempX UNINIT, tempY UNINIT; char *nextCharacter; if (string == NULL || *string == '\0') @@ -4889,7 +4882,7 @@ syms_of_frame (void) DEFSYM (Qframep, "framep"); DEFSYM (Qframe_live_p, "frame-live-p"); DEFSYM (Qframe_windows_min_size, "frame-windows-min-size"); - DEFSYM (Qwindow_pixel_to_total, "window--pixel-to-total"); + DEFSYM (Qwindow__pixel_to_total, "window--pixel-to-total"); DEFSYM (Qexplicit_name, "explicit-name"); DEFSYM (Qheight, "height"); DEFSYM (Qicon, "icon"); @@ -5024,6 +5017,7 @@ syms_of_frame (void) DEFSYM (Qvertical_scroll_bars, "vertical-scroll-bars"); DEFSYM (Qvisibility, "visibility"); DEFSYM (Qwait_for_wm, "wait-for-wm"); + DEFSYM (Qinhibit_double_buffering, "inhibit-double-buffering"); { int i; @@ -5267,6 +5261,21 @@ The function `frame--size-history' displays the value of this variable in a more readable form. */); frame_size_history = Qnil; + DEFVAR_BOOL ("tooltip-reuse-hidden-frame", tooltip_reuse_hidden_frame, + doc: /* Non-nil means reuse hidden tooltip frames. +When this is nil, delete a tooltip frame when hiding the associated +tooltip. When this is non-nil, make the tooltip frame invisible only, +so it can be reused when the next tooltip is shown. + +Setting this to non-nil may drastically reduce the consing overhead +incurred by creating new tooltip frames. However, a value of non-nil +means also that intermittent changes of faces or `default-frame-alist' +are not applied when showing a tooltip in a reused frame. + +This variable is effective only with the X toolkit (and there only when +Gtk+ tooltips are not used) and on Windows. */); + tooltip_reuse_hidden_frame = false; + staticpro (&Vframe_list); defsubr (&Sframep); diff --git a/src/frame.h b/src/frame.h index f0cdcd42096..5e3ee68942a 100644 --- a/src/frame.h +++ b/src/frame.h @@ -288,8 +288,9 @@ struct frame cleared. */ bool_bf explicit_name : 1; - /* True if size of some window on this frame has changed. */ - bool_bf window_sizes_changed : 1; + /* True if configuration of windows on this frame has changed since + last call of run_window_size_change_functions. */ + bool_bf window_configuration_changed : 1; /* True if the mouse has moved on this display device since the last time we checked. */ @@ -828,10 +829,10 @@ default_pixels_per_inch_y (void) are frozen on frame F. */ #define FRAME_WINDOWS_FROZEN(f) (f)->frozen_window_starts -/* True if a size change has been requested for frame F - but not yet really put into effect. This can be true temporarily - when an X event comes in at a bad time. */ -#define FRAME_WINDOW_SIZES_CHANGED(f) (f)->window_sizes_changed +/* True if the frame's window configuration has changed since last call + of run_window_size_change_functions. */ +#define FRAME_WINDOW_CONFIGURATION_CHANGED(f) \ + (f)->window_configuration_changed /* The minibuffer window of frame F, if it has one; otherwise nil. */ #define FRAME_MINIBUF_WINDOW(f) f->minibuffer_window @@ -1101,7 +1102,14 @@ extern Lisp_Object selected_frame; extern int frame_default_tool_bar_height; #endif -extern struct frame *decode_window_system_frame (Lisp_Object); +#ifdef HAVE_WINDOW_SYSTEM +# define WINDOW_SYSTEM_RETURN +#else +# define WINDOW_SYSTEM_RETURN _Noreturn +#endif + +extern WINDOW_SYSTEM_RETURN struct frame * + decode_window_system_frame (Lisp_Object); extern struct frame *decode_live_frame (Lisp_Object); extern struct frame *decode_any_frame (Lisp_Object); extern struct frame *make_initial_frame (void); @@ -1111,11 +1119,20 @@ extern struct frame *make_minibuffer_frame (void); extern struct frame *make_frame_without_minibuffer (Lisp_Object, struct kboard *, Lisp_Object); -extern bool window_system_available (struct frame *); -#else /* not HAVE_WINDOW_SYSTEM */ -#define window_system_available(f) ((void) (f), false) -#endif /* HAVE_WINDOW_SYSTEM */ -extern void check_window_system (struct frame *); +extern bool display_available (void); +#endif + +INLINE bool +window_system_available (struct frame *f) +{ +#ifdef HAVE_WINDOW_SYSTEM + return f ? FRAME_WINDOW_P (f) || FRAME_MSDOS_P (f) : display_available (); +#else + return false; +#endif +} + +extern WINDOW_SYSTEM_RETURN void check_window_system (struct frame *); extern void frame_make_pointer_invisible (struct frame *); extern void frame_make_pointer_visible (struct frame *); extern Lisp_Object delete_frame (Lisp_Object, Lisp_Object); @@ -1149,46 +1166,68 @@ extern Lisp_Object Vframe_list; This value currently equals the average width of the default font of F. */ #define FRAME_COLUMN_WIDTH(F) ((F)->column_width) -/* Pixel width of areas used to display truncation marks, continuation - marks, overlay arrows. This is 0 for terminal frames. */ +/* Get a frame's window system dimension. If no window system, this is 0. */ +INLINE int +frame_dimension (int x) +{ #ifdef HAVE_WINDOW_SYSTEM + return x; +#else + return 0; +#endif +} /* Total width of fringes reserved for drawing truncation bitmaps, continuation bitmaps and alike. The width is in canonical char units of the frame. This must currently be the case because window sizes aren't pixel values. If it weren't the case, we wouldn't be able to split windows horizontally nicely. */ -#define FRAME_FRINGE_COLS(F) ((F)->fringe_cols) +INLINE int +FRAME_FRINGE_COLS (struct frame *f) +{ + return frame_dimension (f->fringe_cols); +} /* Pixel-width of the left and right fringe. */ -#define FRAME_LEFT_FRINGE_WIDTH(F) ((F)->left_fringe_width) -#define FRAME_RIGHT_FRINGE_WIDTH(F) ((F)->right_fringe_width) +INLINE int +FRAME_LEFT_FRINGE_WIDTH (struct frame *f) +{ + return frame_dimension (f->left_fringe_width); +} +INLINE int +FRAME_RIGHT_FRINGE_WIDTH (struct frame *f) +{ + return frame_dimension (f->right_fringe_width); +} /* Total width of fringes in pixels. */ -#define FRAME_TOTAL_FRINGE_WIDTH(F) \ - (FRAME_LEFT_FRINGE_WIDTH (F) + FRAME_RIGHT_FRINGE_WIDTH (F)) +INLINE int +FRAME_TOTAL_FRINGE_WIDTH (struct frame *f) +{ + return FRAME_LEFT_FRINGE_WIDTH (f) + FRAME_RIGHT_FRINGE_WIDTH (f); +} /* Pixel-width of internal border lines */ -#define FRAME_INTERNAL_BORDER_WIDTH(F) ((F)->internal_border_width) +INLINE int +FRAME_INTERNAL_BORDER_WIDTH (struct frame *f) +{ + return frame_dimension (f->internal_border_width); +} /* Pixel-size of window border lines */ -#define FRAME_RIGHT_DIVIDER_WIDTH(F) ((F)->right_divider_width) -#define FRAME_BOTTOM_DIVIDER_WIDTH(F) ((F)->bottom_divider_width) - -#else /* not HAVE_WINDOW_SYSTEM */ - -#define FRAME_FRINGE_COLS(F) 0 -#define FRAME_TOTAL_FRINGE_WIDTH(F) 0 -#define FRAME_LEFT_FRINGE_WIDTH(F) 0 -#define FRAME_RIGHT_FRINGE_WIDTH(F) 0 -#define FRAME_INTERNAL_BORDER_WIDTH(F) 0 -#define FRAME_RIGHT_DIVIDER_WIDTH(F) 0 -#define FRAME_BOTTOM_DIVIDER_WIDTH(F) 0 - -#endif /* not HAVE_WINDOW_SYSTEM */ +INLINE int +FRAME_RIGHT_DIVIDER_WIDTH (struct frame *f) +{ + return frame_dimension (f->right_divider_width); +} +INLINE int +FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f) +{ + return frame_dimension (f->bottom_divider_width); +} /*********************************************************************** Conversion between canonical units and pixels @@ -1469,7 +1508,7 @@ INLINE_HEADER_END /* Suppress -Wsuggest-attribute=const if there are no scroll bars. This is for functions like x_set_horizontal_scroll_bars that have no effect in this case. */ -#if ! USE_HORIZONTAL_SCROLL_BARS && 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +#if ! USE_HORIZONTAL_SCROLL_BARS && GNUC_PREREQ (4, 6, 0) # pragma GCC diagnostic ignored "-Wsuggest-attribute=const" #endif diff --git a/src/fringe.c b/src/fringe.c index 061f78658cf..986bde16f09 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -620,8 +620,7 @@ draw_fringe_bitmap_1 (struct window *w, struct glyph_row *row, int left_p, int o break; } - p.face = FACE_FROM_ID (f, face_id); - + p.face = FACE_FROM_ID_OR_NULL (f, face_id); if (p.face == NULL) { /* This could happen after clearing face cache. @@ -956,7 +955,7 @@ update_window_fringes (struct window *w, bool keep_current_p) row->indicate_bob_p is set, so it's OK that top_row_ends_at_zv_p is not initialized here. Similarly for bot_ind_rn, row->indicate_eob_p and bot_row_ends_at_zv_p. */ - int top_row_ends_at_zv_p IF_LINT (= 0), bot_row_ends_at_zv_p IF_LINT (= 0); + int top_row_ends_at_zv_p UNINIT, bot_row_ends_at_zv_p UNINIT; if (w->pseudo_window_p) return 0; @@ -1627,7 +1626,7 @@ If FACE is nil, reset face to default fringe face. */) { struct frame *f = SELECTED_FRAME (); - if (FACE_FROM_ID (f, FRINGE_FACE_ID) + if (FACE_FROM_ID_OR_NULL (f, FRINGE_FACE_ID) && lookup_derived_face (f, face, FRINGE_FACE_ID, 1) < 0) error ("No such face"); } diff --git a/src/ftcrfont.c b/src/ftcrfont.c index 2676502705d..67b43b63499 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -65,8 +65,6 @@ enum metrics_status #define METRICS_SET_STATUS(metrics, status) \ ((metrics)->ascent = 0, (metrics)->descent = (status)) -struct font_driver ftcrfont_driver; - static int ftcrfont_glyph_extents (struct font *font, unsigned glyph, @@ -101,7 +99,7 @@ ftcrfont_glyph_extents (struct font *font, cache = ftcrfont_info->metrics[row] + col; if (METRICS_STATUS (cache) == METRICS_INVALID) - ftfont_driver.text_extents (font, &glyph, 1, cache); + ftfont_text_extents (font, &glyph, 1, cache); if (metrics) *metrics = *cache; @@ -112,7 +110,7 @@ ftcrfont_glyph_extents (struct font *font, static Lisp_Object ftcrfont_list (struct frame *f, Lisp_Object spec) { - Lisp_Object list = ftfont_driver.list (f, spec), tail; + Lisp_Object list = ftfont_list (f, spec), tail; for (tail = list; CONSP (tail); tail = XCDR (tail)) ASET (XCAR (tail), FONT_TYPE_INDEX, Qftcr); @@ -122,15 +120,13 @@ ftcrfont_list (struct frame *f, Lisp_Object spec) static Lisp_Object ftcrfont_match (struct frame *f, Lisp_Object spec) { - Lisp_Object entity = ftfont_driver.match (f, spec); + Lisp_Object entity = ftfont_match (f, spec); if (VECTORP (entity)) ASET (entity, FONT_TYPE_INDEX, Qftcr); return entity; } -extern FT_Face ftfont_get_ft_face (Lisp_Object); - static Lisp_Object ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size) { @@ -181,7 +177,7 @@ ftcrfont_close (struct font *font) cairo_font_face_destroy (ftcrfont_info->cr_font_face); unblock_input (); - ftfont_driver.close (font); + ftfont_close (font); } static void @@ -282,6 +278,34 @@ ftcrfont_draw (struct glyph_string *s, +struct font_driver const ftcrfont_driver = + { + .type = LISPSYM_INITIALLY (Qftcr), + .get_cache = ftfont_get_cache, + .list = ftcrfont_list, + .match = ftcrfont_match, + .list_family = ftfont_list_family, + .open = ftcrfont_open, + .close = ftcrfont_close, + .has_char = ftfont_has_char, + .encode_char = ftfont_encode_char, + .text_extents = ftcrfont_text_extents, + .draw = ftcrfont_draw, + .get_bitmap = ftfont_get_bitmap, + .anchor_point = ftfont_anchor_point, +#ifdef HAVE_LIBOTF + .otf_capability = ftfont_otf_capability, +#endif +#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF + .shape = ftfont_shape, +#endif +#ifdef HAVE_OTF_GET_VARIATION_GLYPHS + .get_variation_glyphs = ftfont_variation_glyphs, +#endif + .filter_properties = ftfont_filter_properties, + .combining_capability = ftfont_combining_capability, + }; + void syms_of_ftcrfont (void) { @@ -289,14 +313,5 @@ syms_of_ftcrfont (void) abort (); DEFSYM (Qftcr, "ftcr"); - - ftcrfont_driver = ftfont_driver; - ftcrfont_driver.type = Qftcr; - ftcrfont_driver.list = ftcrfont_list; - ftcrfont_driver.match = ftcrfont_match; - ftcrfont_driver.open = ftcrfont_open; - ftcrfont_driver.close = ftcrfont_close; - ftcrfont_driver.text_extents = ftcrfont_text_extents; - ftcrfont_driver.draw = ftcrfont_draw; register_font_driver (&ftcrfont_driver, NULL); } diff --git a/src/ftfont.c b/src/ftfont.c index 7285aee9bd4..bcc10c45fba 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -35,6 +35,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "font.h" #include "ftfont.h" +static struct font_driver const ftfont_driver; + /* Flag to tell if FcInit is already called or not. */ static bool fc_initialized; @@ -73,17 +75,9 @@ enum ftfont_cache_for FTFONT_CACHE_FOR_ENTITY }; -static Lisp_Object ftfont_pattern_entity (FcPattern *, Lisp_Object); - -static Lisp_Object ftfont_resolve_generic_family (Lisp_Object, - FcPattern *); static Lisp_Object ftfont_lookup_cache (Lisp_Object, enum ftfont_cache_for); -static void ftfont_filter_properties (Lisp_Object font, Lisp_Object alist); - -static Lisp_Object ftfont_combining_capability (struct font *); - #define SYMBOL_FcChar8(SYM) (FcChar8 *) SDATA (SYMBOL_NAME (SYM)) static struct @@ -480,83 +474,7 @@ ftfont_get_otf (struct ftfont_info *ftfont_info) } #endif /* HAVE_LIBOTF */ -static Lisp_Object ftfont_get_cache (struct frame *); -static Lisp_Object ftfont_list (struct frame *, Lisp_Object); -static Lisp_Object ftfont_match (struct frame *, Lisp_Object); -static Lisp_Object ftfont_list_family (struct frame *); -static Lisp_Object ftfont_open (struct frame *, Lisp_Object, int); -static void ftfont_close (struct font *); -static int ftfont_has_char (Lisp_Object, int); -static unsigned ftfont_encode_char (struct font *, int); -static void ftfont_text_extents (struct font *, unsigned *, int, - struct font_metrics *); -static int ftfont_get_bitmap (struct font *, unsigned, - struct font_bitmap *, int); -static int ftfont_anchor_point (struct font *, unsigned, int, - int *, int *); -#ifdef HAVE_LIBOTF -static Lisp_Object ftfont_otf_capability (struct font *); -# ifdef HAVE_M17N_FLT -static Lisp_Object ftfont_shape (Lisp_Object); -# endif -#endif - -#ifdef HAVE_OTF_GET_VARIATION_GLYPHS -static int ftfont_variation_glyphs (struct font *, int c, - unsigned variations[256]); -#endif /* HAVE_OTF_GET_VARIATION_GLYPHS */ - -struct font_driver ftfont_driver = - { - LISP_INITIALLY_ZERO, /* Qfreetype */ - 0, /* case insensitive */ - ftfont_get_cache, - ftfont_list, - ftfont_match, - ftfont_list_family, - NULL, /* free_entity */ - ftfont_open, - ftfont_close, - /* We can't draw a text without device dependent functions. */ - NULL, /* prepare_face */ - NULL, /* done_face */ - ftfont_has_char, - ftfont_encode_char, - ftfont_text_extents, - /* We can't draw a text without device dependent functions. */ - NULL, /* draw */ - ftfont_get_bitmap, - NULL, /* free_bitmap */ - ftfont_anchor_point, -#ifdef HAVE_LIBOTF - ftfont_otf_capability, -#else /* not HAVE_LIBOTF */ - NULL, -#endif /* not HAVE_LIBOTF */ - NULL, /* otf_drive */ - NULL, /* start_for_frame */ - NULL, /* end_for_frame */ -#if defined (HAVE_M17N_FLT) && defined (HAVE_LIBOTF) - ftfont_shape, -#else /* not (HAVE_M17N_FLT && HAVE_LIBOTF) */ - NULL, -#endif /* not (HAVE_M17N_FLT && HAVE_LIBOTF) */ - NULL, /* check */ - -#ifdef HAVE_OTF_GET_VARIATION_GLYPHS - ftfont_variation_glyphs, -#else - NULL, -#endif - - ftfont_filter_properties, /* filter_properties */ - - NULL, /* cached_font_ok */ - - ftfont_combining_capability, - }; - -static Lisp_Object +Lisp_Object ftfont_get_cache (struct frame *f) { return freetype_font_cache; @@ -568,7 +486,6 @@ ftfont_get_charset (Lisp_Object registry) char *str = SSDATA (SYMBOL_NAME (registry)); USE_SAFE_ALLOCA; char *re = SAFE_ALLOCA (SBYTES (SYMBOL_NAME (registry)) * 2 + 1); - Lisp_Object regexp; int i, j; for (i = j = 0; i < SBYTES (SYMBOL_NAME (registry)); i++, j++) @@ -582,13 +499,13 @@ ftfont_get_charset (Lisp_Object registry) re[j] = '.'; } re[j] = '\0'; - regexp = make_unibyte_string (re, j); - SAFE_FREE (); + AUTO_STRING_WITH_LEN (regexp, re, j); for (i = 0; fc_charset_table[i].name; i++) if (fast_c_string_match_ignore_case (regexp, fc_charset_table[i].name, strlen (fc_charset_table[i].name)) >= 0) break; + SAFE_FREE (); if (! fc_charset_table[i].name) return -1; if (! fc_charset_table[i].fc_charset) @@ -874,7 +791,7 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots return pattern; } -static Lisp_Object +Lisp_Object ftfont_list (struct frame *f, Lisp_Object spec) { Lisp_Object val = Qnil, family, adstyle; @@ -1073,7 +990,7 @@ ftfont_list (struct frame *f, Lisp_Object spec) return val; } -static Lisp_Object +Lisp_Object ftfont_match (struct frame *f, Lisp_Object spec) { Lisp_Object entity = Qnil; @@ -1123,7 +1040,7 @@ ftfont_match (struct frame *f, Lisp_Object spec) return entity; } -static Lisp_Object +Lisp_Object ftfont_list_family (struct frame *f) { Lisp_Object list = Qnil; @@ -1302,7 +1219,7 @@ ftfont_open2 (struct frame *f, return font_object; } -static Lisp_Object +Lisp_Object ftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) { Lisp_Object font_object; @@ -1315,7 +1232,7 @@ ftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) return ftfont_open2 (f, entity, pixel_size, font_object); } -static void +void ftfont_close (struct font *font) { /* FIXME: Although this function can be called while garbage-collecting, @@ -1345,7 +1262,7 @@ ftfont_close (struct font *font) FT_Done_Size (ftfont_info->ft_size); } -static int +int ftfont_has_char (Lisp_Object font, int c) { struct charset *cs = NULL; @@ -1375,7 +1292,7 @@ ftfont_has_char (Lisp_Object font, int c) } } -static unsigned +unsigned ftfont_encode_char (struct font *font, int c) { struct ftfont_info *ftfont_info = (struct ftfont_info *) font; @@ -1386,7 +1303,7 @@ ftfont_encode_char (struct font *font, int c) return (code > 0 ? code : FONT_INVALID_CODE); } -static void +void ftfont_text_extents (struct font *font, unsigned int *code, int nglyphs, struct font_metrics *metrics) { @@ -1430,7 +1347,7 @@ ftfont_text_extents (struct font *font, unsigned int *code, metrics->width = width; } -static int +int ftfont_get_bitmap (struct font *font, unsigned int code, struct font_bitmap *bitmap, int bits_per_pixel) { struct ftfont_info *ftfont_info = (struct ftfont_info *) font; @@ -1473,7 +1390,7 @@ ftfont_get_bitmap (struct font *font, unsigned int code, struct font_bitmap *bit return 0; } -static int +int ftfont_anchor_point (struct font *font, unsigned int code, int idx, int *x, int *y) { @@ -1539,7 +1456,7 @@ ftfont_otf_features (OTF_GSUB_GPOS *gsub_gpos) } -static Lisp_Object +Lisp_Object ftfont_otf_capability (struct font *font) { struct ftfont_info *ftfont_info = (struct ftfont_info *) font; @@ -2702,7 +2619,7 @@ ftfont_shape (Lisp_Object lgstring) #ifdef HAVE_OTF_GET_VARIATION_GLYPHS -static int +int ftfont_variation_glyphs (struct font *font, int c, unsigned variations[256]) { struct ftfont_info *ftfont_info = (struct ftfont_info *) font; @@ -2760,14 +2677,14 @@ static const char *const ftfont_non_booleans [] = { NULL, }; -static void +void ftfont_filter_properties (Lisp_Object font, Lisp_Object alist) { font_filter_properties (font, alist, ftfont_booleans, ftfont_non_booleans); } -static Lisp_Object +Lisp_Object ftfont_combining_capability (struct font *font) { #ifdef HAVE_M17N_FLT @@ -2777,6 +2694,34 @@ ftfont_combining_capability (struct font *font) #endif } +static struct font_driver const ftfont_driver = + { + /* We can't draw a text without device dependent functions. */ + .type = LISPSYM_INITIALLY (Qfreetype), + .get_cache = ftfont_get_cache, + .list = ftfont_list, + .match = ftfont_match, + .list_family = ftfont_list_family, + .open = ftfont_open, + .close = ftfont_close, + .has_char = ftfont_has_char, + .encode_char = ftfont_encode_char, + .text_extents = ftfont_text_extents, + .get_bitmap = ftfont_get_bitmap, + .anchor_point = ftfont_anchor_point, +#ifdef HAVE_LIBOTF + .otf_capability = ftfont_otf_capability, +#endif +#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF + .shape = ftfont_shape, +#endif +#ifdef HAVE_OTF_GET_VARIATION_GLYPHS + .get_variation_glyphs = ftfont_variation_glyphs, +#endif + .filter_properties = ftfont_filter_properties, + .combining_capability = ftfont_combining_capability, + }; + void syms_of_ftfont (void) { @@ -2800,6 +2745,5 @@ syms_of_ftfont (void) staticpro (&ft_face_cache); ft_face_cache = Qnil; - ftfont_driver.type = Qfreetype; register_font_driver (&ftfont_driver, NULL); } diff --git a/src/ftxfont.c b/src/ftxfont.c index f49d44ffc20..d1632e3c9ac 100644 --- a/src/ftxfont.c +++ b/src/ftxfont.c @@ -31,8 +31,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* FTX font driver. */ -struct font_driver ftxfont_driver; - struct ftxfont_frame_data { /* Background and foreground colors. */ @@ -95,7 +93,7 @@ ftxfont_get_gcs (struct frame *f, unsigned long foreground, unsigned long backgr if (! x_alloc_nearest_color (f, FRAME_X_COLORMAP (f), &color)) break; xgcv.foreground = color.pixel; - new->gcs[i - 1] = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + new->gcs[i - 1] = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), GCForeground, &xgcv); } unblock_input (); @@ -125,7 +123,7 @@ ftxfont_draw_bitmap (struct frame *f, GC gc_fore, GC *gcs, struct font *font, unsigned char *b; int i, j; - if (ftfont_driver.get_bitmap (font, code, &bitmap, size > 0x100 ? 1 : 8) < 0) + if (ftfont_get_bitmap (font, code, &bitmap, size > 0x100 ? 1 : 8) < 0) return 0; if (size > 0x100) { @@ -139,14 +137,14 @@ ftxfont_draw_bitmap (struct frame *f, GC gc_fore, GC *gcs, struct font *font, p[n[0]].y = y - bitmap.top + i; if (++n[0] == size) { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc_fore, p, size, CoordModeOrigin); n[0] = 0; } } } if (flush && n[0] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc_fore, p, n[0], CoordModeOrigin); } else @@ -168,7 +166,7 @@ ftxfont_draw_bitmap (struct frame *f, GC gc_fore, GC *gcs, struct font *font, pp[n[idx]].y = y - bitmap.top + i; if (++(n[idx]) == size) { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), idx == 6 ? gc_fore : gcs[idx], pp, size, CoordModeOrigin); n[idx] = 0; @@ -180,16 +178,15 @@ ftxfont_draw_bitmap (struct frame *f, GC gc_fore, GC *gcs, struct font *font, { for (i = 0; i < 6; i++) if (n[i] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gcs[i], p + 0x100 * i, n[i], CoordModeOrigin); if (n[6] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc_fore, p + 0x600, n[6], CoordModeOrigin); } } - if (ftfont_driver.free_bitmap) - ftfont_driver.free_bitmap (font, &bitmap); + /* There is no ftfont_free_bitmap, so do not try to free BITMAP. */ return bitmap.advance; } @@ -203,7 +200,7 @@ ftxfont_draw_background (struct frame *f, struct font *font, GC gc, int x, int y XGetGCValues (FRAME_X_DISPLAY (f), gc, GCForeground | GCBackground, &xgcv); XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.background); - XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), gc, + XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc, x, y - FONT_BASE (font), width, FONT_HEIGHT (font)); XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.foreground); } @@ -211,7 +208,7 @@ ftxfont_draw_background (struct frame *f, struct font *font, GC gc, int x, int y static Lisp_Object ftxfont_list (struct frame *f, Lisp_Object spec) { - Lisp_Object list = ftfont_driver.list (f, spec), tail; + Lisp_Object list = ftfont_list (f, spec), tail; for (tail = list; CONSP (tail); tail = XCDR (tail)) ASET (XCAR (tail), FONT_TYPE_INDEX, Qftx); @@ -221,7 +218,7 @@ ftxfont_list (struct frame *f, Lisp_Object spec) static Lisp_Object ftxfont_match (struct frame *f, Lisp_Object spec) { - Lisp_Object entity = ftfont_driver.match (f, spec); + Lisp_Object entity = ftfont_match (f, spec); if (VECTORP (entity)) ASET (entity, FONT_TYPE_INDEX, Qftx); @@ -231,13 +228,10 @@ ftxfont_match (struct frame *f, Lisp_Object spec) static Lisp_Object ftxfont_open (struct frame *f, Lisp_Object entity, int pixel_size) { - Lisp_Object font_object; - struct font *font; - - font_object = ftfont_driver.open (f, entity, pixel_size); + Lisp_Object font_object = ftfont_open (f, entity, pixel_size); if (NILP (font_object)) return Qnil; - font = XFONT_OBJECT (font_object); + struct font *font = XFONT_OBJECT (font_object); font->driver = &ftxfont_driver; return font_object; } @@ -245,7 +239,7 @@ ftxfont_open (struct frame *f, Lisp_Object entity, int pixel_size) static void ftxfont_close (struct font *font) { - ftfont_driver.close (font); + ftfont_close (font); } static int @@ -345,18 +339,39 @@ ftxfont_end_for_frame (struct frame *f) +struct font_driver const ftxfont_driver = + { + /* We can't draw a text without device dependent functions. */ + .type = LISPSYM_INITIALLY (Qftx), + .get_cache = ftfont_get_cache, + .list = ftxfont_list, + .match = ftxfont_match, + .list_family = ftfont_list_family, + .open = ftxfont_open, + .close = ftxfont_close, + .has_char = ftfont_has_char, + .encode_char = ftfont_encode_char, + .text_extents = ftfont_text_extents, + .draw = ftxfont_draw, + .get_bitmap = ftfont_get_bitmap, + .anchor_point = ftfont_anchor_point, +#ifdef HAVE_LIBOTF + .otf_capability = ftfont_otf_capability, +#endif + .end_for_frame = ftxfont_end_for_frame, +#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF + .shape = ftfont_shape, +#endif +#ifdef HAVE_OTF_GET_VARIATION_GLYPHS + .get_variation_glyphs = ftfont_variation_glyphs, +#endif + .filter_properties = ftfont_filter_properties, + .combining_capability = ftfont_combining_capability, + }; + void syms_of_ftxfont (void) { DEFSYM (Qftx, "ftx"); - - ftxfont_driver = ftfont_driver; - ftxfont_driver.type = Qftx; - ftxfont_driver.list = ftxfont_list; - ftxfont_driver.match = ftxfont_match; - ftxfont_driver.open = ftxfont_open; - ftxfont_driver.close = ftxfont_close; - ftxfont_driver.draw = ftxfont_draw; - ftxfont_driver.end_for_frame = ftxfont_end_for_frame; register_font_driver (&ftxfont_driver, NULL); } diff --git a/src/gfilenotify.c b/src/gfilenotify.c index 30d0753f7e7..66248050693 100644 --- a/src/gfilenotify.c +++ b/src/gfilenotify.c @@ -258,7 +258,7 @@ WATCH-DESCRIPTOR should be an object returned by `gfile-add-watch'. */) } DEFUN ("gfile-valid-p", Fgfile_valid_p, Sgfile_valid_p, 1, 1, 0, - doc: /* "Check a watch specified by its WATCH-DESCRIPTOR. + doc: /* Check a watch specified by its WATCH-DESCRIPTOR. WATCH-DESCRIPTOR should be an object returned by `gfile-add-watch'. @@ -278,6 +278,25 @@ invalid. */) } } +DEFUN ("gfile-monitor-name", Fgfile_monitor_name, Sgfile_monitor_name, 1, 1, 0, + doc: /* Return the internal monitor name for WATCH-DESCRIPTOR. + +The result is a symbol, either `GInotifyFileMonitor', +`GKqueueFileMonitor', `GFamFileMonitor', or `GPollFileMonitor'. + +WATCH-DESCRIPTOR should be an object returned by `gfile-add-watch'. +If WATCH-DESCRIPTOR is not valid, nil is returned. */) + (Lisp_Object watch_descriptor) +{ + if (NILP (Fgfile_valid_p (watch_descriptor))) + return Qnil; + else + { + GFileMonitor *monitor = XINTPTR (watch_descriptor); + return intern (G_OBJECT_TYPE_NAME (monitor)); + } +} + void globals_of_gfilenotify (void) @@ -294,6 +313,7 @@ syms_of_gfilenotify (void) defsubr (&Sgfile_add_watch); defsubr (&Sgfile_rm_watch); defsubr (&Sgfile_valid_p); + defsubr (&Sgfile_monitor_name); /* Filter objects. */ DEFSYM (Qchange, "change"); diff --git a/src/gmalloc.c b/src/gmalloc.c index fb2861c18ac..3f7bbda84ab 100644 --- a/src/gmalloc.c +++ b/src/gmalloc.c @@ -25,14 +25,11 @@ License along with this library. If not, see <http://www.gnu.org/licenses/>. #define USE_PTHREAD #endif +#include <stddef.h> +#include <stdlib.h> #include <string.h> #include <limits.h> #include <stdint.h> - -#ifdef HYBRID_GET_CURRENT_DIR_NAME -#undef get_current_dir_name -#endif - #include <unistd.h> #ifdef USE_PTHREAD @@ -40,7 +37,22 @@ License along with this library. If not, see <http://www.gnu.org/licenses/>. #endif #ifdef emacs -extern _Noreturn void emacs_abort (void) NO_INLINE; +# include "lisp.h" +#endif + +#ifdef HAVE_MALLOC_H +# if GNUC_PREREQ (4, 2, 0) +# pragma GCC diagnostic ignored "-Wdeprecated-declarations" +# endif +# include <malloc.h> +#endif +#ifndef __MALLOC_HOOK_VOLATILE +# define __MALLOC_HOOK_VOLATILE volatile +#endif +#ifndef HAVE_MALLOC_H +extern void (*__MALLOC_HOOK_VOLATILE __after_morecore_hook) (void); +extern void (*__MALLOC_HOOK_VOLATILE __malloc_initialize_hook) (void); +extern void *(*__morecore) (ptrdiff_t); #endif /* If HYBRID_MALLOC is defined, then temacs will use malloc, @@ -49,13 +61,7 @@ extern _Noreturn void emacs_abort (void) NO_INLINE; however, will use the system malloc, realloc.... In other source files, malloc, realloc... are renamed hybrid_malloc, hybrid_realloc... via macros in conf_post.h. hybrid_malloc and - friends are wrapper functions defined later in this file. - aligned_alloc is defined as a macro only in alloc.c. - - As of this writing (August 2014), Cygwin is the only platform on - which HYBRID_MACRO is defined. Any other platform that wants to - define it will have to define the macros DUMPED and - ALLOCATED_BEFORE_DUMPING, defined below for Cygwin. */ + friends are wrapper functions defined later in this file. */ #undef malloc #undef realloc #undef calloc @@ -66,15 +72,16 @@ extern _Noreturn void emacs_abort (void) NO_INLINE; #define calloc gcalloc #define aligned_alloc galigned_alloc #define free gfree +#define malloc_info gmalloc_info -#ifdef CYGWIN -extern void *bss_sbrk (ptrdiff_t size); -extern int bss_sbrk_did_unexec; -extern char bss_sbrk_buffer[]; -extern void *bss_sbrk_buffer_end; -#define DUMPED bss_sbrk_did_unexec -#define ALLOCATED_BEFORE_DUMPING(P) \ - ((P) < bss_sbrk_buffer_end && (P) >= (void *) bss_sbrk_buffer) +#ifdef HYBRID_MALLOC +# include "sheap.h" +# define DUMPED bss_sbrk_did_unexec +static bool +ALLOCATED_BEFORE_DUMPING (char *p) +{ + return bss_sbrk_buffer <= p && p < bss_sbrk_buffer + STATIC_HEAP_SIZE; +} #endif #ifdef __cplusplus @@ -82,8 +89,9 @@ extern "C" { #endif -#include <stddef.h> - +#ifdef HYBRID_MALLOC +#define extern static +#endif /* Allocate SIZE bytes of memory. */ extern void *malloc (size_t size) ATTRIBUTE_MALLOC_SIZE ((1)); @@ -92,34 +100,28 @@ extern void *malloc (size_t size) ATTRIBUTE_MALLOC_SIZE ((1)); extern void *realloc (void *ptr, size_t size) ATTRIBUTE_ALLOC_SIZE ((2)); /* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ extern void *calloc (size_t nmemb, size_t size) ATTRIBUTE_MALLOC_SIZE ((1,2)); -/* Free a block allocated by `malloc', `realloc' or `calloc'. */ +/* Free a block. */ extern void free (void *ptr); /* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ extern void *aligned_alloc (size_t, size_t); -extern void *memalign (size_t, size_t); #ifdef MSDOS +extern void *memalign (size_t, size_t); extern int posix_memalign (void **, size_t, size_t); #endif -#ifdef USE_PTHREAD -/* Set up mutexes and make malloc etc. thread-safe. */ -extern void malloc_enable_thread (void); -#endif - /* The allocator divides the heap into blocks of fixed size; large requests receive one or more whole blocks, and small requests receive a fragment of a block. Fragment sizes are powers of two, and all fragments of a block are the same size. When all the fragments in a block have been freed, the block itself is freed. */ -#define INT_BIT (CHAR_BIT * sizeof (int)) -#define BLOCKLOG (INT_BIT > 16 ? 12 : 9) +#define BLOCKLOG (INT_WIDTH > 16 ? 12 : 9) #define BLOCKSIZE (1 << BLOCKLOG) #define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE) /* Determine the amount of memory spanned by the initial heap table (not an absolute limit). */ -#define HEAP (INT_BIT > 16 ? 4194304 : 65536) +#define HEAP (INT_WIDTH > 16 ? 4194304 : 65536) /* Number of contiguous free blocks allowed to build up at the end of memory before they will be returned to the system. */ @@ -238,36 +240,12 @@ extern int _malloc_thread_enabled_p; #define UNLOCK_ALIGNED_BLOCKS() #endif -/* Given an address in the middle of a malloc'd object, - return the address of the beginning of the object. */ -extern void *malloc_find_object_address (void *ptr); - -/* Underlying allocation function; successive calls should - return contiguous pieces of memory. */ -extern void *(*__morecore) (ptrdiff_t size); - -/* Default value of `__morecore'. */ -extern void *__default_morecore (ptrdiff_t size); - -/* If not NULL, this function is called after each time - `__morecore' is called to increase the data size. */ -extern void (*__after_morecore_hook) (void); - -/* Number of extra blocks to get each time we ask for more core. - This reduces the frequency of calling `(*__morecore)'. */ -extern size_t __malloc_extra_blocks; - /* Nonzero if `malloc' has been called and done its initialization. */ extern int __malloc_initialized; /* Function called to initialize malloc data structures. */ extern int __malloc_initialize (void); -/* Hooks for debugging versions. */ -extern void (*__malloc_initialize_hook) (void); -extern void (*__free_hook) (void *ptr); -extern void *(*__malloc_hook) (size_t size); -extern void *(*__realloc_hook) (void *ptr, size_t size); -extern void *(*__memalign_hook) (size_t size, size_t alignment); +#ifdef GC_MCHECK /* Return values for `mprobe': these are the kinds of inconsistencies that `mcheck' enables detection of. */ @@ -308,8 +286,9 @@ struct mstats /* Pick up the current statistics. */ extern struct mstats mstats (void); -/* Call WARNFUN with a warning message when memory usage is high. */ -extern void memory_warnings (void *start, void (*warnfun) (const char *)); +#endif + +#undef extern #ifdef __cplusplus } @@ -337,10 +316,17 @@ License along with this library. If not, see <http://www.gnu.org/licenses/>. #include <errno.h> -void *(*__morecore) (ptrdiff_t size) = __default_morecore; +/* Debugging hook for 'malloc'. */ +static void *(*__MALLOC_HOOK_VOLATILE gmalloc_hook) (size_t); -/* Debugging hook for `malloc'. */ -void *(*__malloc_hook) (size_t size); +/* Replacements for traditional glibc malloc hooks, for platforms that + do not already have these hooks. Platforms with these hooks all + used relaxed ref/def, so it is OK to define them here too. */ +void (*__MALLOC_HOOK_VOLATILE __malloc_initialize_hook) (void); +void (*__MALLOC_HOOK_VOLATILE __after_morecore_hook) (void); +void *(*__morecore) (ptrdiff_t); + +#ifndef HYBRID_MALLOC /* Pointer to the base of the first block. */ char *_heapbase; @@ -348,9 +334,6 @@ char *_heapbase; /* Block information table. Allocated with align/__free (not malloc/free). */ malloc_info *_heapinfo; -/* Number of info entries. */ -static size_t heapsize; - /* Search index in the info table. */ size_t _heapindex; @@ -369,10 +352,21 @@ size_t _bytes_free; /* Are you experienced? */ int __malloc_initialized; +#else + +static struct list _fraghead[BLOCKLOG]; + +#endif /* HYBRID_MALLOC */ + +/* Number of extra blocks to get each time we ask for more core. + This reduces the frequency of calling `(*__morecore)'. */ +#if defined DOUG_LEA_MALLOC || defined HYBRID_MALLOC || defined SYSTEM_MALLOC +static +#endif size_t __malloc_extra_blocks; -void (*__malloc_initialize_hook) (void); -void (*__after_morecore_hook) (void); +/* Number of info entries. */ +static size_t heapsize; #if defined GC_MALLOC_CHECK && defined GC_PROTECT_MALLOC_STATE @@ -927,19 +921,19 @@ malloc (size_t size) if (!__malloc_initialized && !__malloc_initialize ()) return NULL; - /* Copy the value of __malloc_hook to an automatic variable in case - __malloc_hook is modified in another thread between its + /* Copy the value of gmalloc_hook to an automatic variable in case + gmalloc_hook is modified in another thread between its NULL-check and the use. Note: Strictly speaking, this is not a right solution. We should use mutexes to access non-read-only variables that are shared among multiple threads. We just leave it for compatibility with - glibc malloc (i.e., assignments to __malloc_hook) for now. */ - hook = __malloc_hook; + glibc malloc (i.e., assignments to gmalloc_hook) for now. */ + hook = gmalloc_hook; return (hook != NULL ? *hook : _malloc_internal) (size); } -#ifndef _LIBC +#if !(defined (_LIBC) || defined (HYBRID_MALLOC)) /* On some ANSI C systems, some libc functions call _malloc, _free and _realloc. Make them use the GNU functions. */ @@ -987,12 +981,14 @@ License along with this library. If not, see <http://www.gnu.org/licenses/>. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ - /* Debugging hook for free. */ -void (*__free_hook) (void *__ptr); +static void (*__MALLOC_HOOK_VOLATILE gfree_hook) (void *); + +#ifndef HYBRID_MALLOC /* List of blocks allocated by aligned_alloc. */ struct alignlist *_aligned_blocks = NULL; +#endif /* Return memory to the heap. Like `_free_internal' but don't lock mutex. */ @@ -1241,7 +1237,7 @@ _free_internal_nolock (void *ptr) } /* Return memory to the heap. - Like `free' but don't call a __free_hook if there is one. */ + Like 'free' but don't call a hook if there is one. */ void _free_internal (void *ptr) { @@ -1255,7 +1251,7 @@ _free_internal (void *ptr) void free (void *ptr) { - void (*hook) (void *) = __free_hook; + void (*hook) (void *) = gfree_hook; if (hook != NULL) (*hook) (ptr); @@ -1263,6 +1259,7 @@ free (void *ptr) _free_internal (ptr); } +#ifndef HYBRID_MALLOC /* Define the `cfree' alias for `free'. */ #ifdef weak_alias weak_alias (free, cfree) @@ -1273,6 +1270,7 @@ cfree (void *ptr) free (ptr); } #endif +#endif /* Change the size of a block allocated by `malloc'. Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Written May 1989 by Mike Haertel. @@ -1298,7 +1296,7 @@ License along with this library. If not, see <http://www.gnu.org/licenses/>. #endif /* Debugging hook for realloc. */ -void *(*__realloc_hook) (void *ptr, size_t size); +static void *(*grealloc_hook) (void *, size_t); /* Resize the given region to the new size, returning a pointer to the (possibly moved) region. This is optimized for speed; @@ -1442,7 +1440,7 @@ realloc (void *ptr, size_t size) if (!__malloc_initialized && !__malloc_initialize ()) return NULL; - hook = __realloc_hook; + hook = grealloc_hook; return (hook != NULL ? *hook : _realloc_internal) (ptr, size); } /* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. @@ -1512,11 +1510,11 @@ extern void *__sbrk (ptrdiff_t increment); /* Allocate INCREMENT more bytes of data space, and return the start of data space, or NULL on errors. If INCREMENT is negative, shrink data space. */ -void * -__default_morecore (ptrdiff_t increment) +static void * +gdefault_morecore (ptrdiff_t increment) { void *result; -#if defined (CYGWIN) +#ifdef HYBRID_MALLOC if (!DUMPED) { return bss_sbrk (increment); @@ -1527,6 +1525,9 @@ __default_morecore (ptrdiff_t increment) return NULL; return result; } + +void *(*__morecore) (ptrdiff_t) = gdefault_morecore; + /* Copyright (C) 1991, 92, 93, 94, 95, 96 Free Software Foundation, Inc. This library is free software; you can redistribute it and/or @@ -1542,17 +1543,11 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this library. If not, see <http://www.gnu.org/licenses/>. */ -void *(*__memalign_hook) (size_t size, size_t alignment); - void * aligned_alloc (size_t alignment, size_t size) { void *result; size_t adj, lastadj; - void *(*hook) (size_t, size_t) = __memalign_hook; - - if (hook) - return (*hook) (alignment, size); /* Allocate a block with enough extra space to pad the block with up to (ALIGNMENT - 1) bytes if necessary. */ @@ -1631,6 +1626,8 @@ aligned_alloc (size_t alignment, size_t size) return result; } +/* Note that memalign and posix_memalign are not used in Emacs. */ +#ifndef HYBRID_MALLOC /* An obsolete alias for aligned_alloc, for any old libraries that use this alias. */ @@ -1642,7 +1639,6 @@ memalign (size_t alignment, size_t size) /* If HYBRID_MALLOC is defined, we may want to use the system posix_memalign below. */ -#ifndef HYBRID_MALLOC int posix_memalign (void **memptr, size_t alignment, size_t size) { @@ -1682,16 +1678,18 @@ License along with this library. If not, see <http://www.gnu.org/licenses/>. The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ +#ifndef HYBRID_MALLOC + +# ifndef HAVE_MALLOC_H /* Allocate SIZE bytes on a page boundary. */ -#ifndef HAVE_DECL_VALLOC extern void *valloc (size_t); -#endif +# endif -#if defined _SC_PAGESIZE || !defined HAVE_GETPAGESIZE -# include "getpagesize.h" -#elif !defined getpagesize +# if defined _SC_PAGESIZE || !defined HAVE_GETPAGESIZE +# include "getpagesize.h" +# elif !defined getpagesize extern int getpagesize (void); -#endif +# endif static size_t pagesize; @@ -1703,6 +1701,7 @@ valloc (size_t size) return aligned_alloc (pagesize, size); } +#endif /* HYBRID_MALLOC */ #undef malloc #undef realloc @@ -1796,19 +1795,6 @@ hybrid_realloc (void *ptr, size_t size) return result; } -#ifdef HYBRID_GET_CURRENT_DIR_NAME -/* Defined in sysdep.c. */ -char *gget_current_dir_name (void); - -char * -hybrid_get_current_dir_name (void) -{ - if (DUMPED) - return get_current_dir_name (); - return gget_current_dir_name (); -} -#endif - #else /* ! HYBRID_MALLOC */ void * @@ -1943,9 +1929,9 @@ freehook (void *ptr) else hdr = NULL; - __free_hook = old_free_hook; + gfree_hook = old_free_hook; free (hdr); - __free_hook = freehook; + gfree_hook = freehook; } static void * @@ -1953,9 +1939,9 @@ mallochook (size_t size) { struct hdr *hdr; - __malloc_hook = old_malloc_hook; + gmalloc_hook = old_malloc_hook; hdr = malloc (sizeof *hdr + size + 1); - __malloc_hook = mallochook; + gmalloc_hook = mallochook; if (hdr == NULL) return NULL; @@ -1981,13 +1967,13 @@ reallochook (void *ptr, size_t size) memset ((char *) ptr + size, FREEFLOOD, osize - size); } - __free_hook = old_free_hook; - __malloc_hook = old_malloc_hook; - __realloc_hook = old_realloc_hook; + gfree_hook = old_free_hook; + gmalloc_hook = old_malloc_hook; + grealloc_hook = old_realloc_hook; hdr = realloc (hdr, sizeof *hdr + size + 1); - __free_hook = freehook; - __malloc_hook = mallochook; - __realloc_hook = reallochook; + gfree_hook = freehook; + gmalloc_hook = mallochook; + grealloc_hook = reallochook; if (hdr == NULL) return NULL; @@ -2044,12 +2030,12 @@ mcheck (void (*func) (enum mcheck_status)) /* These hooks may not be safely inserted if malloc is already in use. */ if (!__malloc_initialized && !mcheck_used) { - old_free_hook = __free_hook; - __free_hook = freehook; - old_malloc_hook = __malloc_hook; - __malloc_hook = mallochook; - old_realloc_hook = __realloc_hook; - __realloc_hook = reallochook; + old_free_hook = gfree_hook; + gfree_hook = freehook; + old_malloc_hook = gmalloc_hook; + gmalloc_hook = mallochook; + old_realloc_hook = grealloc_hook; + grealloc_hook = reallochook; mcheck_used = 1; } diff --git a/src/gnutls.c b/src/gnutls.c index f0354d7fedf..af2ba52870c 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -26,7 +26,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "coding.h" #ifdef HAVE_GNUTLS -#include <gnutls/gnutls.h> #ifdef WINDOWSNT #include <windows.h> @@ -55,7 +54,6 @@ DEF_DLL_FN (gnutls_alert_description_t, gnutls_alert_get, (gnutls_session_t)); DEF_DLL_FN (const char *, gnutls_alert_get_name, (gnutls_alert_description_t)); -DEF_DLL_FN (int, gnutls_alert_send_appropriate, (gnutls_session_t, int)); DEF_DLL_FN (int, gnutls_anon_allocate_client_credentials, (gnutls_anon_client_credentials_t *)); DEF_DLL_FN (void, gnutls_anon_free_client_credentials, @@ -111,8 +109,6 @@ DEF_DLL_FN (ssize_t, gnutls_record_send, (gnutls_session_t, const void *, size_t)); DEF_DLL_FN (const char *, gnutls_strerror, (int)); DEF_DLL_FN (void, gnutls_transport_set_errno, (gnutls_session_t, int)); -DEF_DLL_FN (const char *, gnutls_check_version, (const char *)); -DEF_DLL_FN (void, gnutls_transport_set_lowat, (gnutls_session_t, int)); DEF_DLL_FN (void, gnutls_transport_set_ptr2, (gnutls_session_t, gnutls_transport_ptr_t, gnutls_transport_ptr_t)); @@ -156,8 +152,6 @@ DEF_DLL_FN (int, gnutls_x509_crt_get_subject_unique_id, (gnutls_x509_crt_t, char *, size_t *)); DEF_DLL_FN (int, gnutls_x509_crt_get_signature_algorithm, (gnutls_x509_crt_t)); -DEF_DLL_FN (int, gnutls_x509_crt_get_signature, - (gnutls_x509_crt_t, char *, size_t *)); DEF_DLL_FN (int, gnutls_x509_crt_get_key_id, (gnutls_x509_crt_t, unsigned int, unsigned char *, size_t *_size)); DEF_DLL_FN (const char*, gnutls_sec_param_get_name, (gnutls_sec_param_t)); @@ -184,7 +178,7 @@ init_gnutls_functions (void) HMODULE library; int max_log_level = 1; - if (!(library = w32_delayed_load (Qgnutls_dll))) + if (!(library = w32_delayed_load (Qgnutls))) { GNUTLS_LOG (1, max_log_level, "GnuTLS library not found"); return 0; @@ -192,7 +186,6 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_alert_get); LOAD_DLL_FN (library, gnutls_alert_get_name); - LOAD_DLL_FN (library, gnutls_alert_send_appropriate); LOAD_DLL_FN (library, gnutls_anon_allocate_client_credentials); LOAD_DLL_FN (library, gnutls_anon_free_client_credentials); LOAD_DLL_FN (library, gnutls_bye); @@ -229,11 +222,6 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_record_send); LOAD_DLL_FN (library, gnutls_strerror); LOAD_DLL_FN (library, gnutls_transport_set_errno); - LOAD_DLL_FN (library, gnutls_check_version); - /* We don't need to call gnutls_transport_set_lowat in GnuTLS 2.11.1 - and later, and the function was removed entirely in 3.0.0. */ - if (!fn_gnutls_check_version ("2.11.1")) - LOAD_DLL_FN (library, gnutls_transport_set_lowat); LOAD_DLL_FN (library, gnutls_transport_set_ptr2); LOAD_DLL_FN (library, gnutls_transport_set_pull_function); LOAD_DLL_FN (library, gnutls_transport_set_push_function); @@ -255,7 +243,6 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_unique_id); LOAD_DLL_FN (library, gnutls_x509_crt_get_subject_unique_id); LOAD_DLL_FN (library, gnutls_x509_crt_get_signature_algorithm); - LOAD_DLL_FN (library, gnutls_x509_crt_get_signature); LOAD_DLL_FN (library, gnutls_x509_crt_get_key_id); LOAD_DLL_FN (library, gnutls_sec_param_get_name); LOAD_DLL_FN (library, gnutls_sign_get_name); @@ -272,7 +259,7 @@ init_gnutls_functions (void) max_log_level = global_gnutls_log_level; { - Lisp_Object name = CAR_SAFE (Fget (Qgnutls_dll, QCloaded_from)); + Lisp_Object name = CAR_SAFE (Fget (Qgnutls, QCloaded_from)); GNUTLS_LOG2 (1, max_log_level, "GnuTLS library loaded:", STRINGP (name) ? (const char *) SDATA (name) : "unknown"); } @@ -282,7 +269,6 @@ init_gnutls_functions (void) # define gnutls_alert_get fn_gnutls_alert_get # define gnutls_alert_get_name fn_gnutls_alert_get_name -# define gnutls_alert_send_appropriate fn_gnutls_alert_send_appropriate # define gnutls_anon_allocate_client_credentials fn_gnutls_anon_allocate_client_credentials # define gnutls_anon_free_client_credentials fn_gnutls_anon_free_client_credentials # define gnutls_bye fn_gnutls_bye @@ -296,7 +282,6 @@ init_gnutls_functions (void) # define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file # define gnutls_certificate_type_get fn_gnutls_certificate_type_get # define gnutls_certificate_verify_peers2 fn_gnutls_certificate_verify_peers2 -# define gnutls_check_version fn_gnutls_check_version # define gnutls_cipher_get fn_gnutls_cipher_get # define gnutls_cipher_get_name fn_gnutls_cipher_get_name # define gnutls_credentials_set fn_gnutls_credentials_set @@ -327,7 +312,6 @@ init_gnutls_functions (void) # define gnutls_sign_get_name fn_gnutls_sign_get_name # define gnutls_strerror fn_gnutls_strerror # define gnutls_transport_set_errno fn_gnutls_transport_set_errno -# define gnutls_transport_set_lowat fn_gnutls_transport_set_lowat # define gnutls_transport_set_ptr2 fn_gnutls_transport_set_ptr2 # define gnutls_transport_set_pull_function fn_gnutls_transport_set_pull_function # define gnutls_transport_set_push_function fn_gnutls_transport_set_push_function @@ -343,7 +327,6 @@ init_gnutls_functions (void) # define gnutls_x509_crt_get_key_id fn_gnutls_x509_crt_get_key_id # define gnutls_x509_crt_get_pk_algorithm fn_gnutls_x509_crt_get_pk_algorithm # define gnutls_x509_crt_get_serial fn_gnutls_x509_crt_get_serial -# define gnutls_x509_crt_get_signature fn_gnutls_x509_crt_get_signature # define gnutls_x509_crt_get_signature_algorithm fn_gnutls_x509_crt_get_signature_algorithm # define gnutls_x509_crt_get_subject_unique_id fn_gnutls_x509_crt_get_subject_unique_id # define gnutls_x509_crt_get_version fn_gnutls_x509_crt_get_version @@ -390,18 +373,72 @@ gnutls_log_function2 (int level, const char *string, const char *extra) message ("gnutls.c: [%d] %s %s", level, string, extra); } -/* Log a message and an integer. */ -static void -gnutls_log_function2i (int level, const char *string, int extra) +int +gnutls_try_handshake (struct Lisp_Process *proc) { - message ("gnutls.c: [%d] %s %d", level, string, extra); + gnutls_session_t state = proc->gnutls_state; + int ret; + bool non_blocking = proc->is_non_blocking_client; + + if (proc->gnutls_complete_negotiation_p) + non_blocking = false; + + if (non_blocking) + proc->gnutls_p = true; + + do + { + ret = gnutls_handshake (state); + emacs_gnutls_handle_error (state, ret); + QUIT; + } + while (ret < 0 + && gnutls_error_is_fatal (ret) == 0 + && ! non_blocking); + + proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED; + + if (ret == GNUTLS_E_SUCCESS) + { + /* Here we're finally done. */ + proc->gnutls_initstage = GNUTLS_STAGE_READY; + } + else + { + /* check_memory_full (gnutls_alert_send_appropriate (state, ret)); */ + } + return ret; } +#ifndef WINDOWSNT +static int +emacs_gnutls_nonblock_errno (gnutls_transport_ptr_t ptr) +{ + int err = errno; + + switch (err) + { +# ifdef _AIX + /* This is taken from the GnuTLS system_errno function circa 2016; + see <http://savannah.gnu.org/support/?107464>. */ + case 0: + errno = EAGAIN; + /* Fall through. */ +# endif + case EINPROGRESS: + case ENOTCONN: + return EAGAIN; + + default: + return err; + } +} +#endif + static int emacs_gnutls_handshake (struct Lisp_Process *proc) { gnutls_session_t state = proc->gnutls_state; - int ret; if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO) return -1; @@ -417,20 +454,6 @@ emacs_gnutls_handshake (struct Lisp_Process *proc) (gnutls_transport_ptr_t) proc); gnutls_transport_set_push_function (state, &emacs_gnutls_push); gnutls_transport_set_pull_function (state, &emacs_gnutls_pull); - - /* For non blocking sockets or other custom made pull/push - functions the gnutls_transport_set_lowat must be called, with - a zero low water mark value. (GnuTLS 2.10.4 documentation) - - (Note: this is probably not strictly necessary as the lowat - value is only used when no custom pull/push functions are - set.) */ - /* According to GnuTLS NEWS file, lowat level has been set to - zero by default in version 2.11.1, and the function - gnutls_transport_set_lowat was removed from the library in - version 2.99.0. */ - if (!gnutls_check_version ("2.11.1")) - gnutls_transport_set_lowat (state, 0); #else /* This is how GnuTLS takes sockets: as file descriptors passed in. For an Emacs process socket, infd and outfd are the @@ -438,31 +461,15 @@ emacs_gnutls_handshake (struct Lisp_Process *proc) gnutls_transport_set_ptr2 (state, (void *) (intptr_t) proc->infd, (void *) (intptr_t) proc->outfd); + if (proc->is_non_blocking_client) + gnutls_transport_set_errno_function (state, + emacs_gnutls_nonblock_errno); #endif proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET; } - do - { - ret = gnutls_handshake (state); - emacs_gnutls_handle_error (state, ret); - QUIT; - } - while (ret < 0 && gnutls_error_is_fatal (ret) == 0); - - proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED; - - if (ret == GNUTLS_E_SUCCESS) - { - /* Here we're finally done. */ - proc->gnutls_initstage = GNUTLS_STAGE_READY; - } - else - { - check_memory_full (gnutls_alert_send_appropriate (state, ret)); - } - return ret; + return gnutls_try_handshake (proc); } ptrdiff_t @@ -528,26 +535,12 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte) ssize_t rtnval; gnutls_session_t state = proc->gnutls_state; - int log_level = proc->gnutls_log_level; - if (proc->gnutls_initstage != GNUTLS_STAGE_READY) { - /* If the handshake count is under the limit, try the handshake - again and increment the handshake count. This count is kept - per process (connection), not globally. */ - if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT) - { - proc->gnutls_handshakes_tried++; - emacs_gnutls_handshake (proc); - GNUTLS_LOG2i (5, log_level, "Retried handshake", - proc->gnutls_handshakes_tried); - return -1; - } - - GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries"); - proc->gnutls_handshakes_tried = 0; - return 0; + errno = EAGAIN; + return -1; } + rtnval = gnutls_record_recv (state, buf, nbyte); if (rtnval >= 0) return rtnval; @@ -655,7 +648,7 @@ emacs_gnutls_deinit (Lisp_Object proc) CHECK_PROCESS (proc); - if (XPROCESS (proc)->gnutls_p == 0) + if (! XPROCESS (proc)->gnutls_p) return Qnil; log_level = XPROCESS (proc)->gnutls_log_level; @@ -682,10 +675,23 @@ emacs_gnutls_deinit (Lisp_Object proc) GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1; } - XPROCESS (proc)->gnutls_p = 0; + XPROCESS (proc)->gnutls_p = false; return Qt; } +DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters, + Sgnutls_asynchronous_parameters, 2, 2, 0, + doc: /* Mark this process as being a pre-init GnuTLS process. +The second parameter is the list of parameters to feed to gnutls-boot +to finish setting up the connection. */) + (Lisp_Object proc, Lisp_Object params) +{ + CHECK_PROCESS (proc); + + XPROCESS (proc)->gnutls_boot_parameters = params; + return Qnil; +} + DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0, doc: /* Return the GnuTLS init stage of process PROC. See also `gnutls-boot'. */) @@ -703,7 +709,9 @@ usage: (gnutls-errorp ERROR) */ attributes: const) (Lisp_Object err) { - if (EQ (err, Qt)) return Qnil; + if (EQ (err, Qt) + || EQ (err, Qgnutls_e_again)) + return Qnil; return Qt; } @@ -874,8 +882,6 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) xfree (dn); } - /* Versions older than 2.11 doesn't have these four functions. */ -#if GNUTLS_VERSION_NUMBER >= 0x020b00 /* SubjectPublicKeyInfo. */ { unsigned int bits; @@ -924,7 +930,6 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) make_string (buf, buf_size))); xfree (buf); } -#endif /* Signature. */ err = gnutls_x509_crt_get_signature_algorithm (cert); @@ -1022,7 +1027,7 @@ The return value is a property list with top-level keys :warnings and CHECK_PROCESS (proc); - if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT) + if (GNUTLS_INITSTAGE (proc) != GNUTLS_STAGE_READY) return Qnil; /* Then collect any warnings already computed by the handshake. */ @@ -1154,6 +1159,160 @@ emacs_gnutls_global_deinit (void) } #endif +static void ATTRIBUTE_FORMAT_PRINTF (2, 3) +boot_error (struct Lisp_Process *p, const char *m, ...) +{ + va_list ap; + va_start (ap, m); + if (p->is_non_blocking_client) + pset_status (p, list2 (Qfailed, vformat_string (m, ap))); + else + verror (m, ap); + va_end (ap); +} + +Lisp_Object +gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) +{ + int ret; + struct Lisp_Process *p = XPROCESS (proc); + gnutls_session_t state = p->gnutls_state; + unsigned int peer_verification; + Lisp_Object warnings; + int max_log_level = p->gnutls_log_level; + Lisp_Object hostname, verify_error; + bool verify_error_all = false; + char *c_hostname; + + if (NILP (proplist)) + proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters)); + + verify_error = Fplist_get (proplist, QCverify_error); + hostname = Fplist_get (proplist, QChostname); + + if (EQ (verify_error, Qt)) + verify_error_all = true; + else if (NILP (Flistp (verify_error))) + { + boot_error (p, + "gnutls-boot: invalid :verify_error parameter (not a list)"); + return Qnil; + } + + if (!STRINGP (hostname)) + { + boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)"); + return Qnil; + } + c_hostname = SSDATA (hostname); + + /* Now verify the peer, following + http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html. + The peer should present at least one certificate in the chain; do a + check of the certificate's hostname with + gnutls_x509_crt_check_hostname against :hostname. */ + + ret = gnutls_certificate_verify_peers2 (state, &peer_verification); + if (ret < GNUTLS_E_SUCCESS) + return gnutls_make_error (ret); + + XPROCESS (proc)->gnutls_peer_verification = peer_verification; + + warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings")); + if (!NILP (warnings)) + { + for (Lisp_Object tail = warnings; CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object warning = XCAR (tail); + Lisp_Object message = Fgnutls_peer_status_warning_describe (warning); + if (!NILP (message)) + GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message)); + } + } + + if (peer_verification != 0) + { + if (verify_error_all + || !NILP (Fmember (QCtrustfiles, verify_error))) + { + emacs_gnutls_deinit (proc); + boot_error (p, + "Certificate validation failed %s, verification code %x", + c_hostname, peer_verification); + return Qnil; + } + else + { + GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:", + c_hostname); + } + } + + /* Up to here the process is the same for X.509 certificates and + OpenPGP keys. From now on X.509 certificates are assumed. This + can be easily extended to work with openpgp keys as well. */ + if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509) + { + gnutls_x509_crt_t gnutls_verify_cert; + const gnutls_datum_t *gnutls_verify_cert_list; + unsigned int gnutls_verify_cert_list_size; + + ret = gnutls_x509_crt_init (&gnutls_verify_cert); + if (ret < GNUTLS_E_SUCCESS) + return gnutls_make_error (ret); + + gnutls_verify_cert_list + = gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size); + + if (gnutls_verify_cert_list == NULL) + { + gnutls_x509_crt_deinit (gnutls_verify_cert); + emacs_gnutls_deinit (proc); + boot_error (p, "No x509 certificate was found\n"); + return Qnil; + } + + /* Check only the first certificate in the given chain. */ + ret = gnutls_x509_crt_import (gnutls_verify_cert, + &gnutls_verify_cert_list[0], + GNUTLS_X509_FMT_DER); + + if (ret < GNUTLS_E_SUCCESS) + { + gnutls_x509_crt_deinit (gnutls_verify_cert); + return gnutls_make_error (ret); + } + + XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert; + + int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert, + c_hostname); + check_memory_full (err); + if (!err) + { + XPROCESS (proc)->gnutls_extra_peer_verification + |= CERTIFICATE_NOT_MATCHING; + if (verify_error_all + || !NILP (Fmember (QChostname, verify_error))) + { + gnutls_x509_crt_deinit (gnutls_verify_cert); + emacs_gnutls_deinit (proc); + boot_error (p, "The x509 certificate does not match \"%s\"", + c_hostname); + return Qnil; + } + else + GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:", + c_hostname); + } + } + + /* Set this flag only if the whole initialization succeeded. */ + XPROCESS (proc)->gnutls_p = true; + + return gnutls_make_error (ret); +} + DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0, doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST. Currently only client mode is supported. Return a success/failure @@ -1190,6 +1349,9 @@ t to do all checks. Currently it can contain `:trustfiles' and :min-prime-bits is the minimum accepted number of bits the client will accept in Diffie-Hellman key exchange. +:complete-negotiation, if non-nil, will make negotiation complete +before returning even on non-blocking sockets. + The debug level will be set for this process AND globally for GnuTLS. So if you set it higher or lower at any point, it affects global debugging. @@ -1212,14 +1374,12 @@ one trustfile (usually a CA bundle). */) { int ret = GNUTLS_E_SUCCESS; int max_log_level = 0; - bool verify_error_all = 0; gnutls_session_t state; gnutls_certificate_credentials_t x509_cred = NULL; gnutls_anon_client_credentials_t anon_cred = NULL; Lisp_Object global_init; char const *priority_string_ptr = "NORMAL"; /* default priority string. */ - unsigned int peer_verification; char *c_hostname; /* Placeholders for the property list elements. */ @@ -1230,40 +1390,38 @@ one trustfile (usually a CA bundle). */) /* Lisp_Object callbacks; */ Lisp_Object loglevel; Lisp_Object hostname; - Lisp_Object verify_error; Lisp_Object prime_bits; - Lisp_Object warnings; + struct Lisp_Process *p = XPROCESS (proc); CHECK_PROCESS (proc); CHECK_SYMBOL (type); CHECK_LIST (proplist); if (NILP (Fgnutls_available_p ())) - error ("GnuTLS not available"); - - if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon)) - error ("Invalid GnuTLS credential type"); - - hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname); - priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority); - trustfiles = Fplist_get (proplist, QCgnutls_bootprop_trustfiles); - keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist); - crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles); - loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel); - verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error); - prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits); - - if (EQ (verify_error, Qt)) { - verify_error_all = 1; + boot_error (p, "GnuTLS not available"); + return Qnil; } - else if (NILP (Flistp (verify_error))) + + if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon)) { - error ("gnutls-boot: invalid :verify_error parameter (not a list)"); + boot_error (p, "Invalid GnuTLS credential type"); + return Qnil; } + hostname = Fplist_get (proplist, QChostname); + priority_string = Fplist_get (proplist, QCpriority); + trustfiles = Fplist_get (proplist, QCtrustfiles); + keylist = Fplist_get (proplist, QCkeylist); + crlfiles = Fplist_get (proplist, QCcrlfiles); + loglevel = Fplist_get (proplist, QCloglevel); + prime_bits = Fplist_get (proplist, QCmin_prime_bits); + if (!STRINGP (hostname)) - error ("gnutls-boot: invalid :hostname parameter (not a string)"); + { + boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)"); + return Qnil; + } c_hostname = SSDATA (hostname); state = XPROCESS (proc)->gnutls_state; @@ -1307,7 +1465,7 @@ one trustfile (usually a CA bundle). */) check_memory_full (gnutls_certificate_allocate_credentials (&x509_cred)); XPROCESS (proc)->gnutls_x509_cred = x509_cred; - verify_flags = Fplist_get (proplist, QCgnutls_bootprop_verify_flags); + verify_flags = Fplist_get (proplist, QCverify_flags); if (NUMBERP (verify_flags)) { gnutls_verify_flags = XINT (verify_flags); @@ -1371,7 +1529,8 @@ one trustfile (usually a CA bundle). */) else { emacs_gnutls_deinit (proc); - error ("Invalid trustfile"); + boot_error (p, "Invalid trustfile"); + return Qnil; } } @@ -1395,7 +1554,8 @@ one trustfile (usually a CA bundle). */) else { emacs_gnutls_deinit (proc); - error ("Invalid CRL file"); + boot_error (p, "Invalid CRL file"); + return Qnil; } } @@ -1424,8 +1584,9 @@ one trustfile (usually a CA bundle). */) else { emacs_gnutls_deinit (proc); - error (STRINGP (keyfile) ? "Invalid client cert file" - : "Invalid client key file"); + boot_error (p, STRINGP (keyfile) ? "Invalid client cert file" + : "Invalid client key file"); + return Qnil; } } } @@ -1437,7 +1598,12 @@ one trustfile (usually a CA bundle). */) /* Call gnutls_init here: */ GNUTLS_LOG (1, max_log_level, "gnutls_init"); - ret = gnutls_init (&state, GNUTLS_CLIENT); + int gnutls_flags = GNUTLS_CLIENT; +#ifdef GNUTLS_NONBLOCK + if (XPROCESS (proc)->is_non_blocking_client) + gnutls_flags |= GNUTLS_NONBLOCK; +#endif + ret = gnutls_init (&state, gnutls_flags); XPROCESS (proc)->gnutls_state = state; if (ret < GNUTLS_E_SUCCESS) return gnutls_make_error (ret); @@ -1479,114 +1645,14 @@ one trustfile (usually a CA bundle). */) return gnutls_make_error (ret); } + XPROCESS (proc)->gnutls_complete_negotiation_p = + !NILP (Fplist_get (proplist, QCcomplete_negotiation)); GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET; ret = emacs_gnutls_handshake (XPROCESS (proc)); if (ret < GNUTLS_E_SUCCESS) return gnutls_make_error (ret); - /* Now verify the peer, following - http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html. - The peer should present at least one certificate in the chain; do a - check of the certificate's hostname with - gnutls_x509_crt_check_hostname against :hostname. */ - - ret = gnutls_certificate_verify_peers2 (state, &peer_verification); - if (ret < GNUTLS_E_SUCCESS) - return gnutls_make_error (ret); - - XPROCESS (proc)->gnutls_peer_verification = peer_verification; - - warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings")); - if (!NILP (warnings)) - { - Lisp_Object tail; - for (tail = warnings; CONSP (tail); tail = XCDR (tail)) - { - Lisp_Object warning = XCAR (tail); - Lisp_Object message = Fgnutls_peer_status_warning_describe (warning); - if (!NILP (message)) - GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message)); - } - } - - if (peer_verification != 0) - { - if (verify_error_all - || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error))) - { - emacs_gnutls_deinit (proc); - error ("Certificate validation failed %s, verification code %x", - c_hostname, peer_verification); - } - else - { - GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:", - c_hostname); - } - } - - /* Up to here the process is the same for X.509 certificates and - OpenPGP keys. From now on X.509 certificates are assumed. This - can be easily extended to work with openpgp keys as well. */ - if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509) - { - gnutls_x509_crt_t gnutls_verify_cert; - const gnutls_datum_t *gnutls_verify_cert_list; - unsigned int gnutls_verify_cert_list_size; - - ret = gnutls_x509_crt_init (&gnutls_verify_cert); - if (ret < GNUTLS_E_SUCCESS) - return gnutls_make_error (ret); - - gnutls_verify_cert_list = - gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size); - - if (gnutls_verify_cert_list == NULL) - { - gnutls_x509_crt_deinit (gnutls_verify_cert); - emacs_gnutls_deinit (proc); - error ("No x509 certificate was found\n"); - } - - /* We only check the first certificate in the given chain. */ - ret = gnutls_x509_crt_import (gnutls_verify_cert, - &gnutls_verify_cert_list[0], - GNUTLS_X509_FMT_DER); - - if (ret < GNUTLS_E_SUCCESS) - { - gnutls_x509_crt_deinit (gnutls_verify_cert); - return gnutls_make_error (ret); - } - - XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert; - - int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert, - c_hostname); - check_memory_full (err); - if (!err) - { - XPROCESS (proc)->gnutls_extra_peer_verification |= - CERTIFICATE_NOT_MATCHING; - if (verify_error_all - || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error))) - { - gnutls_x509_crt_deinit (gnutls_verify_cert); - emacs_gnutls_deinit (proc); - error ("The x509 certificate does not match \"%s\"", c_hostname); - } - else - { - GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:", - c_hostname); - } - } - } - - /* Set this flag only if the whole initialization succeeded. */ - XPROCESS (proc)->gnutls_p = 1; - - return gnutls_make_error (ret); + return gnutls_verify_boot (proc, proplist); } DEFUN ("gnutls-bye", Fgnutls_bye, @@ -1627,14 +1693,14 @@ DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0, { #ifdef HAVE_GNUTLS # ifdef WINDOWSNT - Lisp_Object found = Fassq (Qgnutls_dll, Vlibrary_cache); + Lisp_Object found = Fassq (Qgnutls, Vlibrary_cache); if (CONSP (found)) return XCDR (found); else { Lisp_Object status; status = init_gnutls_functions () ? Qt : Qnil; - Vlibrary_cache = Fcons (Fcons (Qgnutls_dll, status), Vlibrary_cache); + Vlibrary_cache = Fcons (Fcons (Qgnutls, status), Vlibrary_cache); return status; } # else /* !WINDOWSNT */ @@ -1666,15 +1732,16 @@ syms_of_gnutls (void) DEFSYM (Qgnutls_x509pki, "gnutls-x509pki"); /* The following are for the property list of 'gnutls-boot'. */ - DEFSYM (QCgnutls_bootprop_hostname, ":hostname"); - DEFSYM (QCgnutls_bootprop_priority, ":priority"); - DEFSYM (QCgnutls_bootprop_trustfiles, ":trustfiles"); - DEFSYM (QCgnutls_bootprop_keylist, ":keylist"); - DEFSYM (QCgnutls_bootprop_crlfiles, ":crlfiles"); - DEFSYM (QCgnutls_bootprop_min_prime_bits, ":min-prime-bits"); - DEFSYM (QCgnutls_bootprop_loglevel, ":loglevel"); - DEFSYM (QCgnutls_bootprop_verify_flags, ":verify-flags"); - DEFSYM (QCgnutls_bootprop_verify_error, ":verify-error"); + DEFSYM (QChostname, ":hostname"); + DEFSYM (QCpriority, ":priority"); + DEFSYM (QCtrustfiles, ":trustfiles"); + DEFSYM (QCkeylist, ":keylist"); + DEFSYM (QCcrlfiles, ":crlfiles"); + DEFSYM (QCmin_prime_bits, ":min-prime-bits"); + DEFSYM (QCloglevel, ":loglevel"); + DEFSYM (QCcomplete_negotiation, ":complete-negotiation"); + DEFSYM (QCverify_flags, ":verify-flags"); + DEFSYM (QCverify_error, ":verify-error"); DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted"); Fput (Qgnutls_e_interrupted, Qgnutls_code, @@ -1693,6 +1760,7 @@ syms_of_gnutls (void) make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); defsubr (&Sgnutls_get_initstage); + defsubr (&Sgnutls_asynchronous_parameters); defsubr (&Sgnutls_errorp); defsubr (&Sgnutls_error_fatalp); defsubr (&Sgnutls_error_string); diff --git a/src/gnutls.h b/src/gnutls.h index e9348e7423e..41769a47f54 100644 --- a/src/gnutls.h +++ b/src/gnutls.h @@ -25,8 +25,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "lisp.h" -/* This limits the attempts to handshake per process (connection). */ -#define GNUTLS_EMACS_HANDSHAKES_LIMIT 100 +/* This limits the attempts to handshake per process (connection). It + should work out to about one minute in asynchronous cases. */ +#define GNUTLS_EMACS_HANDSHAKES_LIMIT 6000 typedef enum { @@ -70,7 +71,7 @@ typedef enum #define GNUTLS_LOG2i(level, max, string, extra) \ do { \ if ((level) <= (max)) \ - gnutls_log_function2i (level, "(Emacs) " string, extra); \ + message ("gnutls.c: [%d] %s %d", level, string, extra); \ } while (false) extern ptrdiff_t @@ -84,6 +85,8 @@ extern void emacs_gnutls_transport_set_errno (gnutls_session_t state, int err); #endif extern Lisp_Object emacs_gnutls_deinit (Lisp_Object); extern Lisp_Object emacs_gnutls_global_init (void); +extern int gnutls_try_handshake (struct Lisp_Process *p); +extern Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist); #endif diff --git a/src/gtkutil.c b/src/gtkutil.c index e323216bb79..3d35a3dee81 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -48,6 +48,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "emacsgtkfixed.h" #endif +#ifdef HAVE_XDBE +#include <X11/extensions/Xdbe.h> +#endif + #ifndef HAVE_GTK_WIDGET_SET_HAS_WINDOW #define gtk_widget_set_has_window(w, b) \ (gtk_fixed_set_has_window (GTK_FIXED (w), b)) @@ -143,6 +147,8 @@ struct xg_frame_tb_info GtkTextDirection dir; }; +static GtkWidget * xg_get_widget_from_map (ptrdiff_t idx); + /*********************************************************************** Display handling functions @@ -815,12 +821,6 @@ xg_clear_under_internal_border (struct frame *f) { if (FRAME_INTERNAL_BORDER_WIDTH (f) > 0) { -#ifndef USE_CAIRO - GtkWidget *wfixed = f->output_data.x->edit_widget; - - gtk_widget_queue_draw (wfixed); - gdk_window_process_all_updates (); -#endif x_clear_area (f, 0, 0, FRAME_PIXEL_WIDTH (f), FRAME_INTERNAL_BORDER_WIDTH (f)); @@ -1233,6 +1233,7 @@ xg_create_frame_widgets (struct frame *f) by callers of this function. */ gtk_widget_realize (wfixed); FRAME_X_WINDOW (f) = GTK_WIDGET_TO_X_WIN (wfixed); + initial_set_up_x_back_buffer (f); /* Since GTK clears its window by filling with the background color, we must keep X and GTK background in sync. */ @@ -1296,8 +1297,11 @@ xg_free_frame_widgets (struct frame *f) if (tbinfo) xfree (tbinfo); + /* x_free_frame_resources should have taken care of it */ + eassert (!FRAME_X_DOUBLE_BUFFERED_P (f)); gtk_widget_destroy (FRAME_GTK_OUTER_WIDGET (f)); FRAME_X_WINDOW (f) = 0; /* Set to avoid XDestroyWindow in xterm.c */ + FRAME_X_RAW_DRAWABLE (f) = 0; FRAME_GTK_OUTER_WIDGET (f) = 0; #ifdef USE_GTK_TOOLTIP if (x->ttip_lbl) @@ -1440,6 +1444,18 @@ xg_set_background_color (struct frame *f, unsigned long bg) { block_input (); xg_set_widget_bg (f, FRAME_GTK_WIDGET (f), FRAME_BACKGROUND_PIXEL (f)); + + Lisp_Object bar; + for (bar = FRAME_SCROLL_BARS (f); + !NILP (bar); + bar = XSCROLL_BAR (bar)->next) + { + GtkWidget *scrollbar = + xg_get_widget_from_map (XSCROLL_BAR (bar)->x_window); + GtkWidget *webox = gtk_widget_get_parent (scrollbar); + xg_set_widget_bg (f, webox, FRAME_BACKGROUND_PIXEL (f)); + } + unblock_input (); } } @@ -1829,7 +1845,8 @@ xg_get_file_with_chooser (struct frame *f, { char msgbuf[1024]; - GtkWidget *filewin, *wtoggle, *wbox, *wmessage IF_LINT (= NULL); + GtkWidget *filewin, *wtoggle, *wbox; + GtkWidget *wmessage UNINIT; GtkWindow *gwin = GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)); GtkFileChooserAction action = (mustmatch_p ? GTK_FILE_CHOOSER_ACTION_OPEN : @@ -2264,7 +2281,6 @@ xg_mark_data (void) } } - /* Callback called when a menu item is destroyed. Used to free data. W is the widget that is being destroyed (not used). CLIENT_DATA points to the xg_menu_item_cb_data associated with the W. */ @@ -3568,44 +3584,23 @@ xg_gtk_scroll_destroy (GtkWidget *widget, gpointer data) xg_remove_widget_from_map (id); } -/* Create a scroll bar widget for frame F. Store the scroll bar - in BAR. - SCROLL_CALLBACK is the callback to invoke when the value of the - bar changes. - END_CALLBACK is the callback to invoke when scrolling ends. - SCROLL_BAR_NAME is the name we use for the scroll bar. Can be used - to set resources for the widget. */ - -void -xg_create_scroll_bar (struct frame *f, - struct scroll_bar *bar, - GCallback scroll_callback, - GCallback end_callback, - const char *scroll_bar_name) +static void +xg_finish_scroll_bar_creation (struct frame *f, + GtkWidget *wscroll, + struct scroll_bar *bar, + GCallback scroll_callback, + GCallback end_callback, + const char *scroll_bar_name) { - GtkWidget *wscroll; - GtkWidget *webox; - intptr_t scroll_id; -#ifdef HAVE_GTK3 - GtkAdjustment *vadj; -#else - GtkObject *vadj; -#endif + GtkWidget *webox = gtk_event_box_new (); - /* Page, step increment values are not so important here, they - will be corrected in x_set_toolkit_scroll_bar_thumb. */ - vadj = gtk_adjustment_new (XG_SB_MIN, XG_SB_MIN, XG_SB_MAX, - 0.1, 0.1, 0.1); - - wscroll = gtk_scrollbar_new (GTK_ORIENTATION_VERTICAL, GTK_ADJUSTMENT (vadj)); - webox = gtk_event_box_new (); gtk_widget_set_name (wscroll, scroll_bar_name); #ifndef HAVE_GTK3 gtk_range_set_update_policy (GTK_RANGE (wscroll), GTK_UPDATE_CONTINUOUS); #endif g_object_set_data (G_OBJECT (wscroll), XG_FRAME_DATA, (gpointer)f); - scroll_id = xg_store_widget_in_map (wscroll); + ptrdiff_t scroll_id = xg_store_widget_in_map (wscroll); g_signal_connect (G_OBJECT (wscroll), "destroy", @@ -3629,11 +3624,52 @@ xg_create_scroll_bar (struct frame *f, gtk_fixed_put (GTK_FIXED (f->output_data.x->edit_widget), webox, -1, -1); gtk_container_add (GTK_CONTAINER (webox), wscroll); + xg_set_widget_bg (f, webox, FRAME_BACKGROUND_PIXEL (f)); + + /* N.B. The event box doesn't become a real X11 window until we ask + for its XID via GTK_WIDGET_TO_X_WIN. If the event box is not a + real X window, it and its scroll-bar child try to draw on the + Emacs main window, which we draw over using Xlib. */ + gtk_widget_realize (webox); + GTK_WIDGET_TO_X_WIN (webox); /* Set the cursor to an arrow. */ xg_set_cursor (webox, FRAME_DISPLAY_INFO (f)->xg_cursor); bar->x_window = scroll_id; +} + +/* Create a scroll bar widget for frame F. Store the scroll bar + in BAR. + SCROLL_CALLBACK is the callback to invoke when the value of the + bar changes. + END_CALLBACK is the callback to invoke when scrolling ends. + SCROLL_BAR_NAME is the name we use for the scroll bar. Can be used + to set resources for the widget. */ + +void +xg_create_scroll_bar (struct frame *f, + struct scroll_bar *bar, + GCallback scroll_callback, + GCallback end_callback, + const char *scroll_bar_name) +{ + GtkWidget *wscroll; +#ifdef HAVE_GTK3 + GtkAdjustment *vadj; +#else + GtkObject *vadj; +#endif + + /* Page, step increment values are not so important here, they + will be corrected in x_set_toolkit_scroll_bar_thumb. */ + vadj = gtk_adjustment_new (XG_SB_MIN, XG_SB_MIN, XG_SB_MAX, + 0.1, 0.1, 0.1); + + wscroll = gtk_scrollbar_new (GTK_ORIENTATION_VERTICAL, GTK_ADJUSTMENT (vadj)); + + xg_finish_scroll_bar_creation (f, wscroll, bar, scroll_callback, + end_callback, scroll_bar_name); bar->horizontal = 0; } @@ -3651,8 +3687,6 @@ xg_create_horizontal_scroll_bar (struct frame *f, const char *scroll_bar_name) { GtkWidget *wscroll; - GtkWidget *webox; - intptr_t scroll_id; #ifdef HAVE_GTK3 GtkAdjustment *hadj; #else @@ -3665,42 +3699,9 @@ xg_create_horizontal_scroll_bar (struct frame *f, 0.1, 0.1, 0.1); wscroll = gtk_scrollbar_new (GTK_ORIENTATION_HORIZONTAL, GTK_ADJUSTMENT (hadj)); - webox = gtk_event_box_new (); - gtk_widget_set_name (wscroll, scroll_bar_name); -#ifndef HAVE_GTK3 - gtk_range_set_update_policy (GTK_RANGE (wscroll), GTK_UPDATE_CONTINUOUS); -#endif - g_object_set_data (G_OBJECT (wscroll), XG_FRAME_DATA, (gpointer)f); - - scroll_id = xg_store_widget_in_map (wscroll); - - g_signal_connect (G_OBJECT (wscroll), - "destroy", - G_CALLBACK (xg_gtk_scroll_destroy), - (gpointer) scroll_id); - g_signal_connect (G_OBJECT (wscroll), - "change-value", - scroll_callback, - (gpointer) bar); - g_signal_connect (G_OBJECT (wscroll), - "button-release-event", - end_callback, - (gpointer) bar); - - /* The scroll bar widget does not draw on a window of its own. Instead - it draws on the parent window, in this case the edit widget. So - whenever the edit widget is cleared, the scroll bar needs to redraw - also, which causes flicker. Put an event box between the edit widget - and the scroll bar, so the scroll bar instead draws itself on the - event box window. */ - gtk_fixed_put (GTK_FIXED (f->output_data.x->edit_widget), webox, -1, -1); - gtk_container_add (GTK_CONTAINER (webox), wscroll); - - /* Set the cursor to an arrow. */ - xg_set_cursor (webox, FRAME_DISPLAY_INFO (f)->xg_cursor); - - bar->x_window = scroll_id; + xg_finish_scroll_bar_creation (f, wscroll, bar, scroll_callback, + end_callback, scroll_bar_name); bar->horizontal = 1; } @@ -3769,16 +3770,10 @@ xg_update_scrollbar_pos (struct frame *f, gtk_widget_show_all (wparent); gtk_widget_set_size_request (wscroll, width, height); } -#ifndef USE_CAIRO - gtk_widget_queue_draw (wfixed); - gdk_window_process_all_updates (); -#endif if (oldx != -1 && oldw > 0 && oldh > 0) { - /* Clear under old scroll bar position. This must be done after - the gtk_widget_queue_draw and gdk_window_process_all_updates - above. */ - oldw += (scale - 1) * oldw; + /* Clear under old scroll bar position. */ + oldw += (scale - 1) * oldw; oldx -= (scale - 1) * oldw; x_clear_area (f, oldx, oldy, oldw, oldh); } @@ -3840,14 +3835,9 @@ xg_update_horizontal_scrollbar_pos (struct frame *f, gtk_widget_show_all (wparent); gtk_widget_set_size_request (wscroll, width, height); } - gtk_widget_queue_draw (wfixed); - gdk_window_process_all_updates (); if (oldx != -1 && oldw > 0 && oldh > 0) - /* Clear under old scroll bar position. This must be done after - the gtk_widget_queue_draw and gdk_window_process_all_updates - above. */ - x_clear_area (f, - oldx, oldy, oldw, oldh); + /* Clear under old scroll bar position. */ + x_clear_area (f, oldx, oldy, oldw, oldh); /* GTK does not redraw until the main loop is entered again, but if there are no X events pending we will not enter it. So we sync diff --git a/src/image.c b/src/image.c index 6a62235673a..45010e7e2bc 100644 --- a/src/image.c +++ b/src/image.c @@ -30,10 +30,13 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #endif #include <setjmp.h> + #include <c-ctype.h> +#include <flexmember.h> #include "lisp.h" #include "frame.h" +#include "process.h" #include "window.h" #include "buffer.h" #include "dispextern.h" @@ -56,6 +59,11 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ +/* Work around GCC bug 54561. */ +#if GNUC_PREREQ (4, 3, 0) +# pragma GCC diagnostic ignored "-Wclobbered" +#endif + #ifdef HAVE_X_WINDOWS typedef struct x_bitmap_record Bitmap_Record; #define GET_PIXEL(ximg, x, y) XGetPixel (ximg, x, y) @@ -80,7 +88,6 @@ typedef struct w32_bitmap_record Bitmap_Record; #define PIX_MASK_DRAW 1 #define x_defined_color w32_defined_color -#define DefaultDepthOfScreen(screen) (one_w32_display_info.n_cbits) #endif /* HAVE_NTGUI */ @@ -91,11 +98,9 @@ typedef struct ns_bitmap_record Bitmap_Record; #define NO_PIXMAP 0 #define PIX_MASK_RETAIN 0 -#define PIX_MASK_DRAW 1 #define x_defined_color(f, name, color_def, alloc) \ ns_defined_color (f, name, color_def, alloc, 0) -#define DefaultDepthOfScreen(screen) x_display_list->n_planes #endif /* HAVE_NS */ #if (defined HAVE_X_WINDOWS \ @@ -216,13 +221,14 @@ x_create_bitmap_from_data (struct frame *f, char *bits, unsigned int width, unsi #ifdef HAVE_X_WINDOWS Pixmap bitmap; - bitmap = XCreateBitmapFromData (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + bitmap = XCreateBitmapFromData (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), bits, width, height); if (! bitmap) return -1; #endif /* HAVE_X_WINDOWS */ #ifdef HAVE_NTGUI + Lisp_Object frame UNINIT; /* The value is not used. */ Pixmap bitmap; bitmap = CreateBitmap (width, height, FRAME_DISPLAY_INFO (XFRAME (frame))->n_planes, @@ -270,11 +276,11 @@ x_create_bitmap_from_data (struct frame *f, char *bits, unsigned int width, unsi ptrdiff_t x_create_bitmap_from_file (struct frame *f, Lisp_Object file) { - Display_Info *dpyinfo = FRAME_DISPLAY_INFO (f); - #ifdef HAVE_NTGUI return -1; /* W32_TODO : bitmap support */ -#endif /* HAVE_NTGUI */ +#else + Display_Info *dpyinfo = FRAME_DISPLAY_INFO (f); +#endif #ifdef HAVE_NS ptrdiff_t id; @@ -322,7 +328,7 @@ x_create_bitmap_from_file (struct frame *f, Lisp_Object file) filename = SSDATA (found); - result = XReadBitmapFile (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + result = XReadBitmapFile (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), filename, &width, &height, &bitmap, &xhot, &yhot); if (result != BitmapSuccess) return -1; @@ -788,7 +794,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, case IMAGE_FUNCTION_VALUE: value = indirect_function (value); - if (!NILP (Ffunctionp (value))) + if (FUNCTIONP (value)) break; return 0; @@ -1091,8 +1097,8 @@ image_ascent (struct image *img, struct face *face, struct glyph_slice *slice) static uint32_t xcolor_to_argb32 (XColor xc) { - return (0xff << 24) | ((xc.red / 256) << 16) - | ((xc.green / 256) << 8) | (xc.blue / 256); + return ((0xffu << 24) | ((xc.red / 256) << 16) + | ((xc.green / 256) << 8) | (xc.blue / 256)); } static uint32_t @@ -1142,7 +1148,8 @@ static RGB_PIXEL_COLOR four_corners_best (XImagePtr_or_DC ximg, int *corners, unsigned long width, unsigned long height) { - RGB_PIXEL_COLOR corner_pixels[4], best IF_LINT (= 0); + RGB_PIXEL_COLOR corner_pixels[4]; + RGB_PIXEL_COLOR best UNINIT; int i, best_count; if (corners && corners[BOT_CORNER] >= 0) @@ -1946,7 +1953,7 @@ x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth, { #ifdef HAVE_X_WINDOWS Display *display = FRAME_X_DISPLAY (f); - Window window = FRAME_X_WINDOW (f); + Drawable drawable = FRAME_X_DRAWABLE (f); Screen *screen = FRAME_X_SCREEN (f); eassert (input_blocked_p ()); @@ -1975,7 +1982,7 @@ x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth, (*ximg)->data = xmalloc ((*ximg)->bytes_per_line * height); /* Allocate a pixmap of the same size. */ - *pixmap = XCreatePixmap (display, window, width, height, depth); + *pixmap = XCreatePixmap (display, drawable, width, height, depth); if (*pixmap == NO_PIXMAP) { x_destroy_x_image (*ximg); @@ -2300,7 +2307,7 @@ x_find_image_fd (Lisp_Object file, int *pfd) happens, e.g., under Auto Image File Mode.) 'openp' didn't open the file, so we should, because the caller expects that. */ - fd = emacs_open (SSDATA (file_found), O_RDONLY | O_BINARY, 0); + fd = emacs_open (SSDATA (file_found), O_RDONLY, 0); } } else /* fd < 0, but not -2 */ @@ -2325,12 +2332,12 @@ x_find_image_file (Lisp_Object file) occurred. FD is a file descriptor open for reading FILE. Set *SIZE to the size of the file. */ -static unsigned char * +static char * slurp_file (int fd, ptrdiff_t *size) { FILE *fp = fdopen (fd, "rb"); - unsigned char *buf = NULL; + char *buf = NULL; struct stat st; if (fp) @@ -2517,7 +2524,7 @@ xbm_image_p (Lisp_Object object) if (STRINGP (elt)) { if (SCHARS (elt) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR) + < (width + CHAR_BIT - 1) / CHAR_BIT) return 0; } else if (BOOL_VECTOR_P (elt)) @@ -2532,7 +2539,7 @@ xbm_image_p (Lisp_Object object) else if (STRINGP (data)) { if (SCHARS (data) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height) + < (width + CHAR_BIT - 1) / CHAR_BIT * height) return 0; } else if (BOOL_VECTOR_P (data)) @@ -2555,9 +2562,9 @@ xbm_image_p (Lisp_Object object) scanning a number, store its value in *IVAL. */ static int -xbm_scan (unsigned char **s, unsigned char *end, char *sval, int *ival) +xbm_scan (char **s, char *end, char *sval, int *ival) { - unsigned int c; + unsigned char c; loop: @@ -2609,7 +2616,7 @@ xbm_scan (unsigned char **s, unsigned char *end, char *sval, int *ival) if (*s < end) *s = *s - 1; *ival = value; - c = XBM_TK_NUMBER; + return XBM_TK_NUMBER; } else if (c_isalpha (c) || c == '_') { @@ -2620,7 +2627,7 @@ xbm_scan (unsigned char **s, unsigned char *end, char *sval, int *ival) *sval = 0; if (*s < end) *s = *s - 1; - c = XBM_TK_IDENT; + return XBM_TK_IDENT; } else if (c == '/' && **s == '*') { @@ -2736,7 +2743,7 @@ Create_Pixmap_From_Bitmap_Data (struct frame *f, struct image *img, char *data, img->pixmap = (x_check_image_size (0, img->width, img->height) ? XCreatePixmapFromBitmapData (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), + FRAME_X_DRAWABLE (f), data, img->width, img->height, fg, bg, @@ -2757,11 +2764,11 @@ Create_Pixmap_From_Bitmap_Data (struct frame *f, struct image *img, char *data, bitmap remains unread). */ static bool -xbm_read_bitmap_data (struct frame *f, unsigned char *contents, unsigned char *end, +xbm_read_bitmap_data (struct frame *f, char *contents, char *end, int *width, int *height, char **data, bool inhibit_image_error) { - unsigned char *s = contents; + char *s = contents; char buffer[BUFSIZ]; bool padding_p = 0; bool v10 = 0; @@ -2918,8 +2925,7 @@ xbm_read_bitmap_data (struct frame *f, unsigned char *contents, unsigned char *e successful. */ static bool -xbm_load_image (struct frame *f, struct image *img, unsigned char *contents, - unsigned char *end) +xbm_load_image (struct frame *f, struct image *img, char *contents, char *end) { bool rc; char *data; @@ -2979,8 +2985,8 @@ xbm_file_p (Lisp_Object data) { int w, h; return (STRINGP (data) - && xbm_read_bitmap_data (NULL, SDATA (data), - (SDATA (data) + SBYTES (data)), + && xbm_read_bitmap_data (NULL, SSDATA (data), + SSDATA (data) + SBYTES (data), &w, &h, NULL, 1)); } @@ -3009,7 +3015,7 @@ xbm_load (struct frame *f, struct image *img) } ptrdiff_t size; - unsigned char *contents = slurp_file (fd, &size); + char *contents = slurp_file (fd, &size); if (contents == NULL) { image_error ("Error loading XBM image `%s'", file); @@ -3070,9 +3076,8 @@ xbm_load (struct frame *f, struct image *img) } if (in_memory_file_p) - success_p = xbm_load_image (f, img, SDATA (data), - (SDATA (data) - + SBYTES (data))); + success_p = xbm_load_image (f, img, SSDATA (data), + SSDATA (data) + SBYTES (data)); else { USE_SAFE_ALLOCA; @@ -3081,7 +3086,7 @@ xbm_load (struct frame *f, struct image *img) { int i; char *p; - int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR; + int nbytes = (img->width + CHAR_BIT - 1) / CHAR_BIT; SAFE_NALLOCA (bits, nbytes, img->height); p = bits; @@ -3105,7 +3110,7 @@ xbm_load (struct frame *f, struct image *img) int nbytes, i; /* Windows mono bitmaps are reversed compared with X. */ invertedBits = bits; - nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR; + nbytes = (img->width + CHAR_BIT - 1) / CHAR_BIT; SAFE_NALLOCA (bits, nbytes, img->height); for (i = 0; i < nbytes; i++) bits[i] = XBM_BIT_SHUFFLE (invertedBits[i]); @@ -3158,16 +3163,18 @@ static bool xpm_load (struct frame *f, struct image *img); #define XColor xpm_XColor #define XImage xpm_XImage #define Display xpm_Display -#define PIXEL_ALREADY_TYPEDEFED +#ifdef CYGWIN +#include "noX/xpm.h" +#else /* not CYGWIN */ #include "X11/xpm.h" +#endif /* not CYGWIN */ #undef FOR_MSW #undef XColor #undef XImage #undef Display -#undef PIXEL_ALREADY_TYPEDEFED -#else +#else /* not HAVE_NTGUI */ #include "X11/xpm.h" -#endif /* HAVE_NTGUI */ +#endif /* not HAVE_NTGUI */ #endif /* HAVE_XPM */ #if defined (HAVE_XPM) || defined (HAVE_NS) @@ -3339,7 +3346,7 @@ xpm_cache_color (struct frame *f, char *color_name, XColor *color, int bucket) if (bucket < 0) bucket = xpm_color_bucket (color_name); - nbytes = offsetof (struct xpm_cached_color, name) + strlen (color_name) + 1; + nbytes = FLEXSIZEOF (struct xpm_cached_color, name, strlen (color_name) + 1); p = xmalloc (nbytes); strcpy (p->name, color_name); p->color = *color; @@ -3514,7 +3521,7 @@ x_create_bitmap_from_xpm_data (struct frame *f, const char **bits) xpm_init_color_cache (f, &attrs); #endif - rc = XpmCreatePixmapFromData (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + rc = XpmCreatePixmapFromData (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), (char **) bits, &bitmap, &mask, &attrs); if (rc != XpmSuccess) { @@ -3677,7 +3684,7 @@ xpm_load (struct frame *f, struct image *img) #endif /* XpmReadFileToPixmap is not available in the Windows port of libxpm. But XpmReadFileToImage almost does what we want. */ - rc = XpmReadFileToImage (&hdc, SDATA (file), + rc = XpmReadFileToImage (&hdc, SSDATA (file), &xpm_image, &xpm_mask, &attrs); #else @@ -3701,7 +3708,7 @@ xpm_load (struct frame *f, struct image *img) #ifdef HAVE_NTGUI /* XpmCreatePixmapFromBuffer is not available in the Windows port of libxpm. But XpmCreateImageFromBuffer almost does what we want. */ - rc = XpmCreateImageFromBuffer (&hdc, SDATA (buffer), + rc = XpmCreateImageFromBuffer (&hdc, SSDATA (buffer), &xpm_image, &xpm_mask, &attrs); #else @@ -3720,10 +3727,10 @@ xpm_load (struct frame *f, struct image *img) { int width = img->ximg->width; int height = img->ximg->height; - unsigned char *data = (unsigned char *) xmalloc (width*height*4); + void *data = xmalloc (width * height * 4); int i; - uint32_t *od = (uint32_t *)data; - uint32_t *id = (uint32_t *)img->ximg->data; + uint32_t *od = data; + uint32_t *id = (uint32_t *) img->ximg->data; char *mid = img->mask_img ? img->mask_img->data : 0; uint32_t bgcolor = get_spec_bg_or_alpha_as_argb (img, f); @@ -3752,7 +3759,7 @@ xpm_load (struct frame *f, struct image *img) #ifdef HAVE_X_WINDOWS if (rc == XpmSuccess) { - img->pixmap = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + img->pixmap = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), img->ximg->width, img->ximg->height, img->ximg->depth); if (img->pixmap == NO_PIXMAP) @@ -3762,7 +3769,7 @@ xpm_load (struct frame *f, struct image *img) } else if (img->mask_img) { - img->mask = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + img->mask = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), img->mask_img->width, img->mask_img->height, img->mask_img->depth); @@ -3884,14 +3891,12 @@ xpm_load (struct frame *f, struct image *img) /* XPM support functions for NS where libxpm is not available. Only XPM version 3 (without any extensions) is supported. */ -static void xpm_put_color_table_v (Lisp_Object, const unsigned char *, +static void xpm_put_color_table_v (Lisp_Object, const char *, int, Lisp_Object); -static Lisp_Object xpm_get_color_table_v (Lisp_Object, - const unsigned char *, int); -static void xpm_put_color_table_h (Lisp_Object, const unsigned char *, +static Lisp_Object xpm_get_color_table_v (Lisp_Object, const char *, int); +static void xpm_put_color_table_h (Lisp_Object, const char *, int, Lisp_Object); -static Lisp_Object xpm_get_color_table_h (Lisp_Object, - const unsigned char *, int); +static Lisp_Object xpm_get_color_table_h (Lisp_Object, const char *, int); /* Tokens returned from xpm_scan. */ @@ -3910,12 +3915,9 @@ enum xpm_token length of the corresponding token, respectively. */ static int -xpm_scan (const unsigned char **s, - const unsigned char *end, - const unsigned char **beg, - ptrdiff_t *len) +xpm_scan (const char **s, const char *end, const char **beg, ptrdiff_t *len) { - int c; + unsigned char c; while (*s < end) { @@ -3978,12 +3980,9 @@ xpm_scan (const unsigned char **s, hash table is used. */ static Lisp_Object -xpm_make_color_table_v (void (**put_func) (Lisp_Object, - const unsigned char *, - int, +xpm_make_color_table_v (void (**put_func) (Lisp_Object, const char *, int, Lisp_Object), - Lisp_Object (**get_func) (Lisp_Object, - const unsigned char *, + Lisp_Object (**get_func) (Lisp_Object, const char *, int)) { *put_func = xpm_put_color_table_v; @@ -3993,28 +3992,27 @@ xpm_make_color_table_v (void (**put_func) (Lisp_Object, static void xpm_put_color_table_v (Lisp_Object color_table, - const unsigned char *chars_start, + const char *chars_start, int chars_len, Lisp_Object color) { - ASET (color_table, *chars_start, color); + unsigned char uc = *chars_start; + ASET (color_table, uc, color); } static Lisp_Object xpm_get_color_table_v (Lisp_Object color_table, - const unsigned char *chars_start, + const char *chars_start, int chars_len) { - return AREF (color_table, *chars_start); + unsigned char uc = *chars_start; + return AREF (color_table, uc); } static Lisp_Object -xpm_make_color_table_h (void (**put_func) (Lisp_Object, - const unsigned char *, - int, +xpm_make_color_table_h (void (**put_func) (Lisp_Object, const char *, int, Lisp_Object), - Lisp_Object (**get_func) (Lisp_Object, - const unsigned char *, + Lisp_Object (**get_func) (Lisp_Object, const char *, int)) { *put_func = xpm_put_color_table_h; @@ -4027,7 +4025,7 @@ xpm_make_color_table_h (void (**put_func) (Lisp_Object, static void xpm_put_color_table_h (Lisp_Object color_table, - const unsigned char *chars_start, + const char *chars_start, int chars_len, Lisp_Object color) { @@ -4041,7 +4039,7 @@ xpm_put_color_table_h (Lisp_Object color_table, static Lisp_Object xpm_get_color_table_h (Lisp_Object color_table, - const unsigned char *chars_start, + const char *chars_start, int chars_len) { struct Lisp_Hash_Table *table = XHASH_TABLE (color_table); @@ -4075,20 +4073,22 @@ xpm_str_to_color_key (const char *s) static bool xpm_load_image (struct frame *f, struct image *img, - const unsigned char *contents, - const unsigned char *end) + const char *contents, + const char *end) { - const unsigned char *s = contents, *beg, *str; - unsigned char buffer[BUFSIZ]; + const char *s = contents, *beg, *str; + char buffer[BUFSIZ]; int width, height, x, y; int num_colors, chars_per_pixel; ptrdiff_t len; int LA1; - void (*put_color_table) (Lisp_Object, const unsigned char *, int, Lisp_Object); - Lisp_Object (*get_color_table) (Lisp_Object, const unsigned char *, int); + void (*put_color_table) (Lisp_Object, const char *, int, Lisp_Object); + Lisp_Object (*get_color_table) (Lisp_Object, const char *, int); Lisp_Object frame, color_symbols, color_table; int best_key; +#ifndef HAVE_NS bool have_mask = false; +#endif XImagePtr ximg = NULL, mask_img = NULL; #define match() \ @@ -4327,7 +4327,7 @@ xpm_load (struct frame *f, } ptrdiff_t size; - unsigned char *contents = slurp_file (fd, &size); + char *contents = slurp_file (fd, &size); if (contents == NULL) { image_error ("Error loading XPM image `%s'", file); @@ -4347,8 +4347,8 @@ xpm_load (struct frame *f, image_error ("Invalid image data `%s'", data); return 0; } - success_p = xpm_load_image (f, img, SDATA (data), - SDATA (data) + SBYTES (data)); + success_p = xpm_load_image (f, img, SSDATA (data), + SSDATA (data) + SBYTES (data)); } return success_p; @@ -5041,13 +5041,13 @@ static void x_build_heuristic_mask (struct frame *f, struct image *img, Lisp_Object how) { XImagePtr_or_DC ximg; -#ifndef HAVE_NTGUI - XImagePtr mask_img; -#else +#ifdef HAVE_NTGUI HGDIOBJ prev; char *mask_img; int row_width; -#endif /* HAVE_NTGUI */ +#elif !defined HAVE_NS + XImagePtr mask_img; +#endif int x, y; bool use_img_background; unsigned long bg = 0; @@ -5222,20 +5222,22 @@ pbm_image_p (Lisp_Object object) end of input. */ static int -pbm_next_char (unsigned char **s, unsigned char *end) +pbm_next_char (char **s, char *end) { - int c = -1; - - while (*s < end && (c = *(*s)++, c == '#')) + while (*s < end) { - /* Skip to the next line break. */ - while (*s < end && (c = *(*s)++, c != '\n' && c != '\r')) - ; - - c = -1; + unsigned char c = *(*s)++; + if (c != '#') + return c; + while (*s < end) + { + c = *(*s)++; + if (c == '\n' || c == '\r') + break; + } } - return c; + return -1; } @@ -5244,7 +5246,7 @@ pbm_next_char (unsigned char **s, unsigned char *end) end of input. */ static int -pbm_scan_number (unsigned char **s, unsigned char *end) +pbm_scan_number (char **s, char *end) { int c = 0, val = -1; @@ -5274,12 +5276,9 @@ pbm_load (struct frame *f, struct image *img) int width, height, max_color_idx = 0; Lisp_Object specified_file; enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type; - unsigned char *contents = NULL; - unsigned char *end, *p; -#ifdef USE_CAIRO - unsigned char *data = 0; - uint32_t *dataptr; -#else + char *contents = NULL; + char *end, *p; +#ifndef USE_CAIRO XImagePtr ximg; #endif @@ -5315,7 +5314,7 @@ pbm_load (struct frame *f, struct image *img) image_error ("Invalid image data `%s'", data); return 0; } - p = SDATA (data); + p = SSDATA (data); end = p + SBYTES (data); } @@ -5366,8 +5365,8 @@ pbm_load (struct frame *f, struct image *img) height = pbm_scan_number (&p, end); #ifdef USE_CAIRO - data = (unsigned char *) xmalloc (width * height * 4); - dataptr = (uint32_t *) data; + void *data = xmalloc (width * height * 4); + uint32_t *dataptr = data; #endif if (type != PBM_MONO) @@ -5396,7 +5395,8 @@ pbm_load (struct frame *f, struct image *img) if (type == PBM_MONO) { - int c = 0, g; + unsigned char c = 0; + int g; struct image_keyword fmt[PBM_LAST]; unsigned long fg = FRAME_FOREGROUND_PIXEL (f); unsigned long bg = FRAME_BACKGROUND_PIXEL (f); @@ -5541,7 +5541,7 @@ pbm_load (struct frame *f, struct image *img) r = (double) r * 255 / max_color_idx; g = (double) g * 255 / max_color_idx; b = (double) b * 255 / max_color_idx; - *dataptr++ = (0xff << 24) | (r << 16) | (g << 8) | b; + *dataptr++ = (0xffu << 24) | (r << 16) | (g << 8) | b; #else /* RGB values are now in the range 0..max_color_idx. Scale this to the range 0..0xffff supported by X. */ @@ -5894,13 +5894,12 @@ struct png_load_context static bool png_load_body (struct frame *f, struct image *img, struct png_load_context *c) { - Lisp_Object specified_file; - Lisp_Object specified_data; + Lisp_Object specified_file, specified_data; + FILE *fp = NULL; int x, y; ptrdiff_t i; png_struct *png_ptr; png_info *info_ptr = NULL, *end_info = NULL; - FILE *fp = NULL; png_byte sig[8]; png_byte *pixels = NULL; png_byte **rows = NULL; @@ -5922,7 +5921,6 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) /* Find out what file to load. */ specified_file = image_spec_value (img->spec, QCfile, NULL); specified_data = image_spec_value (img->spec, QCdata, NULL); - IF_LINT (Lisp_Object volatile specified_data_volatile = specified_data); if (NILP (specified_data)) { @@ -6018,10 +6016,6 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) return 0; } - /* Silence a bogus diagnostic; see GCC bug 54561. */ - IF_LINT (fp = c->fp); - IF_LINT (specified_data = specified_data_volatile); - /* Read image info. */ if (!NILP (specified_data)) png_set_read_fn (png_ptr, &tbr, png_read_from_memory); @@ -6671,10 +6665,8 @@ static bool jpeg_load_body (struct frame *f, struct image *img, struct my_jpeg_error_mgr *mgr) { - Lisp_Object specified_file; - Lisp_Object specified_data; - /* The 'volatile' silences a bogus diagnostic; see GCC bug 54561. */ - FILE * IF_LINT (volatile) fp = NULL; + Lisp_Object specified_file, specified_data; + FILE *volatile fp = NULL; JSAMPARRAY buffer; int row_stride, x, y; unsigned long *colors; @@ -6687,7 +6679,6 @@ jpeg_load_body (struct frame *f, struct image *img, /* Open the JPEG file. */ specified_file = image_spec_value (img->spec, QCfile, NULL); specified_data = image_spec_value (img->spec, QCdata, NULL); - IF_LINT (Lisp_Object volatile specified_data_volatile = specified_data); if (NILP (specified_data)) { @@ -6751,9 +6742,6 @@ jpeg_load_body (struct frame *f, struct image *img, return 0; } - /* Silence a bogus diagnostic; see GCC bug 54561. */ - IF_LINT (specified_data = specified_data_volatile); - /* Create the JPEG decompression object. Let it read from fp. Read the JPEG image header. */ jpeg_CreateDecompress (&mgr->cinfo, JPEG_LIB_VERSION, sizeof *&mgr->cinfo); @@ -6848,7 +6836,7 @@ jpeg_load_body (struct frame *f, struct image *img, r = mgr->cinfo.colormap[ir][i]; g = mgr->cinfo.colormap[ig][i]; b = mgr->cinfo.colormap[ib][i]; - *dataptr++ = (0xff << 24) | (r << 16) | (g << 8) | b; + *dataptr++ = (0xffu << 24) | (r << 16) | (g << 8) | b; } } @@ -7491,7 +7479,11 @@ gif_image_p (Lisp_Object object) /* avoid conflict with QuickdrawText.h */ # define DrawText gif_DrawText # include <gif_lib.h> -# undef DrawText +/* The bogus ifdef below, which is always true, is to avoid a compiler + warning about DrawText being unused. */ +# ifdef DrawText +# undef DrawText +# endif /* Giflib before 5.0 didn't define these macros (used only if HAVE_NTGUI). */ # ifndef GIFLIB_MINOR @@ -7637,14 +7629,6 @@ gif_load (struct frame *f, struct image *img) EMACS_INT idx; int gif_err; -#ifdef USE_CAIRO - unsigned char *data = 0; -#else - unsigned long pixel_colors[256]; - unsigned long bgcolor = 0; - XImagePtr ximg; -#endif - if (NILP (specified_data)) { Lisp_Object file = x_find_image_file (specified_file); @@ -7775,24 +7759,26 @@ gif_load (struct frame *f, struct image *img) #ifdef USE_CAIRO /* xzalloc so data is zero => transparent */ - data = (unsigned char *) xzalloc (width * height * 4); + void *data = xzalloc (width * height * 4); + uint32_t *data32 = data; if (STRINGP (specified_bg)) { XColor color; if (x_defined_color (f, SSDATA (specified_bg), &color, 0)) { - uint32_t *dataptr = (uint32_t *)data; + uint32_t *dataptr = data32; int r = color.red/256; int g = color.green/256; int b = color.blue/256; for (y = 0; y < height; ++y) for (x = 0; x < width; ++x) - *dataptr++ = (0xff << 24) | (r << 16) | (g << 8) | b; + *dataptr++ = (0xffu << 24) | (r << 16) | (g << 8) | b; } } #else /* Create the X image and pixmap. */ + XImagePtr ximg; if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0)) { gif_close (gif, NULL); @@ -7830,6 +7816,7 @@ gif_load (struct frame *f, struct image *img) init_color_table (); #ifndef USE_CAIRO + unsigned long bgcolor; if (STRINGP (specified_bg)) bgcolor = x_alloc_image_color (f, img, specified_bg, FRAME_BACKGROUND_PIXEL (f)); @@ -7883,7 +7870,7 @@ gif_load (struct frame *f, struct image *img) #ifndef USE_CAIRO /* Allocate subimage colors. */ - memset (pixel_colors, 0, sizeof pixel_colors); + unsigned long pixel_colors[256] = { 0, }; if (gif_color_map) for (i = 0; i < gif_color_map->ColorCount; ++i) @@ -7920,14 +7907,14 @@ gif_load (struct frame *f, struct image *img) { #ifdef USE_CAIRO uint32_t *dataptr = - ((uint32_t*)data + ((row + subimg_top) * subimg_width - + x + subimg_left)); + (data32 + ((row + subimg_top) * subimg_width + + x + subimg_left)); int r = gif_color_map->Colors[c].Red; int g = gif_color_map->Colors[c].Green; int b = gif_color_map->Colors[c].Blue; if (transparency_color_index != c) - *dataptr = (0xff << 24) | (r << 16) | (g << 8) | b; + *dataptr = (0xffu << 24) | (r << 16) | (g << 8) | b; #else XPutPixel (ximg, x + subimg_left, row + subimg_top, pixel_colors[c]); @@ -7946,13 +7933,13 @@ gif_load (struct frame *f, struct image *img) { #ifdef USE_CAIRO uint32_t *dataptr = - ((uint32_t*)data + ((y + subimg_top) * subimg_width - + x + subimg_left)); + (data32 + ((y + subimg_top) * subimg_width + + x + subimg_left)); int r = gif_color_map->Colors[c].Red; int g = gif_color_map->Colors[c].Green; int b = gif_color_map->Colors[c].Blue; if (transparency_color_index != c) - *dataptr = (0xff << 24) | (r << 16) | (g << 8) | b; + *dataptr = (0xffu << 24) | (r << 16) | (g << 8) | b; #else XPutPixel (ximg, x + subimg_left, y + subimg_top, pixel_colors[c]); @@ -8077,15 +8064,25 @@ compute_image_size (size_t width, size_t height, { Lisp_Object value; int desired_width, desired_height; + double scale = 1; + + value = image_spec_value (spec, QCscale, NULL); + if (NUMBERP (value)) + scale = extract_float (value); /* If width and/or height is set in the display spec assume we want to scale to those values. If either h or w is unspecified, the unspecified should be calculated from the specified to preserve aspect ratio. */ value = image_spec_value (spec, QCwidth, NULL); - desired_width = NATNUMP (value) ? min (XFASTINT (value), INT_MAX) : -1; + desired_width = NATNUMP (value) ? + min (XFASTINT (value) * scale, INT_MAX) : -1; value = image_spec_value (spec, QCheight, NULL); - desired_height = NATNUMP (value) ? min (XFASTINT (value), INT_MAX) : -1; + desired_height = NATNUMP (value) ? + min (XFASTINT (value) * scale, INT_MAX) : -1; + + width = width * scale; + height = height * scale; if (desired_width == -1) { @@ -8136,6 +8133,13 @@ compute_image_size (size_t width, size_t height, /* h known, calculate w. */ desired_width = scale_image_size (desired_height, height, width); + /* We have no width/height settings, so just apply the scale. */ + if (desired_width == -1 && desired_height == -1) + { + desired_width = width; + desired_height = height; + } + *d_width = desired_width; *d_height = desired_height; } @@ -8315,8 +8319,8 @@ static struct animation_cache * imagemagick_create_cache (char *signature) { struct animation_cache *cache - = xmalloc (offsetof (struct animation_cache, signature) - + strlen (signature) + 1); + = xmalloc (FLEXSIZEOF (struct animation_cache, signature, + strlen (signature) + 1)); cache->wand = 0; cache->index = 0; cache->next = 0; @@ -8519,7 +8523,6 @@ imagemagick_load_image (struct frame *f, struct image *img, EMACS_INT ino; int desired_width, desired_height; double rotation; - int pixelwidth; char hint_buffer[MaxTextExtent]; char *filename_hint = NULL; @@ -8538,6 +8541,14 @@ imagemagick_load_image (struct frame *f, struct image *img, status = MagickReadImage (image_wand, filename); else { + Lisp_Object lwidth = image_spec_value (img->spec, QCwidth, NULL); + Lisp_Object lheight = image_spec_value (img->spec, QCheight, NULL); + + if (NATNUMP (lwidth) && NATNUMP (lheight)) + { + MagickSetSize (image_wand, XFASTINT (lwidth), XFASTINT (lheight)); + MagickSetDepth (image_wand, 8); + } filename_hint = imagemagick_filename_hint (img->spec, hint_buffer); MagickSetFilename (image_wand, filename_hint); status = MagickReadImageBlob (image_wand, contents, size); @@ -8550,6 +8561,18 @@ imagemagick_load_image (struct frame *f, struct image *img, return 0; } +#ifdef HAVE_MAGICKAUTOORIENTIMAGE + /* If no :rotation is explicitly specified, apply the automatic + rotation from EXIF. */ + if (NILP (image_spec_value (img->spec, QCrotation, NULL))) + if (MagickAutoOrientImage (image_wand) == MagickFalse) + { + image_error ("Error applying automatic orientation in image `%s'", img->spec); + DestroyMagickWand (image_wand); + return 0; + } +#endif + if (ino < 0 || ino >= MagickGetNumberImages (image_wand)) { image_error ("Invalid image number `%s' in image `%s'", image, img->spec); @@ -8736,7 +8759,7 @@ imagemagick_load_image (struct frame *f, struct image *img, on rgb display. seems about 3 times as fast as pixel pushing(not carefully measured) */ - pixelwidth = CharPixel; /*??? TODO figure out*/ + int pixelwidth = CharPixel; /*??? TODO figure out*/ MagickExportImagePixels (image_wand, 0, 0, width, height, exportdepth, pixelwidth, ximg->data); } @@ -8920,7 +8943,7 @@ static bool svg_image_p (Lisp_Object object); static bool svg_load (struct frame *f, struct image *img); static bool svg_load_image (struct frame *, struct image *, - unsigned char *, ptrdiff_t, char *); + char *, ptrdiff_t, char *); /* Indices of image specification fields in svg_format, below. */ @@ -9009,10 +9032,13 @@ svg_image_p (Lisp_Object object) # ifdef WINDOWSNT +/* Restore the original definition of __MINGW_MAJOR_VERSION. */ # ifdef W32_SAVE_MINGW_VERSION # undef __MINGW_MAJOR_VERSION # define __MINGW_MAJOR_VERSION W32_SAVE_MINGW_VERSION -# undef W32_SAVE_MINGW_VERSION +# ifdef __MINGW_MAJOR_VERSION +# undef W32_SAVE_MINGW_VERSION +# endif # endif /* SVG library functions. */ @@ -9112,7 +9138,9 @@ init_svg_functions (void) # define gdk_pixbuf_get_width fn_gdk_pixbuf_get_width # define g_clear_error fn_g_clear_error # define g_object_unref fn_g_object_unref -# define g_type_init fn_g_type_init +# if ! GLIB_CHECK_VERSION (2, 36, 0) +# define g_type_init fn_g_type_init +# endif # define rsvg_handle_close fn_rsvg_handle_close # define rsvg_handle_get_dimensions fn_rsvg_handle_get_dimensions # define rsvg_handle_get_pixbuf fn_rsvg_handle_get_pixbuf @@ -9145,7 +9173,7 @@ svg_load (struct frame *f, struct image *img) /* Read the entire file into memory. */ ptrdiff_t size; - unsigned char *contents = slurp_file (fd, &size); + char *contents = slurp_file (fd, &size); if (contents == NULL) { image_error ("Error loading SVG image `%s'", file); @@ -9169,7 +9197,7 @@ svg_load (struct frame *f, struct image *img) return 0; } original_filename = BVAR (current_buffer, filename); - success_p = svg_load_image (f, img, SDATA (data), SBYTES (data), + success_p = svg_load_image (f, img, SSDATA (data), SBYTES (data), (NILP (original_filename) ? NULL : SSDATA (original_filename))); } @@ -9177,19 +9205,16 @@ svg_load (struct frame *f, struct image *img) return success_p; } -/* svg_load_image is a helper function for svg_load, which does the - actual loading given contents and size, apart from frame and image - structures, passed from svg_load. +/* Load frame F and image IMG. CONTENTS contains the SVG XML data to + be parsed, SIZE is its size, and FILENAME is the name of the SVG + file being loaded. - Uses librsvg to do most of the image processing. + Use librsvg to do most of the image processing. - Returns true when successful. */ + Return true when successful. */ static bool -svg_load_image (struct frame *f, /* Pointer to emacs frame structure. */ - struct image *img, /* Pointer to emacs image structure. */ - unsigned char *contents, /* String containing the SVG XML data to be parsed. */ - ptrdiff_t size, /* Size of data in bytes. */ - char *filename) /* Name of SVG file being loaded. */ +svg_load_image (struct frame *f, struct image *img, char *contents, + ptrdiff_t size, char *filename) { RsvgHandle *rsvg_handle; RsvgDimensionData dimension_data; @@ -9216,7 +9241,7 @@ svg_load_image (struct frame *f, /* Pointer to emacs frame structure. * rsvg_handle_set_base_uri(rsvg_handle, filename); /* Parse the contents argument and fill in the rsvg_handle. */ - rsvg_handle_write (rsvg_handle, contents, size, &err); + rsvg_handle_write (rsvg_handle, (unsigned char *) contents, size, &err); if (err) goto rsvg_error; /* The parsing is complete, rsvg_handle is ready to used, close it @@ -9249,8 +9274,8 @@ svg_load_image (struct frame *f, /* Pointer to emacs frame structure. * eassert (gdk_pixbuf_get_has_alpha (pixbuf)); eassert (gdk_pixbuf_get_bits_per_sample (pixbuf) == 8); -#ifdef USE_CAIRO { +#ifdef USE_CAIRO unsigned char *data = (unsigned char *) xmalloc (width*height*4); uint32_t bgcolor = get_spec_bg_or_alpha_as_argb (img, f); @@ -9276,82 +9301,77 @@ svg_load_image (struct frame *f, /* Pointer to emacs frame structure. * create_cairo_image_surface (img, data, width, height); g_object_unref (pixbuf); - } #else - /* Try to create a x pixmap to hold the svg pixmap. */ - XImagePtr ximg; - if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0)) - { - g_object_unref (pixbuf); - return 0; - } + /* Try to create a x pixmap to hold the svg pixmap. */ + XImagePtr ximg; + if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0)) + { + g_object_unref (pixbuf); + return 0; + } - init_color_table (); + init_color_table (); - /* Handle alpha channel by combining the image with a background - color. */ - XColor background; - Lisp_Object specified_bg = image_spec_value (img->spec, QCbackground, NULL); - if (!STRINGP (specified_bg) - || !x_defined_color (f, SSDATA (specified_bg), &background, 0)) - x_query_frame_background_color (f, &background); - - /* SVG pixmaps specify transparency in the last byte, so right - shift 8 bits to get rid of it, since emacs doesn't support - transparency. */ - background.red >>= 8; - background.green >>= 8; - background.blue >>= 8; - - /* This loop handles opacity values, since Emacs assumes - non-transparent images. Each pixel must be "flattened" by - calculating the resulting color, given the transparency of the - pixel, and the image background color. */ - for (int y = 0; y < height; ++y) - { - for (int x = 0; x < width; ++x) - { - int red; - int green; - int blue; - int opacity; - - red = *pixels++; - green = *pixels++; - blue = *pixels++; - opacity = *pixels++; - - red = ((red * opacity) - + (background.red * ((1 << 8) - opacity))); - green = ((green * opacity) - + (background.green * ((1 << 8) - opacity))); - blue = ((blue * opacity) - + (background.blue * ((1 << 8) - opacity))); - - XPutPixel (ximg, x, y, lookup_rgb_color (f, red, green, blue)); - } + /* Handle alpha channel by combining the image with a background + color. */ + XColor background; + Lisp_Object specified_bg = image_spec_value (img->spec, QCbackground, NULL); + if (!STRINGP (specified_bg) + || !x_defined_color (f, SSDATA (specified_bg), &background, 0)) + x_query_frame_background_color (f, &background); + + /* SVG pixmaps specify transparency in the last byte, so right + shift 8 bits to get rid of it, since emacs doesn't support + transparency. */ + background.red >>= 8; + background.green >>= 8; + background.blue >>= 8; + + /* This loop handles opacity values, since Emacs assumes + non-transparent images. Each pixel must be "flattened" by + calculating the resulting color, given the transparency of the + pixel, and the image background color. */ + for (int y = 0; y < height; ++y) + { + for (int x = 0; x < width; ++x) + { + int red = *pixels++; + int green = *pixels++; + int blue = *pixels++; + int opacity = *pixels++; + + red = ((red * opacity) + + (background.red * ((1 << 8) - opacity))); + green = ((green * opacity) + + (background.green * ((1 << 8) - opacity))); + blue = ((blue * opacity) + + (background.blue * ((1 << 8) - opacity))); + + XPutPixel (ximg, x, y, lookup_rgb_color (f, red, green, blue)); + } - pixels += rowstride - 4 * width; - } + pixels += rowstride - 4 * width; + } #ifdef COLOR_TABLE_SUPPORT - /* Remember colors allocated for this image. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); + /* Remember colors allocated for this image. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); #endif /* COLOR_TABLE_SUPPORT */ - g_object_unref (pixbuf); + g_object_unref (pixbuf); - img->width = width; - img->height = height; + img->width = width; + img->height = height; - /* Maybe fill in the background field while we have ximg handy. - Casting avoids a GCC warning. */ - IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg); + /* Maybe fill in the background field while we have ximg handy. + Casting avoids a GCC warning. */ + IMAGE_BACKGROUND (img, f, (XImagePtr_or_DC)ximg); - /* Put ximg into the image. */ - image_put_x_image (f, img, ximg, 0); + /* Put ximg into the image. */ + image_put_x_image (f, img, ximg, 0); #endif /* ! USE_CAIRO */ + } return 1; @@ -9525,7 +9545,7 @@ gs_load (struct frame *f, struct image *img) { /* Only W32 version did BLOCK_INPUT here. ++kfs */ block_input (); - img->pixmap = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + img->pixmap = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), img->width, img->height, DefaultDepthOfScreen (FRAME_X_SCREEN (f))); unblock_input (); @@ -9541,7 +9561,7 @@ gs_load (struct frame *f, struct image *img) if successful. We do not record_unwind_protect here because other places in redisplay like calling window scroll functions don't either. Let the Lisp loader use `unwind-protect' instead. */ - printnum1 = FRAME_X_WINDOW (f); + printnum1 = FRAME_X_DRAWABLE (f); printnum2 = img->pixmap; window_and_pixmap_id = make_formatted_string (buffer, "%"pMu" %"pMu, printnum1, printnum2); @@ -9760,6 +9780,8 @@ lookup_image_type (Lisp_Object type) return NULL; } +#if !defined CANNOT_DUMP && defined HAVE_WINDOW_SYSTEM + /* Reset image_types before dumping. Called from Fdump_emacs. */ @@ -9773,6 +9795,7 @@ reset_image_types (void) image_types = next; } } +#endif void syms_of_image (void) @@ -9816,6 +9839,7 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (QCcrop, ":crop"); DEFSYM (QCrotation, ":rotation"); DEFSYM (QCmatrix, ":matrix"); + DEFSYM (QCscale, ":scale"); DEFSYM (QCcolor_adjustment, ":color-adjustment"); DEFSYM (QCmask, ":mask"); diff --git a/src/indent.c b/src/indent.c index 578dac83df5..29c9ffd90cc 100644 --- a/src/indent.c +++ b/src/indent.c @@ -296,7 +296,7 @@ skip_invisible (ptrdiff_t pos, ptrdiff_t *next_boundary_p, ptrdiff_t to, Lisp_Ob if (dp != 0 && VECTORP (DISP_CHAR_VECTOR (dp, ch))) \ width = sanitize_char_width (ASIZE (DISP_CHAR_VECTOR (dp, ch))); \ else \ - width = CHAR_WIDTH (ch); \ + width = CHARACTER_WIDTH (ch); \ } \ } while (0) @@ -1162,7 +1162,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, int prev_tab_offset; /* Previous tab offset. */ int continuation_glyph_width; struct buffer *cache_buffer = current_buffer; - struct region_cache *width_cache; + struct region_cache *width_cache = NULL; struct composition_it cmp_it; @@ -1170,11 +1170,14 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, if (cache_buffer->base_buffer) cache_buffer = cache_buffer->base_buffer; - width_cache = width_run_cache_on_off (); if (dp == buffer_display_table ()) - width_table = (VECTORP (BVAR (current_buffer, width_table)) - ? XVECTOR (BVAR (current_buffer, width_table))->contents - : 0); + { + width_table = (VECTORP (BVAR (current_buffer, width_table)) + ? XVECTOR (BVAR (current_buffer, width_table))->contents + : 0); + if (width_table) + width_cache = width_run_cache_on_off (); + } else /* If the window has its own display table, we can't use the width run cache, because that's based on the buffer's display table. */ @@ -1873,9 +1876,9 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, } pos = *compute_motion (prevline, bytepos, 0, lmargin, 0, from, /* Don't care for VPOS... */ - 1 << (BITS_PER_SHORT - 1), + 1 << (SHRT_WIDTH - 1), /* ... nor HPOS. */ - 1 << (BITS_PER_SHORT - 1), + 1 << (SHRT_WIDTH - 1), -1, hscroll, 0, w); vpos -= pos.vpos; first = 0; @@ -1923,9 +1926,9 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, } pos = *compute_motion (prevline, bytepos, 0, lmargin, 0, from, /* Don't care for VPOS... */ - 1 << (BITS_PER_SHORT - 1), + 1 << (SHRT_WIDTH - 1), /* ... nor HPOS. */ - 1 << (BITS_PER_SHORT - 1), + 1 << (SHRT_WIDTH - 1), -1, hscroll, 0, w); did_motion = 1; } @@ -1936,7 +1939,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, did_motion = 0; } return compute_motion (from, from_byte, vpos, pos.hpos, did_motion, - ZV, vtarget, - (1 << (BITS_PER_SHORT - 1)), + ZV, vtarget, - (1 << (SHRT_WIDTH - 1)), -1, hscroll, 0, w); } @@ -1955,6 +1958,20 @@ window_column_x (struct window *w, Lisp_Object window, return x; } +/* Restore window's buffer and point. */ + +static void +restore_window_buffer (Lisp_Object list) +{ + struct window *w = decode_live_window (XCAR (list)); + list = XCDR (list); + wset_buffer (w, XCAR (list)); + list = XCDR (list); + set_marker_both (w->pointm, w->contents, + XFASTINT (XCAR (list)), + XFASTINT (XCAR (XCDR (list)))); +} + DEFUN ("vertical-motion", Fvertical_motion, Svertical_motion, 1, 3, 0, doc: /* Move point to start of the screen line LINES lines down. If LINES is negative, this means moving up. @@ -1994,10 +2011,9 @@ whether or not it is currently displayed in some window. */) struct it it; struct text_pos pt; struct window *w; - Lisp_Object old_buffer; - EMACS_INT old_charpos IF_LINT (= 0), old_bytepos IF_LINT (= 0); Lisp_Object lcols; void *itdata = NULL; + ptrdiff_t count = SPECPDL_INDEX (); /* Allow LINES to be of the form (HPOS . VPOS) aka (COLUMNS . LINES). */ bool lcols_given = CONSP (lines); @@ -2010,13 +2026,13 @@ whether or not it is currently displayed in some window. */) CHECK_NUMBER (lines); w = decode_live_window (window); - old_buffer = Qnil; if (XBUFFER (w->contents) != current_buffer) { /* Set the window's buffer temporarily to the current buffer. */ - old_buffer = w->contents; - old_charpos = marker_position (w->pointm); - old_bytepos = marker_byte_position (w->pointm); + Lisp_Object old = list4 (window, w->contents, + make_number (marker_position (w->pointm)), + make_number (marker_byte_position (w->pointm))); + record_unwind_protect (restore_window_buffer, old); wset_buffer (w, Fcurrent_buffer ()); set_marker_both (w->pointm, w->contents, BUF_PT (current_buffer), BUF_PT_BYTE (current_buffer)); @@ -2037,8 +2053,8 @@ whether or not it is currently displayed in some window. */) bool disp_string_at_start_p = 0; ptrdiff_t nlines = XINT (lines); int vpos_init = 0; - double start_col IF_LINT (= 0); - int start_x IF_LINT (= 0); + double start_col UNINIT; + int start_x UNINIT; int to_x = -1; bool start_x_given = !NILP (cur_col); @@ -2179,6 +2195,7 @@ whether or not it is currently displayed in some window. */) if (nlines <= 0) { it.vpos = vpos_init; + it.current_y = 0; /* Do this even if LINES is 0, so that we move back to the beginning of the current line as we ought. */ if ((nlines < 0 && IT_CHARPOS (it) > 0) @@ -2188,6 +2205,7 @@ whether or not it is currently displayed in some window. */) else if (overshoot_handled) { it.vpos = vpos_init; + it.current_y = 0; move_it_by_lines (&it, min (PTRDIFF_MAX, nlines)); } else @@ -2201,6 +2219,7 @@ whether or not it is currently displayed in some window. */) while (IT_CHARPOS (it) <= it_start) { it.vpos = 0; + it.current_y = 0; move_it_by_lines (&it, 1); } if (nlines > 1) @@ -2209,6 +2228,7 @@ whether or not it is currently displayed in some window. */) else /* it_start = ZV */ { it.vpos = 0; + it.current_y = 0; move_it_by_lines (&it, min (PTRDIFF_MAX, nlines)); /* We could have some display or overlay string at ZV, in which case it.vpos will be nonzero now, while @@ -2248,12 +2268,7 @@ whether or not it is currently displayed in some window. */) bidi_unshelve_cache (itdata, 0); } - if (BUFFERP (old_buffer)) - { - wset_buffer (w, old_buffer); - set_marker_both (w->pointm, w->contents, - old_charpos, old_bytepos); - } + unbind_to (count, Qnil); return make_number (it.vpos); } diff --git a/src/inotify.c b/src/inotify.c index 38c8df5a29a..cacc6dca147 100644 --- a/src/inotify.c +++ b/src/inotify.c @@ -364,7 +364,7 @@ See inotify_rm_watch(2) for more information. } DEFUN ("inotify-valid-p", Finotify_valid_p, Sinotify_valid_p, 1, 1, 0, - doc: /* "Check a watch specified by its WATCH-DESCRIPTOR. + doc: /* Check a watch specified by its WATCH-DESCRIPTOR. WATCH-DESCRIPTOR should be an object returned by `inotify-add-watch'. diff --git a/src/insdel.c b/src/insdel.c index fc3f19fd581..ed914ec6f75 100644 --- a/src/insdel.c +++ b/src/insdel.c @@ -364,6 +364,78 @@ adjust_markers_for_replace (ptrdiff_t from, ptrdiff_t from_byte, check_markers (); } +/* Starting at POS (BYTEPOS), find the byte position corresponding to + ENDPOS, which could be either before or after POS. */ +static ptrdiff_t +count_bytes (ptrdiff_t pos, ptrdiff_t bytepos, ptrdiff_t endpos) +{ + eassert (BEG_BYTE <= bytepos && bytepos <= Z_BYTE + && BEG <= endpos && endpos <= Z); + + if (pos <= endpos) + for ( ; pos < endpos; pos++) + INC_POS (bytepos); + else + for ( ; pos > endpos; pos--) + DEC_POS (bytepos); + + return bytepos; +} + +/* Adjust byte positions of markers when their character positions + didn't change. This is used in several places that replace text, + but keep the character positions of the markers unchanged -- the + byte positions could still change due to different numbers of bytes + in the new text. + + FROM (FROM_BYTE) and TO (TO_BYTE) specify the region of text where + changes have been done. TO_Z, if non-zero, means all the markers + whose positions are after TO should also be adjusted. */ +void +adjust_markers_bytepos (ptrdiff_t from, ptrdiff_t from_byte, + ptrdiff_t to, ptrdiff_t to_byte, int to_z) +{ + register struct Lisp_Marker *m; + ptrdiff_t beg = from, begbyte = from_byte; + + adjust_suspend_auto_hscroll (from, to); + + if (Z == Z_BYTE || (!to_z && to == to_byte)) + { + /* Make sure each affected marker's bytepos is equal to + its charpos. */ + for (m = BUF_MARKERS (current_buffer); m; m = m->next) + { + if (m->bytepos > from_byte + && (to_z || m->bytepos <= to_byte)) + m->bytepos = m->charpos; + } + } + else + { + for (m = BUF_MARKERS (current_buffer); m; m = m->next) + { + /* Recompute each affected marker's bytepos. */ + if (m->bytepos > from_byte + && (to_z || m->bytepos <= to_byte)) + { + if (m->charpos < beg + && beg - m->charpos > m->charpos - from) + { + beg = from; + begbyte = from_byte; + } + m->bytepos = count_bytes (beg, begbyte, m->charpos); + beg = m->charpos; + begbyte = m->bytepos; + } + } + } + + /* Make sure cached charpos/bytepos is invalid. */ + clear_charpos_cache (current_buffer); +} + void buffer_overflow (void) @@ -1400,6 +1472,16 @@ replace_range (ptrdiff_t from, ptrdiff_t to, Lisp_Object new, if (markers) adjust_markers_for_replace (from, from_byte, nchars_del, nbytes_del, inschars, outgoing_insbytes); + else + { + /* The character positions of the markers remain intact, but we + still need to update their byte positions, because the + deleted and the inserted text might have multibyte sequences + which make the original byte positions of the markers + invalid. */ + adjust_markers_bytepos (from, from_byte, from + inschars, + from_byte + outgoing_insbytes, 1); + } /* Adjust the overlay center as needed. This must be done after adjusting the markers that bound the overlays. */ @@ -1515,10 +1597,22 @@ replace_range_2 (ptrdiff_t from, ptrdiff_t from_byte, eassert (GPT <= GPT_BYTE); /* Adjust markers for the deletion and the insertion. */ - if (markers - && ! (nchars_del == 1 && inschars == 1 && nbytes_del == insbytes)) - adjust_markers_for_replace (from, from_byte, nchars_del, nbytes_del, - inschars, insbytes); + if (! (nchars_del == 1 && inschars == 1 && nbytes_del == insbytes)) + { + if (markers) + adjust_markers_for_replace (from, from_byte, nchars_del, nbytes_del, + inschars, insbytes); + else + { + /* The character positions of the markers remain intact, but + we still need to update their byte positions, because the + deleted and the inserted text might have multibyte + sequences which make the original byte positions of the + markers invalid. */ + adjust_markers_bytepos (from, from_byte, from + inschars, + from_byte + insbytes, 1); + } + } /* Adjust the overlay center as needed. This must be done after adjusting the markers that bound the overlays. */ @@ -1596,7 +1690,7 @@ del_range_1 (ptrdiff_t from, ptrdiff_t to, bool prepare, bool ret_string) /* Like del_range_1 but args are byte positions, not char positions. */ void -del_range_byte (ptrdiff_t from_byte, ptrdiff_t to_byte, bool prepare) +del_range_byte (ptrdiff_t from_byte, ptrdiff_t to_byte) { ptrdiff_t from, to; @@ -1612,23 +1706,22 @@ del_range_byte (ptrdiff_t from_byte, ptrdiff_t to_byte, bool prepare) from = BYTE_TO_CHAR (from_byte); to = BYTE_TO_CHAR (to_byte); - if (prepare) - { - ptrdiff_t old_from = from, old_to = Z - to; - ptrdiff_t range_length = to - from; - prepare_to_modify_buffer (from, to, &from); - to = from + range_length; - - if (old_from != from) - from_byte = CHAR_TO_BYTE (from); - if (to > ZV) - { - to = ZV; - to_byte = ZV_BYTE; - } - else if (old_to == Z - to) - to_byte = CHAR_TO_BYTE (to); - } + { + ptrdiff_t old_from = from, old_to = Z - to; + ptrdiff_t range_length = to - from; + prepare_to_modify_buffer (from, to, &from); + to = from + range_length; + + if (old_from != from) + from_byte = CHAR_TO_BYTE (from); + if (to > ZV) + { + to = ZV; + to_byte = ZV_BYTE; + } + else if (old_to == Z - to) + to_byte = CHAR_TO_BYTE (to); + } del_range_2 (from, from_byte, to, to_byte, 0); signal_after_change (from, to - from, 0); diff --git a/src/intervals.c b/src/intervals.c index 8451069708c..e797e25ce9c 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -1821,11 +1821,16 @@ set_point (ptrdiff_t charpos) void set_point_from_marker (Lisp_Object marker) { + ptrdiff_t charpos = clip_to_bounds (BEGV, marker_position (marker), ZV); + ptrdiff_t bytepos = marker_byte_position (marker); + + /* Don't trust the byte position if the marker belongs to a + different buffer. */ if (XMARKER (marker)->buffer != current_buffer) - signal_error ("Marker points into wrong buffer", marker); - set_point_both - (clip_to_bounds (BEGV, marker_position (marker), ZV), - clip_to_bounds (BEGV_BYTE, marker_byte_position (marker), ZV_BYTE)); + bytepos = buf_charpos_to_bytepos (current_buffer, charpos); + else + bytepos = clip_to_bounds (BEGV_BYTE, bytepos, ZV_BYTE); + set_point_both (charpos, bytepos); } /* If there's an invisible character at position POS + TEST_OFFS in the diff --git a/src/intervals.h b/src/intervals.h index b8cdcfdc0f5..b56c0509993 100644 --- a/src/intervals.h +++ b/src/intervals.h @@ -19,6 +19,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #ifndef EMACS_INTERVALS_H #define EMACS_INTERVALS_H +#include "buffer.h" +#include "lisp.h" + INLINE_HEADER_BEGIN /* Basic data type for use of intervals. */ @@ -197,12 +200,12 @@ set_interval_plist (INTERVAL i, Lisp_Object plist) /* Is this interval writable? Replace later with cache access. */ #define INTERVAL_WRITABLE_P(i) \ - (i && (NILP (textget ((i)->plist, Qread_only)) \ - || !NILP (textget ((i)->plist, Qinhibit_read_only)) \ - || ((CONSP (Vinhibit_read_only) \ - ? !NILP (Fmemq (textget ((i)->plist, Qread_only), \ - Vinhibit_read_only)) \ - : !NILP (Vinhibit_read_only))))) \ + (NILP (textget ((i)->plist, Qread_only)) \ + || !NILP (textget ((i)->plist, Qinhibit_read_only)) \ + || ((CONSP (Vinhibit_read_only) \ + ? !NILP (Fmemq (textget ((i)->plist, Qread_only), \ + Vinhibit_read_only)) \ + : !NILP (Vinhibit_read_only)))) /* Macros to tell whether insertions before or after this interval should stick to it. Now we have Vtext_property_default_nonsticky, @@ -285,7 +288,7 @@ extern void set_text_properties_1 (Lisp_Object, Lisp_Object, Lisp_Object text_property_list (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); void add_text_properties_from_list (Lisp_Object, Lisp_Object, Lisp_Object); -Lisp_Object extend_property_ranges (Lisp_Object, Lisp_Object); +Lisp_Object extend_property_ranges (Lisp_Object, Lisp_Object, Lisp_Object); Lisp_Object get_char_property_and_overlay (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object*); extern int text_property_stickiness (Lisp_Object prop, Lisp_Object pos, diff --git a/src/keyboard.c b/src/keyboard.c index f24d86e8833..15c7f5ff8c6 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -75,6 +75,12 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ # pragma GCC diagnostic ignored "-Wclobbered" #endif +#ifdef WINDOWSNT +char const DEV_TTY[] = "CONOUT$"; +#else +char const DEV_TTY[] = "/dev/tty"; +#endif + /* Variables for blockinput.h: */ /* Positive if interrupt input is blocked right now. */ @@ -142,9 +148,6 @@ static Lisp_Object regular_top_level_message; static sys_jmp_buf getcjmp; -/* True while doing kbd input. */ -bool waiting_for_input; - /* True while displaying for echoing. Delays C-g throwing. */ static bool echoing; @@ -696,7 +699,7 @@ recursive_edit_1 (void) val = command_loop (); if (EQ (val, Qt)) - Fsignal (Qquit, Qnil); + quit (); /* Handle throw from read_minibuf when using minibuffer while it's active but we're in another window. */ if (STRINGP (val)) @@ -2135,7 +2138,7 @@ read_event_from_main_queue (struct timespec *end_time, { Lisp_Object c = Qnil; sys_jmp_buf save_jump; - KBOARD *kb IF_LINT (= NULL); + KBOARD *kb; start: @@ -2159,9 +2162,9 @@ read_event_from_main_queue (struct timespec *end_time, if (CONSP (last)) { while (CONSP (XCDR (last))) - last = XCDR (last); + last = XCDR (last); if (!NILP (XCDR (last))) - emacs_abort (); + emacs_abort (); } if (!CONSP (last)) kset_kbd_queue (kb, list1 (c)); @@ -2206,8 +2209,8 @@ read_decoded_event_from_main_queue (struct timespec *end_time, Lisp_Object prev_event, bool *used_mouse_menu) { -#define MAX_ENCODED_BYTES 16 #ifndef WINDOWSNT +#define MAX_ENCODED_BYTES 16 Lisp_Object events[MAX_ENCODED_BYTES]; int n = 0; #endif @@ -2568,6 +2571,9 @@ read_char (int commandflag, Lisp_Object map, so restore it now. */ restore_getcjmp (save_jump); pthread_sigmask (SIG_SETMASK, &empty_mask, 0); +#if THREADS_ENABLED + maybe_reacquire_global_lock (); +#endif unbind_to (jmpcount, Qnil); XSETINT (c, quit_char); internal_last_event_frame = selected_frame; @@ -2847,7 +2853,16 @@ read_char (int commandflag, Lisp_Object map, last_input_event = c; call4 (Qcommand_execute, tem, Qnil, Fvector (1, &last_input_event), Qt); - if (CONSP (c) && EQ (XCAR (c), Qselect_window) && !end_time) + if (CONSP (c) + && (EQ (XCAR (c), Qselect_window) +#ifdef HAVE_DBUS + || EQ (XCAR (c), Qdbus_event) +#endif +#ifdef USE_FILE_NOTIFY + || EQ (XCAR (c), Qfile_notify) +#endif + || EQ (XCAR (c), Qconfig_changed_event)) + && !end_time) /* We stopped being idle for this event; undo that. This prevents automatic window selection (under mouse-autoselect-window) from acting as a real input event, for @@ -3552,14 +3567,23 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, #endif /* subprocesses */ } + Lisp_Object ignore_event; + + switch (event->kind) + { + case FOCUS_IN_EVENT: ignore_event = Qfocus_in; break; + case FOCUS_OUT_EVENT: ignore_event = Qfocus_out; break; + case HELP_EVENT: ignore_event = Qhelp_echo; break; + case ICONIFY_EVENT: ignore_event = Qiconify_frame; break; + case DEICONIFY_EVENT: ignore_event = Qmake_frame_visible; break; + case SELECTION_REQUEST_EVENT: ignore_event = Qselection_request; break; + default: ignore_event = Qnil; break; + } + /* If we're inside while-no-input, and this event qualifies as input, set quit-flag to cause an interrupt. */ if (!NILP (Vthrow_on_input) - && event->kind != FOCUS_IN_EVENT - && event->kind != FOCUS_OUT_EVENT - && event->kind != HELP_EVENT - && event->kind != ICONIFY_EVENT - && event->kind != DEICONIFY_EVENT) + && NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events))) { Vquit_flag = Vthrow_on_input; /* If we're inside a function that wants immediate quits, @@ -3897,6 +3921,16 @@ kbd_buffer_get_event (KBOARD **kbp, kbd_fetch_ptr = event + 1; } #endif + +#ifdef HAVE_NTGUI + else if (event->kind == END_SESSION_EVENT) + { + /* Make an event (end-session). */ + obj = list1 (Qend_session); + kbd_fetch_ptr = event + 1; + } +#endif + #if defined (HAVE_X11) || defined (HAVE_NTGUI) \ || defined (HAVE_NS) else if (event->kind == ICONIFY_EVENT) @@ -5392,6 +5426,36 @@ make_lispy_event (struct input_event *event) { c &= 0377; eassert (c == event->code); + } + + /* Caps-lock shouldn't affect interpretation of key chords: + Control+s should produce C-s whether caps-lock is on or + not. And Control+Shift+s should produce C-S-s whether + caps-lock is on or not. */ + if (event->modifiers & ~shift_modifier) + { + /* This is a key chord: some non-shift modifier is + depressed. */ + + if (uppercasep (c) && + !(event->modifiers & shift_modifier)) + { + /* Got a capital letter without a shift. The caps + lock is on. Un-capitalize the letter. */ + c = downcase (c); + } + else if (lowercasep (c) && + (event->modifiers & shift_modifier)) + { + /* Got a lower-case letter even though shift is + depressed. The caps lock is on. Capitalize the + letter. */ + c = upcase (c); + } + } + + if (event->kind == ASCII_KEYSTROKE_EVENT) + { /* Turn ASCII characters into control characters when proper. */ if (event->modifiers & ctrl_modifier) @@ -5984,7 +6048,6 @@ make_lispy_event (struct input_event *event) } #endif - #if defined HAVE_INOTIFY || defined HAVE_KQUEUE || defined HAVE_GFILENOTIFY case FILE_NOTIFY_EVENT: { @@ -6603,7 +6666,12 @@ has the same base event type and all the specified modifiers. */) int parse_solitary_modifier (Lisp_Object symbol) { - Lisp_Object name = SYMBOL_NAME (symbol); + Lisp_Object name; + + if (!SYMBOLP (symbol)) + return 0; + + name = SYMBOL_NAME (symbol); switch (SREF (name, 0)) { @@ -6884,7 +6952,10 @@ tty_read_avail_input (struct terminal *terminal, the kbd_buffer can really hold. That may prevent loss of characters on some systems when input is stuffed at us. */ unsigned char cbuf[KBD_BUFFER_SIZE - 1]; - int n_to_read, i; +#ifndef WINDOWSNT + int n_to_read; +#endif + int i; struct tty_display_info *tty = terminal->display_info.tty; int nread = 0; #ifdef subprocesses @@ -7560,7 +7631,7 @@ menu_item_eval_property_1 (Lisp_Object arg) /* If we got a quit from within the menu computation, quit all the way out of it. This takes care of C-] in the debugger. */ if (CONSP (arg) && EQ (XCAR (arg), Qquit)) - Fsignal (Qquit, Qnil); + quit (); return Qnil; } @@ -8833,7 +8904,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, /* The length of the echo buffer when we started reading, and the length of this_command_keys when we started reading. */ - ptrdiff_t echo_start IF_LINT (= 0); + ptrdiff_t echo_start UNINIT; ptrdiff_t keys_start; Lisp_Object current_binding = Qnil; @@ -8881,7 +8952,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, While we're reading, we keep the event here. */ Lisp_Object delayed_switch_frame; - Lisp_Object original_uppercase IF_LINT (= Qnil); + Lisp_Object original_uppercase UNINIT; int original_uppercase_position = -1; /* Gets around Microsoft compiler limitations. */ @@ -8991,7 +9062,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, while those allow us to restart the entire key sequence, echo_local_start and keys_local_start allow us to throw away just one key. */ - ptrdiff_t echo_local_start IF_LINT (= 0); + ptrdiff_t echo_local_start UNINIT; int keys_local_start; Lisp_Object new_binding; @@ -10026,11 +10097,9 @@ DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0, doc: /* Return the current depth in recursive edits. */) (void) { - Lisp_Object temp; - /* Wrap around reliably on integer overflow. */ - EMACS_INT sum = (command_loop_level & INTMASK) + (minibuf_level & INTMASK); - XSETINT (temp, sum); - return temp; + EMACS_INT sum; + INT_ADD_WRAPV (command_loop_level, minibuf_level, &sum); + return make_number (sum); } DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1, @@ -10215,7 +10284,7 @@ static void handle_interrupt_signal (int sig) { /* See if we have an active terminal on our controlling tty. */ - struct terminal *terminal = get_named_terminal ("/dev/tty"); + struct terminal *terminal = get_named_terminal (DEV_TTY); if (!terminal) { /* If there are no frames there, let's pretend that we are a @@ -10284,7 +10353,7 @@ handle_interrupt (bool in_signal_handler) cancel_echoing (); /* XXX This code needs to be revised for multi-tty support. */ - if (!NILP (Vquit_flag) && get_named_terminal ("/dev/tty")) + if (!NILP (Vquit_flag) && get_named_terminal (DEV_TTY)) { if (! in_signal_handler) { @@ -10322,6 +10391,9 @@ handle_interrupt (bool in_signal_handler) is used. Note that [Enter] is not echoed by dos. */ cursor_to (SELECTED_FRAME (), 0, 0); #endif + + write_stdout ("Emacs is resuming after an emergency escape.\n"); + /* It doesn't work to autosave while GC is in progress; the code used for auto-saving doesn't cope with the mark bit. */ if (!gc_in_progress) @@ -10383,7 +10455,7 @@ handle_interrupt (bool in_signal_handler) immediate_quit = false; pthread_sigmask (SIG_SETMASK, &empty_mask, 0); saved = gl_state; - Fsignal (Qquit, Qnil); + quit (); gl_state = saved; } else @@ -10580,7 +10652,7 @@ process. See also `current-input-mode'. */) (Lisp_Object quit) { - struct terminal *t = get_named_terminal ("/dev/tty"); + struct terminal *t = get_named_terminal (DEV_TTY); struct tty_display_info *tty; if (!t) @@ -10727,11 +10799,19 @@ The `posn-' functions access elements of such lists. */) { Lisp_Object x = XCAR (tem); Lisp_Object y = XCAR (XCDR (tem)); + Lisp_Object aux_info = XCDR (XCDR (tem)); + int y_coord = XINT (y); /* Point invisible due to hscrolling? X can be -1 when a newline in a R2L line overflows into the left fringe. */ if (XINT (x) < -1) return Qnil; + if (!NILP (aux_info) && y_coord < 0) + { + int rtop = XINT (XCAR (aux_info)); + + y = make_number (y_coord + rtop); + } tem = Fposn_at_x_y (x, y, window, Qnil); } @@ -10988,6 +11068,7 @@ syms_of_keyboard (void) #ifdef HAVE_NTGUI DEFSYM (Qlanguage_change, "language-change"); + DEFSYM (Qend_session, "end-session"); #endif #ifdef HAVE_DBUS @@ -11092,6 +11173,7 @@ syms_of_keyboard (void) DEFSYM (Qiconify_frame, "iconify-frame"); DEFSYM (Qmake_frame_visible, "make-frame-visible"); DEFSYM (Qselect_window, "select-window"); + DEFSYM (Qselection_request, "selection-request"); { int i; @@ -11729,8 +11811,32 @@ Currently, the only supported values for this variable are `sigusr1' and `sigusr2'. */); Vdebug_on_event = intern_c_string ("sigusr2"); + DEFVAR_BOOL ("attempt-stack-overflow-recovery", + attempt_stack_overflow_recovery, + doc: /* If non-nil, attempt to recover from C stack +overflow. This recovery is unsafe and may lead to deadlocks or data +corruption, but it usually works and may preserve modified buffers +that would otherwise be lost. If nil, treat stack overflow like any +other kind of crash. */); + attempt_stack_overflow_recovery = true; + + DEFVAR_BOOL ("attempt-orderly-shutdown-on-fatal-signal", + attempt_orderly_shutdown_on_fatal_signal, + doc: /* If non-nil, attempt to perform an orderly +shutdown when Emacs receives a fatal signal (e.g., a crash). +This cleanup is unsafe and may lead to deadlocks or data corruption, +but it usually works and may preserve modified buffers that would +otherwise be lost. If nil, crash immediately in response to fatal +signals. */); + attempt_orderly_shutdown_on_fatal_signal = true; + /* Create the initial keyboard. Qt means 'unset'. */ initial_kboard = allocate_kboard (Qt); + + DEFVAR_LISP ("while-no-input-ignore-events", + Vwhile_no_input_ignore_events, + doc: /* Ignored events from while-no-input. */); + Vwhile_no_input_ignore_events = Qnil; } void @@ -11744,6 +11850,10 @@ keys_of_keyboard (void) initial_define_lispy_key (Vspecial_event_map, "delete-frame", "handle-delete-frame"); +#ifdef HAVE_NTGUI + initial_define_lispy_key (Vspecial_event_map, "end-session", + "kill-emacs"); +#endif initial_define_lispy_key (Vspecial_event_map, "ns-put-working-text", "ns-put-working-text"); initial_define_lispy_key (Vspecial_event_map, "ns-unput-working-text", diff --git a/src/keyboard.h b/src/keyboard.h index 387378750c8..435851f79c8 100644 --- a/src/keyboard.h +++ b/src/keyboard.h @@ -415,9 +415,6 @@ extern void unuse_menu_items (void); #define EVENT_HEAD_KIND(event_head) \ (Fget ((event_head), Qevent_kind)) -/* True while doing kbd input. */ -extern bool waiting_for_input; - /* Address (if not 0) of struct timespec to zero out if a SIGIO interrupt happens. */ extern struct timespec *input_available_clear_time; @@ -496,6 +493,8 @@ extern void mark_kboards (void); extern const char *const lispy_function_keys[]; #endif +extern char const DEV_TTY[]; + INLINE_HEADER_END #endif /* EMACS_KEYBOARD_H */ diff --git a/src/keymap.c b/src/keymap.c index c975aad27d8..c4a59adff5b 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -41,6 +41,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include "lisp.h" #include "commands.h" @@ -971,8 +972,18 @@ copy_keymap_1 (Lisp_Object chartable, Lisp_Object idx, Lisp_Object elt) DEFUN ("copy-keymap", Fcopy_keymap, Scopy_keymap, 1, 1, 0, doc: /* Return a copy of the keymap KEYMAP. -The copy starts out with the same definitions of KEYMAP, -but changing either the copy or KEYMAP does not affect the other. + +Note that this is almost never needed. If you want a keymap that's like +another yet with a few changes, you should use map inheritance rather +than copying. I.e. something like: + + (let ((map (make-sparse-keymap))) + (set-keymap-parent map <theirmap>) + (define-key map ...) + ...) + +After performing `copy-keymap', the copy starts out with the same definitions +of KEYMAP, but changing either the copy or KEYMAP does not affect the other. Any key definitions that are subkeymaps are recursively copied. However, a key definition which is a symbol whose definition is a keymap is not copied. */) @@ -1303,7 +1314,7 @@ silly_event_symbol_error (Lisp_Object c) *p = 0; c = reorder_modifiers (c); - AUTO_STRING (new_mods_string, new_mods); + AUTO_STRING_WITH_LEN (new_mods_string, new_mods, p - new_mods); keystring = concat2 (new_mods_string, XCDR (assoc)); error ("To bind the key %s, use [?%s], not [%s]", diff --git a/src/kqueue.c b/src/kqueue.c index 49ca0c95e27..8ebd132fdc3 100644 --- a/src/kqueue.c +++ b/src/kqueue.c @@ -29,6 +29,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "keyboard.h" #include "process.h" +#ifdef HAVE_SYS_RESOURCE_H +#include <sys/resource.h> +#endif /* HAVE_SYS_RESOURCE_H */ + /* File handle for kqueue. */ static int kqueuefd = -1; @@ -364,9 +368,12 @@ only when the upper directory of the renamed file is watched. */) (Lisp_Object file, Lisp_Object flags, Lisp_Object callback) { Lisp_Object watch_object, dir_list; - int fd, oflags; + int maxfd, fd, oflags; u_short fflags = 0; struct kevent kev; +#ifdef HAVE_GETRLIMIT + struct rlimit rlim; +#endif /* HAVE_GETRLIMIT */ /* Check parameters. */ CHECK_STRING (file); @@ -379,6 +386,21 @@ only when the upper directory of the renamed file is watched. */) if (! FUNCTIONP (callback)) wrong_type_argument (Qinvalid_function, callback); + /* Check available file descriptors. */ +#ifdef HAVE_GETRLIMIT + if (! getrlimit (RLIMIT_NOFILE, &rlim)) + maxfd = rlim.rlim_cur; + else +#endif /* HAVE_GETRLIMIT */ + maxfd = 256; + + /* We assume 50 file descriptors are sufficient for the rest of Emacs. */ + if ((maxfd - 50) < XINT (Flength (watch_list))) + xsignal2 + (Qfile_notify_error, + build_string ("File watching not possible, no file descriptor left"), + Flength (watch_list)); + if (kqueuefd < 0) { /* Create kqueue descriptor. */ @@ -469,7 +491,7 @@ WATCH-DESCRIPTOR should be an object returned by `kqueue-add-watch'. */) } DEFUN ("kqueue-valid-p", Fkqueue_valid_p, Skqueue_valid_p, 1, 1, 0, - doc: /* "Check a watch specified by its WATCH-DESCRIPTOR. + doc: /* Check a watch specified by its WATCH-DESCRIPTOR. WATCH-DESCRIPTOR should be an object returned by `kqueue-add-watch'. diff --git a/src/lastfile.c b/src/lastfile.c index d516093b297..27602bd6a44 100644 --- a/src/lastfile.c +++ b/src/lastfile.c @@ -38,7 +38,12 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "lisp.h" +#if ((!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC) \ + || defined WINDOWSNT || defined CYGWIN || defined DARWIN_OS) char my_edata[] = "End of Emacs initialized data"; +#endif + +#ifndef CANNOT_DUMP /* Help unexec locate the end of the .bss area used by Emacs (which isn't always a separate section in NT executables). */ @@ -49,3 +54,5 @@ char my_endbss[1]; of the bss area used by Emacs. */ static char _my_endbss[1]; char * my_endbss_static = _my_endbss; + +#endif diff --git a/src/lisp.h b/src/lisp.h index 25f811e06ef..84963086216 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -21,10 +21,12 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #ifndef EMACS_LISP_H #define EMACS_LISP_H +#include <alloca.h> #include <setjmp.h> #include <stdalign.h> #include <stdarg.h> #include <stddef.h> +#include <string.h> #include <float.h> #include <inttypes.h> #include <limits.h> @@ -68,6 +70,7 @@ DEFINE_GDB_SYMBOL_BEGIN (int, GCTYPEBITS) DEFINE_GDB_SYMBOL_END (GCTYPEBITS) /* EMACS_INT - signed integer wide enough to hold an Emacs value + EMACS_INT_WIDTH - width in bits of EMACS_INT EMACS_INT_MAX - maximum value of EMACS_INT; can be used in #if pI - printf length modifier for EMACS_INT EMACS_UINT - unsigned variant of EMACS_INT */ @@ -77,18 +80,25 @@ DEFINE_GDB_SYMBOL_END (GCTYPEBITS) # elif INTPTR_MAX <= INT_MAX && !defined WIDE_EMACS_INT typedef int EMACS_INT; typedef unsigned int EMACS_UINT; +enum { EMACS_INT_WIDTH = INT_WIDTH }; # define EMACS_INT_MAX INT_MAX # define pI "" # elif INTPTR_MAX <= LONG_MAX && !defined WIDE_EMACS_INT typedef long int EMACS_INT; typedef unsigned long EMACS_UINT; +enum { EMACS_INT_WIDTH = LONG_WIDTH }; # define EMACS_INT_MAX LONG_MAX # define pI "l" # elif INTPTR_MAX <= LLONG_MAX typedef long long int EMACS_INT; typedef unsigned long long int EMACS_UINT; +enum { EMACS_INT_WIDTH = LLONG_WIDTH }; # define EMACS_INT_MAX LLONG_MAX -# define pI "ll" +# ifdef __MINGW32__ +# define pI "I64" +# else +# define pI "ll" +# endif # else # error "INTPTR_MAX too large" # endif @@ -103,11 +113,12 @@ enum { BOOL_VECTOR_BITS_PER_CHAR = /* An unsigned integer type representing a fixed-length bit sequence, suitable for bool vector words, GC mark bits, etc. Normally it is size_t - for speed, but it is unsigned char on weird platforms. */ + for speed, but on weird platforms it is unsigned char and not all + its bits are used. */ #if BOOL_VECTOR_BITS_PER_CHAR == CHAR_BIT typedef size_t bits_word; # define BITS_WORD_MAX SIZE_MAX -enum { BITS_PER_BITS_WORD = CHAR_BIT * sizeof (bits_word) }; +enum { BITS_PER_BITS_WORD = SIZE_WIDTH }; #else typedef unsigned char bits_word; # define BITS_WORD_MAX ((1u << BOOL_VECTOR_BITS_PER_CHAR) - 1) @@ -115,15 +126,6 @@ enum { BITS_PER_BITS_WORD = BOOL_VECTOR_BITS_PER_CHAR }; #endif verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1); -/* Number of bits in some machine integer types. */ -enum - { - BITS_PER_CHAR = CHAR_BIT, - BITS_PER_SHORT = CHAR_BIT * sizeof (short), - BITS_PER_LONG = CHAR_BIT * sizeof (long int), - BITS_PER_EMACS_INT = CHAR_BIT * sizeof (EMACS_INT) - }; - /* printmax_t and uprintmax_t are types for printing large integers. These are the widest integers that are supported for printing. pMd etc. are conversions for printing them. @@ -228,7 +230,7 @@ enum Lisp_Bits #define GCALIGNMENT 8 /* Number of bits in a Lisp_Object value, not counting the tag. */ - VALBITS = BITS_PER_EMACS_INT - GCTYPEBITS, + VALBITS = EMACS_INT_WIDTH - GCTYPEBITS, /* Number of bits in a Lisp fixnum tag. */ INTTYPEBITS = GCTYPEBITS - 1, @@ -256,6 +258,11 @@ DEFINE_GDB_SYMBOL_BEGIN (bool, USE_LSB_TAG) #define USE_LSB_TAG (VAL_MAX / 2 < INTPTR_MAX) DEFINE_GDB_SYMBOL_END (USE_LSB_TAG) +/* Mask for the value (as opposed to the type bits) of a Lisp object. */ +DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) +# define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX) +DEFINE_GDB_SYMBOL_END (VALMASK) + #if !USE_LSB_TAG && !defined WIDE_EMACS_INT # error "USE_LSB_TAG not supported on this platform; please report this." \ "Try 'configure --with-wide-int' to work around the problem." @@ -290,9 +297,8 @@ error !; used elsewhere. FIXME: Remove the lisp_h_OP macros, and define just the inline OP - functions, once most developers have access to GCC 4.8 or later and - can use "gcc -Og" to debug. Maybe in the year 2016. See - Bug#11935. + functions, once "gcc -Og" (new to GCC 4.8) works well enough for + Emacs developers. Maybe in the year 2020. See Bug#11935. Commentary for these macros can be found near their corresponding functions, below. */ @@ -308,7 +314,7 @@ error !; #define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ - ((ok) ? (void) 0 : (void) wrong_type_argument (predicate, x)) + ((ok) ? (void) 0 : wrong_type_argument (predicate, x)) #define lisp_h_CONSP(x) (XTYPE (x) == Lisp_Cons) #define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) #define lisp_h_FLOATP(x) (XTYPE (x) == Lisp_Float) @@ -318,7 +324,8 @@ error !; #define lisp_h_NILP(x) EQ (x, Qnil) #define lisp_h_SET_SYMBOL_VAL(sym, v) \ (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value = (v)) -#define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->constant) +#define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->trapped_write == SYMBOL_NOWRITE) +#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->trapped_write) #define lisp_h_SYMBOL_VAL(sym) \ (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value) #define lisp_h_SYMBOLP(x) (XTYPE (x) == Lisp_Symbol) @@ -341,7 +348,9 @@ error !; (struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \ + (char *) lispsym)) # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) -# define lisp_h_XUNTAG(a, type) ((void *) (intptr_t) (XLI (a) - (type))) +# define lisp_h_XUNTAG(a, type) \ + __builtin_assume_aligned ((void *) (intptr_t) (XLI (a) - (type)), \ + GCALIGNMENT) #endif /* When compiling via gcc -O0, define the key operations as macros, as @@ -371,6 +380,7 @@ error !; # define NILP(x) lisp_h_NILP (x) # define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v) # define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) +# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) # define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) # define SYMBOLP(x) lisp_h_SYMBOLP (x) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) @@ -547,68 +557,87 @@ typedef EMACS_INT Lisp_Object; #define LISP_INITIALLY(i) (i) enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; #endif /* CHECK_LISP_OBJECT_TYPE */ - -#define LISP_INITIALLY_ZERO LISP_INITIALLY (0) /* Forward declarations. */ /* Defined in this file. */ -union Lisp_Fwd; -INLINE bool BOOL_VECTOR_P (Lisp_Object); -INLINE bool BUFFER_OBJFWDP (union Lisp_Fwd *); -INLINE bool BUFFERP (Lisp_Object); -INLINE bool CHAR_TABLE_P (Lisp_Object); -INLINE Lisp_Object CHAR_TABLE_REF_ASCII (Lisp_Object, ptrdiff_t); -INLINE bool (CONSP) (Lisp_Object); -INLINE bool (FLOATP) (Lisp_Object); -INLINE bool functionp (Lisp_Object); -INLINE bool (INTEGERP) (Lisp_Object); -INLINE bool (MARKERP) (Lisp_Object); -INLINE bool (MISCP) (Lisp_Object); -INLINE bool (NILP) (Lisp_Object); -INLINE bool OVERLAYP (Lisp_Object); -INLINE bool PROCESSP (Lisp_Object); -INLINE bool PSEUDOVECTORP (Lisp_Object, int); -INLINE bool SAVE_VALUEP (Lisp_Object); -INLINE bool FINALIZERP (Lisp_Object); - -#ifdef HAVE_MODULES -INLINE bool USER_PTRP (Lisp_Object); -INLINE struct Lisp_User_Ptr *(XUSER_PTR) (Lisp_Object); -#endif - INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, Lisp_Object); -INLINE bool STRINGP (Lisp_Object); -INLINE bool SUB_CHAR_TABLE_P (Lisp_Object); -INLINE bool SUBRP (Lisp_Object); -INLINE bool (SYMBOLP) (Lisp_Object); -INLINE bool (VECTORLIKEP) (Lisp_Object); -INLINE bool WINDOWP (Lisp_Object); -INLINE bool TERMINALP (Lisp_Object); -INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object); -INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object); -INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object); -INLINE void *(XUNTAG) (Lisp_Object, int); /* Defined in chartab.c. */ extern Lisp_Object char_table_ref (Lisp_Object, int); extern void char_table_set (Lisp_Object, int, Lisp_Object); /* Defined in data.c. */ -extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object); -extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object); +extern _Noreturn void wrong_type_argument (Lisp_Object, Lisp_Object); + +#ifdef CANNOT_DUMP +enum { might_dump = false }; +#elif defined DOUG_LEA_MALLOC /* Defined in emacs.c. */ extern bool might_dump; +#endif /* True means Emacs has already been initialized. Used during startup to detect startup of dumped Emacs. */ extern bool initialized; +extern bool generating_ldefs_boot; + /* Defined in floatfns.c. */ extern double extract_float (Lisp_Object); +/* Low-level conversion and type checking. */ + +/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. + At the machine level, these operations are no-ops. */ + +INLINE EMACS_INT +(XLI) (Lisp_Object o) +{ + return lisp_h_XLI (o); +} + +INLINE Lisp_Object +(XIL) (EMACS_INT i) +{ + return lisp_h_XIL (i); +} + +/* Extract A's type. */ + +INLINE enum Lisp_Type +(XTYPE) (Lisp_Object a) +{ +#if USE_LSB_TAG + return lisp_h_XTYPE (a); +#else + EMACS_UINT i = XLI (a); + return USE_LSB_TAG ? i & ~VALMASK : i >> VALBITS; +#endif +} + +INLINE void +(CHECK_TYPE) (int ok, Lisp_Object predicate, Lisp_Object x) +{ + lisp_h_CHECK_TYPE (ok, predicate, x); +} + +/* Extract A's pointer value, assuming A's type is TYPE. */ + +INLINE void * +(XUNTAG) (Lisp_Object a, int type) +{ +#if USE_LSB_TAG + return lisp_h_XUNTAG (a, type); +#else + intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK; + return (void *) i; +#endif +} + + /* Interned state of a symbol. */ enum symbol_interned @@ -626,6 +655,13 @@ enum symbol_redirect SYMBOL_FORWARDED = 3 }; +enum symbol_trapped_write +{ + SYMBOL_UNTRAPPED_WRITE = 0, + SYMBOL_NOWRITE = 1, + SYMBOL_TRAPPED_WRITE = 2 +}; + struct Lisp_Symbol { bool_bf gcmarkbit : 1; @@ -637,10 +673,10 @@ struct Lisp_Symbol 3 : it's a forwarding variable, the value is in `forward'. */ ENUM_BF (symbol_redirect) redirect : 3; - /* Non-zero means symbol is constant, i.e. changing its value - should signal an error. If the value is 3, then the var - can be changed, but only by `defconst'. */ - unsigned constant : 2; + /* 0 : normal case, just set the value + 1 : constant, cannot set, e.g. nil, t, :keywords. + 2 : trap the write, call watcher functions. */ + ENUM_BF (symbol_trapped_write) trapped_write : 2; /* Interned state of the symbol. This is an enumerator from enum symbol_interned. */ @@ -719,12 +755,20 @@ struct Lisp_Symbol except the former expands to an integer constant expression. */ #define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym) +/* LISPSYM_INITIALLY (Qfoo) is equivalent to Qfoo except it is + designed for use as an initializer, even for a constant initializer. */ +#define LISPSYM_INITIALLY(name) LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name)) + /* Declare extern constants for Lisp symbols. These can be helpful when using a debugger like GDB, on older platforms where the debug format does not represent C macros. */ #define DEFINE_LISP_SYMBOL(name) \ DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ - DEFINE_GDB_SYMBOL_END (LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name))) + DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) + +/* The index of the C-defined Lisp symbol SYM. + This can be used in a static initializer. */ +#define SYMBOL_INDEX(sym) i##sym /* By default, define macros for Qt, etc., as this leads to a bit better performance in the core Emacs interpreter. A plugin can @@ -736,19 +780,74 @@ struct Lisp_Symbol #include "globals.h" -/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. - At the machine level, these operations are no-ops. */ +/* Header of vector-like objects. This documents the layout constraints on + vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents + compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR + and PSEUDOVECTORP cast their pointers to struct vectorlike_header *, + because when two such pointers potentially alias, a compiler won't + incorrectly reorder loads and stores to their size fields. See + Bug#8546. */ +struct vectorlike_header + { + /* The only field contains various pieces of information: + - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit. + - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain + vector (0) or a pseudovector (1). + - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number + of slots) of the vector. + - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields: + - a) pseudovector subtype held in PVEC_TYPE_MASK field; + - b) number of Lisp_Objects slots at the beginning of the object + held in PSEUDOVECTOR_SIZE_MASK field. These objects are always + traced by the GC; + - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and + measured in word_size units. Rest fields may also include + Lisp_Objects, but these objects usually needs some special treatment + during GC. + There are some exceptions. For PVEC_FREE, b) is always zero. For + PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero. + Current layout limits the pseudovectors to 63 PVEC_xxx subtypes, + 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */ + ptrdiff_t size; + }; -INLINE EMACS_INT -(XLI) (Lisp_Object o) +INLINE bool +(SYMBOLP) (Lisp_Object x) { - return lisp_h_XLI (o); + return lisp_h_SYMBOLP (x); +} + +INLINE struct Lisp_Symbol * +(XSYMBOL) (Lisp_Object a) +{ +#if USE_LSB_TAG + return lisp_h_XSYMBOL (a); +#else + eassert (SYMBOLP (a)); + intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol); + void *p = (char *) lispsym + i; + return p; +#endif } INLINE Lisp_Object -(XIL) (EMACS_INT i) +make_lisp_symbol (struct Lisp_Symbol *sym) { - return lisp_h_XIL (i); + Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym)); + eassert (XSYMBOL (a) == sym); + return a; +} + +INLINE Lisp_Object +builtin_lisp_symbol (int index) +{ + return make_lisp_symbol (lispsym + index); +} + +INLINE void +(CHECK_SYMBOL) (Lisp_Object x) +{ + lisp_h_CHECK_SYMBOL (x); } /* In the size word of a vector, this bit means the vector has been marked. */ @@ -782,6 +881,9 @@ enum pvec_type PVEC_OTHER, PVEC_XWIDGET, PVEC_XWIDGET_VIEW, + PVEC_THREAD, + PVEC_MUTEX, + PVEC_CONDVAR, /* These should be last, check internal_equal to see why. */ PVEC_COMPILED, @@ -816,11 +918,6 @@ enum More_Lisp_Bits XCONS (tem) is the struct Lisp_Cons * pointing to the memory for that cons. */ -/* Mask for the value (as opposed to the type bits) of a Lisp object. */ -DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) -# define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX) -DEFINE_GDB_SYMBOL_END (VALMASK) - /* Largest and smallest representable fixnum values. These are the C values. They are macros for use in static initializers. */ #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) @@ -848,24 +945,6 @@ INLINE EMACS_INT return n; } -INLINE struct Lisp_Symbol * -(XSYMBOL) (Lisp_Object a) -{ - return lisp_h_XSYMBOL (a); -} - -INLINE enum Lisp_Type -(XTYPE) (Lisp_Object a) -{ - return lisp_h_XTYPE (a); -} - -INLINE void * -(XUNTAG) (Lisp_Object a, int type) -{ - return lisp_h_XUNTAG (a, type); -} - #else /* ! USE_LSB_TAG */ /* Although compiled only if ! USE_LSB_TAG, the following functions @@ -917,32 +996,6 @@ XFASTINT (Lisp_Object a) return n; } -/* Extract A's type. */ -INLINE enum Lisp_Type -XTYPE (Lisp_Object a) -{ - EMACS_UINT i = XLI (a); - return USE_LSB_TAG ? i & ~VALMASK : i >> VALBITS; -} - -/* Extract A's value as a symbol. */ -INLINE struct Lisp_Symbol * -XSYMBOL (Lisp_Object a) -{ - eassert (SYMBOLP (a)); - intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol); - void *p = (char *) lispsym + i; - return p; -} - -/* Extract A's pointer value, assuming A's type is TYPE. */ -INLINE void * -XUNTAG (Lisp_Object a, int type) -{ - intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK; - return (void *) i; -} - #endif /* ! USE_LSB_TAG */ /* Extract A's value as an unsigned integer. */ @@ -993,98 +1046,6 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) return num < lower ? lower : num <= upper ? num : upper; } - -/* Extract a value or address from a Lisp_Object. */ - -INLINE struct Lisp_Cons * -(XCONS) (Lisp_Object a) -{ - return lisp_h_XCONS (a); -} - -INLINE struct Lisp_Vector * -XVECTOR (Lisp_Object a) -{ - eassert (VECTORLIKEP (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct Lisp_String * -XSTRING (Lisp_Object a) -{ - eassert (STRINGP (a)); - return XUNTAG (a, Lisp_String); -} - -/* The index of the C-defined Lisp symbol SYM. - This can be used in a static initializer. */ -#define SYMBOL_INDEX(sym) i##sym - -INLINE struct Lisp_Float * -XFLOAT (Lisp_Object a) -{ - eassert (FLOATP (a)); - return XUNTAG (a, Lisp_Float); -} - -/* Pseudovector types. */ - -INLINE struct Lisp_Process * -XPROCESS (Lisp_Object a) -{ - eassert (PROCESSP (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct window * -XWINDOW (Lisp_Object a) -{ - eassert (WINDOWP (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct terminal * -XTERMINAL (Lisp_Object a) -{ - eassert (TERMINALP (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct Lisp_Subr * -XSUBR (Lisp_Object a) -{ - eassert (SUBRP (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct buffer * -XBUFFER (Lisp_Object a) -{ - eassert (BUFFERP (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct Lisp_Char_Table * -XCHAR_TABLE (Lisp_Object a) -{ - eassert (CHAR_TABLE_P (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct Lisp_Sub_Char_Table * -XSUB_CHAR_TABLE (Lisp_Object a) -{ - eassert (SUB_CHAR_TABLE_P (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - -INLINE struct Lisp_Bool_Vector * -XBOOL_VECTOR (Lisp_Object a) -{ - eassert (BOOL_VECTOR_P (a)); - return XUNTAG (a, Lisp_Vectorlike); -} - /* Construct a Lisp_Object from a value or address. */ INLINE Lisp_Object @@ -1095,18 +1056,10 @@ make_lisp_ptr (void *ptr, enum Lisp_Type type) return a; } -INLINE Lisp_Object -make_lisp_symbol (struct Lisp_Symbol *sym) -{ - Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym)); - eassert (XSYMBOL (a) == sym); - return a; -} - -INLINE Lisp_Object -builtin_lisp_symbol (int index) +INLINE bool +(INTEGERP) (Lisp_Object x) { - return make_lisp_symbol (lispsym + index); + return lisp_h_INTEGERP (x); } #define XSETINT(a, b) ((a) = make_number (b)) @@ -1151,6 +1104,9 @@ builtin_lisp_symbol (int index) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) +#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) +#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)) +#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR)) /* Efficiently convert a pointer to a Lisp object and back. The pointer is represented as a Lisp integer, so the garbage collector @@ -1171,14 +1127,6 @@ make_pointer_integer (void *p) return a; } -/* Type checking. */ - -INLINE void -(CHECK_TYPE) (int ok, Lisp_Object predicate, Lisp_Object x) -{ - lisp_h_CHECK_TYPE (ok, predicate, x); -} - /* See the macros in intervals.h. */ typedef struct interval *INTERVAL; @@ -1198,6 +1146,30 @@ struct GCALIGNED Lisp_Cons } u; }; +INLINE bool +(NILP) (Lisp_Object x) +{ + return lisp_h_NILP (x); +} + +INLINE bool +(CONSP) (Lisp_Object x) +{ + return lisp_h_CONSP (x); +} + +INLINE void +CHECK_CONS (Lisp_Object x) +{ + CHECK_TYPE (CONSP (x), Qconsp, x); +} + +INLINE struct Lisp_Cons * +(XCONS) (Lisp_Object a) +{ + return lisp_h_XCONS (a); +} + /* Take the car or cdr of something known to be a cons cell. */ /* The _addr functions shouldn't be used outside of the minimal set of code that has to know what a cons cell looks like. Other code not @@ -1249,16 +1221,20 @@ XSETCDR (Lisp_Object c, Lisp_Object n) INLINE Lisp_Object CAR (Lisp_Object c) { - return (CONSP (c) ? XCAR (c) - : NILP (c) ? Qnil - : wrong_type_argument (Qlistp, c)); + if (CONSP (c)) + return XCAR (c); + if (!NILP (c)) + wrong_type_argument (Qlistp, c); + return Qnil; } INLINE Lisp_Object CDR (Lisp_Object c) { - return (CONSP (c) ? XCDR (c) - : NILP (c) ? Qnil - : wrong_type_argument (Qlistp, c)); + if (CONSP (c)) + return XCDR (c); + if (!NILP (c)) + wrong_type_argument (Qlistp, c); + return Qnil; } /* Take the car or cdr of something whose type is not known. */ @@ -1283,6 +1259,25 @@ struct GCALIGNED Lisp_String unsigned char *data; }; +INLINE bool +STRINGP (Lisp_Object x) +{ + return XTYPE (x) == Lisp_String; +} + +INLINE void +CHECK_STRING (Lisp_Object x) +{ + CHECK_TYPE (STRINGP (x), Qstringp, x); +} + +INLINE struct Lisp_String * +XSTRING (Lisp_Object a) +{ + eassert (STRINGP (a)); + return XUNTAG (a, Lisp_String); +} + /* True if STR is a multibyte string. */ INLINE bool STRING_MULTIBYTE (Lisp_Object str) @@ -1378,37 +1373,6 @@ STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize) XSTRING (string)->size = newsize; } -/* Header of vector-like objects. This documents the layout constraints on - vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents - compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR - and PSEUDOVECTORP cast their pointers to struct vectorlike_header *, - because when two such pointers potentially alias, a compiler won't - incorrectly reorder loads and stores to their size fields. See - Bug#8546. */ -struct vectorlike_header - { - /* The only field contains various pieces of information: - - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit. - - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain - vector (0) or a pseudovector (1). - - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number - of slots) of the vector. - - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields: - - a) pseudovector subtype held in PVEC_TYPE_MASK field; - - b) number of Lisp_Objects slots at the beginning of the object - held in PSEUDOVECTOR_SIZE_MASK field. These objects are always - traced by the GC; - - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and - measured in word_size units. Rest fields may also include - Lisp_Objects, but these objects usually needs some special treatment - during GC. - There are some exceptions. For PVEC_FREE, b) is always zero. For - PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero. - Current layout limits the pseudovectors to 63 PVEC_xxx subtypes, - 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */ - ptrdiff_t size; - }; - /* A regular vector is just a header plus an array of Lisp_Objects. */ struct Lisp_Vector @@ -1417,12 +1381,61 @@ struct Lisp_Vector Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; }; -/* C11 prohibits alignof (struct Lisp_Vector), so compute it manually. */ -enum - { - ALIGNOF_STRUCT_LISP_VECTOR - = alignof (union { struct vectorlike_header a; Lisp_Object b; }) - }; +INLINE bool +(VECTORLIKEP) (Lisp_Object x) +{ + return lisp_h_VECTORLIKEP (x); +} + +INLINE struct Lisp_Vector * +XVECTOR (Lisp_Object a) +{ + eassert (VECTORLIKEP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +INLINE ptrdiff_t +ASIZE (Lisp_Object array) +{ + ptrdiff_t size = XVECTOR (array)->header.size; + eassume (0 <= size); + return size; +} + +INLINE bool +VECTORP (Lisp_Object x) +{ + return VECTORLIKEP (x) && ! (ASIZE (x) & PSEUDOVECTOR_FLAG); +} + +INLINE void +CHECK_VECTOR (Lisp_Object x) +{ + CHECK_TYPE (VECTORP (x), Qvectorp, x); +} + +/* A pseudovector is like a vector, but has other non-Lisp components. */ + +INLINE bool +PSEUDOVECTOR_TYPEP (struct vectorlike_header *a, int code) +{ + return ((a->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) + == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); +} + +/* True if A is a pseudovector whose code is CODE. */ +INLINE bool +PSEUDOVECTORP (Lisp_Object a, int code) +{ + if (! VECTORLIKEP (a)) + return false; + else + { + /* Converting to struct vectorlike_header * avoids aliasing issues. */ + struct vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike); + return PSEUDOVECTOR_TYPEP (h, code); + } +} /* A boolvector is a kind of vectorlike, with contents like a string. */ @@ -1440,6 +1453,51 @@ struct Lisp_Bool_Vector bits_word data[FLEXIBLE_ARRAY_MEMBER]; }; +/* Some handy constants for calculating sizes + and offsets, mostly of vectorlike objects. */ + +enum + { + header_size = offsetof (struct Lisp_Vector, contents), + bool_header_size = offsetof (struct Lisp_Bool_Vector, data), + word_size = sizeof (Lisp_Object) + }; + +/* The number of data words and bytes in a bool vector with SIZE bits. */ + +INLINE EMACS_INT +bool_vector_words (EMACS_INT size) +{ + eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); + return (size + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD; +} + +INLINE EMACS_INT +bool_vector_bytes (EMACS_INT size) +{ + eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); + return (size + BOOL_VECTOR_BITS_PER_CHAR - 1) / BOOL_VECTOR_BITS_PER_CHAR; +} + +INLINE bool +BOOL_VECTOR_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_BOOL_VECTOR); +} + +INLINE void +CHECK_BOOL_VECTOR (Lisp_Object x) +{ + CHECK_TYPE (BOOL_VECTOR_P (x), Qbool_vector_p, x); +} + +INLINE struct Lisp_Bool_Vector * +XBOOL_VECTOR (Lisp_Object a) +{ + eassert (BOOL_VECTOR_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + INLINE EMACS_INT bool_vector_size (Lisp_Object a) { @@ -1460,22 +1518,6 @@ bool_vector_uchar_data (Lisp_Object a) return (unsigned char *) bool_vector_data (a); } -/* The number of data words and bytes in a bool vector with SIZE bits. */ - -INLINE EMACS_INT -bool_vector_words (EMACS_INT size) -{ - eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); - return (size + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD; -} - -INLINE EMACS_INT -bool_vector_bytes (EMACS_INT size) -{ - eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1)); - return (size + BOOL_VECTOR_BITS_PER_CHAR - 1) / BOOL_VECTOR_BITS_PER_CHAR; -} - /* True if A's Ith bit is set. */ INLINE bool @@ -1508,16 +1550,6 @@ bool_vector_set (Lisp_Object a, EMACS_INT i, bool b) *addr &= ~ (1 << (i % BOOL_VECTOR_BITS_PER_CHAR)); } -/* Some handy constants for calculating sizes - and offsets, mostly of vectorlike objects. */ - -enum - { - header_size = offsetof (struct Lisp_Vector, contents), - bool_header_size = offsetof (struct Lisp_Bool_Vector, data), - word_size = sizeof (Lisp_Object) - }; - /* Conveniences for dealing with Lisp arrays. */ INLINE Lisp_Object @@ -1533,14 +1565,6 @@ aref_addr (Lisp_Object array, ptrdiff_t idx) } INLINE ptrdiff_t -ASIZE (Lisp_Object array) -{ - ptrdiff_t size = XVECTOR (array)->header.size; - eassume (0 <= size); - return size; -} - -INLINE ptrdiff_t gc_asize (Lisp_Object array) { /* Like ASIZE, but also can be used in the garbage collector. */ @@ -1657,6 +1681,19 @@ struct Lisp_Char_Table Lisp_Object extras[FLEXIBLE_ARRAY_MEMBER]; }; +INLINE bool +CHAR_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_CHAR_TABLE); +} + +INLINE struct Lisp_Char_Table * +XCHAR_TABLE (Lisp_Object a) +{ + eassert (CHAR_TABLE_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + struct Lisp_Sub_Char_Table { /* HEADER.SIZE is the vector's size field, which also holds the @@ -1678,6 +1715,19 @@ struct Lisp_Sub_Char_Table Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; }; +INLINE bool +SUB_CHAR_TABLE_P (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_SUB_CHAR_TABLE); +} + +INLINE struct Lisp_Sub_Char_Table * +XSUB_CHAR_TABLE (Lisp_Object a) +{ + eassert (SUB_CHAR_TABLE_P (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + INLINE Lisp_Object CHAR_TABLE_REF_ASCII (Lisp_Object ct, ptrdiff_t idx) { @@ -1740,9 +1790,22 @@ struct Lisp_Subr short min_args, max_args; const char *symbol_name; const char *intspec; - const char *doc; + EMACS_INT doc; }; +INLINE bool +SUBRP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_SUBR); +} + +INLINE struct Lisp_Subr * +XSUBR (Lisp_Object a) +{ + eassert (SUBRP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + enum char_table_specials { /* This is the number of slots that every char table must have. This @@ -1769,6 +1832,8 @@ verify (offsetof (struct Lisp_Sub_Char_Table, contents) == (offsetof (struct Lisp_Vector, contents) + SUB_CHAR_TABLE_OFFSET * sizeof (Lisp_Object))); +#include "thread.h" + /*********************************************************************** Symbols ***********************************************************************/ @@ -1784,19 +1849,19 @@ INLINE Lisp_Object INLINE struct Lisp_Symbol * SYMBOL_ALIAS (struct Lisp_Symbol *sym) { - eassert (sym->redirect == SYMBOL_VARALIAS); + eassume (sym->redirect == SYMBOL_VARALIAS && sym->val.alias); return sym->val.alias; } INLINE struct Lisp_Buffer_Local_Value * SYMBOL_BLV (struct Lisp_Symbol *sym) { - eassert (sym->redirect == SYMBOL_LOCALIZED); + eassume (sym->redirect == SYMBOL_LOCALIZED && sym->val.blv); return sym->val.blv; } INLINE union Lisp_Fwd * SYMBOL_FWD (struct Lisp_Symbol *sym) { - eassert (sym->redirect == SYMBOL_FORWARDED); + eassume (sym->redirect == SYMBOL_FORWARDED && sym->val.fwd); return sym->val.fwd; } @@ -1809,19 +1874,19 @@ INLINE void INLINE void SET_SYMBOL_ALIAS (struct Lisp_Symbol *sym, struct Lisp_Symbol *v) { - eassert (sym->redirect == SYMBOL_VARALIAS); + eassume (sym->redirect == SYMBOL_VARALIAS && v); sym->val.alias = v; } INLINE void SET_SYMBOL_BLV (struct Lisp_Symbol *sym, struct Lisp_Buffer_Local_Value *v) { - eassert (sym->redirect == SYMBOL_LOCALIZED); + eassume (sym->redirect == SYMBOL_LOCALIZED && v); sym->val.blv = v; } INLINE void SET_SYMBOL_FWD (struct Lisp_Symbol *sym, union Lisp_Fwd *v) { - eassert (sym->redirect == SYMBOL_FORWARDED); + eassume (sym->redirect == SYMBOL_FORWARDED && v); sym->val.fwd = v; } @@ -1847,9 +1912,20 @@ SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym) return XSYMBOL (sym)->interned == SYMBOL_INTERNED_IN_INITIAL_OBARRAY; } -/* Value is non-zero if symbol is considered a constant, i.e. its - value cannot be changed (there is an exception for keyword symbols, - whose value can be set to the keyword symbol itself). */ +/* Value is non-zero if symbol cannot be changed through a simple set, + i.e. it's a constant (e.g. nil, t, :keywords), or it has some + watching functions. */ + +INLINE int +(SYMBOL_TRAPPED_WRITE_P) (Lisp_Object sym) +{ + return lisp_h_SYMBOL_TRAPPED_WRITE_P (sym); +} + +/* Value is non-zero if symbol cannot be changed at all, i.e. it's a + constant (e.g. nil, t, :keywords). Code that actually wants to + write to SYM, should also check whether there are any watching + functions. */ INLINE int (SYMBOL_CONSTANT_P) (Lisp_Object sym) @@ -2022,7 +2098,7 @@ static double const DEFAULT_REHASH_SIZE = 1.5; INLINE EMACS_UINT sxhash_combine (EMACS_UINT x, EMACS_UINT y) { - return (x << 4) + (x >> (BITS_PER_EMACS_INT - 4)) + y; + return (x << 4) + (x >> (EMACS_INT_WIDTH - 4)) + y; } /* Hash X, returning a value that fits into a fixnum. */ @@ -2030,7 +2106,7 @@ sxhash_combine (EMACS_UINT x, EMACS_UINT y) INLINE EMACS_UINT SXHASH_REDUCE (EMACS_UINT x) { - return (x ^ x >> (BITS_PER_EMACS_INT - FIXNUM_BITS)) & INTMASK; + return (x ^ x >> (EMACS_INT_WIDTH - FIXNUM_BITS)) & INTMASK; } /* These structures are used for various misc types. */ @@ -2042,6 +2118,25 @@ struct Lisp_Misc_Any /* Supertype of all Misc types. */ unsigned spacer : 15; }; +INLINE bool +(MISCP) (Lisp_Object x) +{ + return lisp_h_MISCP (x); +} + +INLINE struct Lisp_Misc_Any * +XMISCANY (Lisp_Object a) +{ + eassert (MISCP (a)); + return XUNTAG (a, Lisp_Misc); +} + +INLINE enum Lisp_Misc_Type +XMISCTYPE (Lisp_Object a) +{ + return XMISCANY (a)->type; +} + struct Lisp_Marker { ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Marker */ @@ -2107,18 +2202,8 @@ struct Lisp_Overlay Lisp_Object plist; }; -/* Types of data which may be saved in a Lisp_Save_Value. */ - -enum - { - SAVE_UNUSED, - SAVE_INTEGER, - SAVE_FUNCPOINTER, - SAVE_POINTER, - SAVE_OBJECT - }; - -/* Number of bits needed to store one of the above values. */ +/* Number of bits needed to store one of the values + SAVE_UNUSED..SAVE_OBJECT. */ enum { SAVE_SLOT_BITS = 3 }; /* Number of slots in a save value where save_type is nonzero. */ @@ -2128,8 +2213,15 @@ enum { SAVE_VALUE_SLOTS = 4 }; enum { SAVE_TYPE_BITS = SAVE_VALUE_SLOTS * SAVE_SLOT_BITS + 1 }; +/* Types of data which may be saved in a Lisp_Save_Value. */ + enum Lisp_Save_Type { + SAVE_UNUSED, + SAVE_INTEGER, + SAVE_FUNCPOINTER, + SAVE_POINTER, + SAVE_OBJECT, SAVE_TYPE_INT_INT = SAVE_INTEGER + (SAVE_INTEGER << SAVE_SLOT_BITS), SAVE_TYPE_INT_INT_INT = (SAVE_INTEGER + (SAVE_TYPE_INT_INT << SAVE_SLOT_BITS)), @@ -2147,6 +2239,12 @@ enum Lisp_Save_Type SAVE_TYPE_MEMORY = SAVE_TYPE_PTR_INT + (1 << (SAVE_TYPE_BITS - 1)) }; +/* SAVE_SLOT_BITS must be large enough to represent these values. */ +verify (((SAVE_UNUSED | SAVE_INTEGER | SAVE_FUNCPOINTER + | SAVE_POINTER | SAVE_OBJECT) + >> SAVE_SLOT_BITS) + == 0); + /* Special object used to hold a different values for later use. This is mostly used to package C integers and pointers to call @@ -2196,6 +2294,19 @@ struct Lisp_Save_Value } data[SAVE_VALUE_SLOTS]; }; +INLINE bool +SAVE_VALUEP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value; +} + +INLINE struct Lisp_Save_Value * +XSAVE_VALUE (Lisp_Object a) +{ + eassert (SAVE_VALUEP (a)); + return XUNTAG (a, Lisp_Misc); +} + /* Return the type of V's Nth saved value. */ INLINE int save_type (struct Lisp_Save_Value *v, int n) @@ -2276,6 +2387,19 @@ struct Lisp_Finalizer Lisp_Object function; }; +INLINE bool +FINALIZERP (Lisp_Object x) +{ + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer; +} + +INLINE struct Lisp_Finalizer * +XFINALIZER (Lisp_Object a) +{ + eassert (FINALIZERP (a)); + return XUNTAG (a, Lisp_Misc); +} + /* A miscellaneous object, when it's on the free list. */ struct Lisp_Free { @@ -2307,53 +2431,44 @@ XMISC (Lisp_Object a) return XUNTAG (a, Lisp_Misc); } -INLINE struct Lisp_Misc_Any * -XMISCANY (Lisp_Object a) -{ - eassert (MISCP (a)); - return & XMISC (a)->u_any; -} - -INLINE enum Lisp_Misc_Type -XMISCTYPE (Lisp_Object a) +INLINE bool +(MARKERP) (Lisp_Object x) { - return XMISCANY (a)->type; + return lisp_h_MARKERP (x); } INLINE struct Lisp_Marker * XMARKER (Lisp_Object a) { eassert (MARKERP (a)); - return & XMISC (a)->u_marker; + return XUNTAG (a, Lisp_Misc); } -INLINE struct Lisp_Overlay * -XOVERLAY (Lisp_Object a) +INLINE bool +OVERLAYP (Lisp_Object x) { - eassert (OVERLAYP (a)); - return & XMISC (a)->u_overlay; + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay; } -INLINE struct Lisp_Save_Value * -XSAVE_VALUE (Lisp_Object a) +INLINE struct Lisp_Overlay * +XOVERLAY (Lisp_Object a) { - eassert (SAVE_VALUEP (a)); - return & XMISC (a)->u_save_value; + eassert (OVERLAYP (a)); + return XUNTAG (a, Lisp_Misc); } -INLINE struct Lisp_Finalizer * -XFINALIZER (Lisp_Object a) +#ifdef HAVE_MODULES +INLINE bool +USER_PTRP (Lisp_Object x) { - eassert (FINALIZERP (a)); - return & XMISC (a)->u_finalizer; + return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_User_Ptr; } -#ifdef HAVE_MODULES INLINE struct Lisp_User_Ptr * XUSER_PTR (Lisp_Object a) { eassert (USER_PTRP (a)); - return & XMISC (a)->u_user_ptr; + return XUNTAG (a, Lisp_Misc); } #endif @@ -2399,7 +2514,7 @@ struct Lisp_Buffer_Objfwd }; /* struct Lisp_Buffer_Local_Value is used in a symbol value cell when - the symbol has buffer-local or frame-local bindings. (Exception: + the symbol has buffer-local bindings. (Exception: some buffer-local variables are built-in, with their values stored in the buffer structure itself. They are handled differently, using struct Lisp_Buffer_Objfwd.) @@ -2427,9 +2542,6 @@ struct Lisp_Buffer_Local_Value /* True means that merely setting the variable creates a local binding for the current buffer. */ bool_bf local_if_set : 1; - /* True means this variable can have frame-local bindings, otherwise, it is - can have buffer-local bindings. The two cannot be combined. */ - bool_bf frame_local : 1; /* True means that the binding now loaded was found. Presumably equivalent to (defcell!=valcell). */ bool_bf found : 1; @@ -2471,6 +2583,12 @@ XFWDTYPE (union Lisp_Fwd *a) return a->u_intfwd.type; } +INLINE bool +BUFFER_OBJFWDP (union Lisp_Fwd *a) +{ + return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj; +} + INLINE struct Lisp_Buffer_Objfwd * XBUFFER_OBJFWD (union Lisp_Fwd *a) { @@ -2488,6 +2606,19 @@ struct Lisp_Float } u; }; +INLINE bool +(FLOATP) (Lisp_Object x) +{ + return lisp_h_FLOATP (x); +} + +INLINE struct Lisp_Float * +XFLOAT (Lisp_Object a) +{ + eassert (FLOATP (a)); + return XUNTAG (a, Lisp_Float); +} + INLINE double XFLOAT_DATA (Lisp_Object f) { @@ -2551,12 +2682,6 @@ enum char_bits /* Data type checking. */ INLINE bool -(NILP) (Lisp_Object x) -{ - return lisp_h_NILP (x); -} - -INLINE bool NUMBERP (Lisp_Object x) { return INTEGERP (x) || FLOATP (x); @@ -2579,109 +2704,11 @@ RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi) && XINT (x) <= TYPE_MAXIMUM (type)) INLINE bool -(CONSP) (Lisp_Object x) -{ - return lisp_h_CONSP (x); -} -INLINE bool -(FLOATP) (Lisp_Object x) -{ - return lisp_h_FLOATP (x); -} -INLINE bool -(MISCP) (Lisp_Object x) -{ - return lisp_h_MISCP (x); -} -INLINE bool -(SYMBOLP) (Lisp_Object x) -{ - return lisp_h_SYMBOLP (x); -} -INLINE bool -(INTEGERP) (Lisp_Object x) -{ - return lisp_h_INTEGERP (x); -} -INLINE bool -(VECTORLIKEP) (Lisp_Object x) -{ - return lisp_h_VECTORLIKEP (x); -} -INLINE bool -(MARKERP) (Lisp_Object x) -{ - return lisp_h_MARKERP (x); -} - -INLINE bool -STRINGP (Lisp_Object x) -{ - return XTYPE (x) == Lisp_String; -} -INLINE bool -VECTORP (Lisp_Object x) -{ - return VECTORLIKEP (x) && ! (ASIZE (x) & PSEUDOVECTOR_FLAG); -} -INLINE bool -OVERLAYP (Lisp_Object x) -{ - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay; -} -INLINE bool -SAVE_VALUEP (Lisp_Object x) -{ - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value; -} - -INLINE bool -FINALIZERP (Lisp_Object x) -{ - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer; -} - -#ifdef HAVE_MODULES -INLINE bool -USER_PTRP (Lisp_Object x) -{ - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_User_Ptr; -} -#endif - -INLINE bool AUTOLOADP (Lisp_Object x) { return CONSP (x) && EQ (Qautoload, XCAR (x)); } -INLINE bool -BUFFER_OBJFWDP (union Lisp_Fwd *a) -{ - return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj; -} - -INLINE bool -PSEUDOVECTOR_TYPEP (struct vectorlike_header *a, int code) -{ - return ((a->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) - == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); -} - -/* True if A is a pseudovector whose code is CODE. */ -INLINE bool -PSEUDOVECTORP (Lisp_Object a, int code) -{ - if (! VECTORLIKEP (a)) - return false; - else - { - /* Converting to struct vectorlike_header * avoids aliasing issues. */ - struct vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike); - return PSEUDOVECTOR_TYPEP (h, code); - } -} - /* Test for specific pseudovector types. */ @@ -2692,60 +2719,12 @@ WINDOW_CONFIGURATIONP (Lisp_Object a) } INLINE bool -PROCESSP (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_PROCESS); -} - -INLINE bool -WINDOWP (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_WINDOW); -} - -INLINE bool -TERMINALP (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_TERMINAL); -} - -INLINE bool -SUBRP (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_SUBR); -} - -INLINE bool COMPILEDP (Lisp_Object a) { return PSEUDOVECTORP (a, PVEC_COMPILED); } INLINE bool -BUFFERP (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_BUFFER); -} - -INLINE bool -CHAR_TABLE_P (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_CHAR_TABLE); -} - -INLINE bool -SUB_CHAR_TABLE_P (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_SUB_CHAR_TABLE); -} - -INLINE bool -BOOL_VECTOR_P (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_BOOL_VECTOR); -} - -INLINE bool FRAMEP (Lisp_Object a) { return PSEUDOVECTORP (a, PVEC_FRAME); @@ -2778,42 +2757,16 @@ INLINE void } INLINE void -(CHECK_SYMBOL) (Lisp_Object x) -{ - lisp_h_CHECK_SYMBOL (x); -} - -INLINE void (CHECK_NUMBER) (Lisp_Object x) { lisp_h_CHECK_NUMBER (x); } INLINE void -CHECK_STRING (Lisp_Object x) -{ - CHECK_TYPE (STRINGP (x), Qstringp, x); -} -INLINE void CHECK_STRING_CAR (Lisp_Object x) { CHECK_TYPE (STRINGP (XCAR (x)), Qstringp, XCAR (x)); } -INLINE void -CHECK_CONS (Lisp_Object x) -{ - CHECK_TYPE (CONSP (x), Qconsp, x); -} -INLINE void -CHECK_VECTOR (Lisp_Object x) -{ - CHECK_TYPE (VECTORP (x), Qvectorp, x); -} -INLINE void -CHECK_BOOL_VECTOR (Lisp_Object x) -{ - CHECK_TYPE (BOOL_VECTOR_P (x), Qbool_vector_p, x); -} /* This is a bit special because we always need size afterwards. */ INLINE ptrdiff_t CHECK_VECTOR_OR_STRING (Lisp_Object x) @@ -2830,23 +2783,6 @@ CHECK_ARRAY (Lisp_Object x, Lisp_Object predicate) CHECK_TYPE (ARRAYP (x), predicate, x); } INLINE void -CHECK_BUFFER (Lisp_Object x) -{ - CHECK_TYPE (BUFFERP (x), Qbufferp, x); -} -INLINE void -CHECK_WINDOW (Lisp_Object x) -{ - CHECK_TYPE (WINDOWP (x), Qwindowp, x); -} -#ifdef subprocesses -INLINE void -CHECK_PROCESS (Lisp_Object x) -{ - CHECK_TYPE (PROCESSP (x), Qprocessp, x); -} -#endif -INLINE void CHECK_NATNUM (Lisp_Object x) { CHECK_TYPE (NATNUMP (x), Qwholenump, x); @@ -2962,13 +2898,6 @@ CHECK_NUMBER_CDR (Lisp_Object x) Lisp_Object fnname #endif -/* True if OBJ is a Lisp function. */ -INLINE bool -FUNCTIONP (Lisp_Object obj) -{ - return functionp (obj); -} - /* defsubr (Sname); is how we define the symbol for function `name' at start-up time. */ extern void defsubr (struct Lisp_Subr *); @@ -3032,12 +2961,6 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int); defvar_int (&i_fwd, lname, &globals.f_ ## vname); \ } while (false) -#define DEFVAR_BUFFER_DEFAULTS(lname, vname, doc) \ - do { \ - static struct Lisp_Objfwd o_fwd; \ - defvar_lisp_nopro (&o_fwd, lname, &BVAR (&buffer_defaults, vname)); \ - } while (false) - #define DEFVAR_KBOARD(lname, vname, doc) \ do { \ static struct Lisp_Kboard_Objfwd ko_fwd; \ @@ -3123,6 +3046,9 @@ union specbinding ENUM_BF (specbind_tag) kind : CHAR_BIT; /* `where' is not used in the case of SPECPDL_LET. */ Lisp_Object symbol, old_value, where; + /* Normally this is unused; but it is set to the symbol's + current value when a thread is swapped out. */ + Lisp_Object saved_value; } let; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; @@ -3133,9 +3059,10 @@ union specbinding } bt; }; -extern union specbinding *specpdl; -extern union specbinding *specpdl_ptr; -extern ptrdiff_t specpdl_size; +/* These 3 are defined as macros in thread.h. */ +/* extern union specbinding *specpdl; */ +/* extern union specbinding *specpdl_ptr; */ +/* extern ptrdiff_t specpdl_size; */ INLINE ptrdiff_t SPECPDL_INDEX (void) @@ -3186,19 +3113,14 @@ struct handler /* Most global vars are reset to their value via the specpdl mechanism, but a few others are handled by storing their value here. */ sys_jmp_buf jmp; - EMACS_INT lisp_eval_depth; + EMACS_INT f_lisp_eval_depth; ptrdiff_t pdlcount; int poll_suppress_count; int interrupt_input_blocked; - struct byte_stack *byte_stack; }; extern Lisp_Object memory_signal_data; -/* An address near the bottom of the stack. - Tells GC how to save a copy of the stack. */ -extern char *stack_bottom; - /* Check quit-flag and quit if it is non-nil. Typing C-g does not directly cause a quit; it only sets Vquit_flag. So the program needs to do QUIT at times when it is safe to quit. @@ -3287,7 +3209,13 @@ set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next) XSYMBOL (sym)->next = next; } -/* Buffer-local (also frame-local) variable access functions. */ +INLINE void +make_symbol_constant (Lisp_Object sym) +{ + XSYMBOL (sym)->trapped_write = SYMBOL_NOWRITE; +} + +/* Buffer-local variable access functions. */ INLINE int blv_found (struct Lisp_Buffer_Local_Value *blv) @@ -3357,6 +3285,9 @@ set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) } /* Defined in data.c. */ +extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object); +extern void notify_variable_watchers (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); extern Lisp_Object indirect_function (Lisp_Object); extern Lisp_Object find_symbol_value (Lisp_Object); enum Arith_Comparison { @@ -3395,7 +3326,17 @@ extern _Noreturn void args_out_of_range (Lisp_Object, Lisp_Object); extern _Noreturn void args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *); -extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, bool); +enum Set_Internal_Bind { + SET_INTERNAL_SET, + SET_INTERNAL_BIND, + SET_INTERNAL_UNBIND, + SET_INTERNAL_THREAD_SWITCH +}; +extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, + enum Set_Internal_Bind); +extern void set_default_internal (Lisp_Object, Lisp_Object, + enum Set_Internal_Bind bindflag); + extern void syms_of_data (void); extern void swap_in_global_binding (struct Lisp_Symbol *); @@ -3439,7 +3380,7 @@ ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *); ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, EMACS_UINT); void hash_remove_from_table (struct Lisp_Hash_Table *, Lisp_Object); -extern struct hash_table_test hashtest_eq, hashtest_eql, hashtest_equal; +extern struct hash_table_test const hashtest_eq, hashtest_eql, hashtest_equal; extern void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, ptrdiff_t *, ptrdiff_t *); extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t, @@ -3503,7 +3444,7 @@ extern void insert_from_string_before_markers (Lisp_Object, ptrdiff_t, ptrdiff_t, bool); extern void del_range (ptrdiff_t, ptrdiff_t); extern Lisp_Object del_range_1 (ptrdiff_t, ptrdiff_t, bool, bool); -extern void del_range_byte (ptrdiff_t, ptrdiff_t, bool); +extern void del_range_byte (ptrdiff_t, ptrdiff_t); extern void del_range_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool); extern Lisp_Object del_range_2 (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool); @@ -3516,6 +3457,8 @@ extern void adjust_after_insert (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t); extern void adjust_markers_for_delete (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t); +extern void adjust_markers_bytepos (ptrdiff_t, ptrdiff_t, + ptrdiff_t, ptrdiff_t, int); extern void replace_range (ptrdiff_t, ptrdiff_t, Lisp_Object, bool, bool, bool, bool); extern void replace_range_2 (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, const char *, ptrdiff_t, ptrdiff_t, bool); @@ -3584,16 +3527,12 @@ extern void mark_object (Lisp_Object); #if defined REL_ALLOC && !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC extern void refill_memory_reserve (void); #endif -#ifdef DOUG_LEA_MALLOC extern void alloc_unexec_pre (void); extern void alloc_unexec_post (void); -#else -INLINE void alloc_unexec_pre (void) {} -INLINE void alloc_unexec_post (void) {} -#endif +extern void mark_stack (char *, char *); +extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; -extern Lisp_Object *stack_base; extern EMACS_INT consing_since_gc; extern EMACS_INT gc_relative_threshold; extern EMACS_INT memory_full_cons_threshold; @@ -3728,7 +3667,6 @@ extern struct Lisp_Vector *allocate_pseudovector (int, int, int, VECSIZE (type), tag)) extern bool gc_in_progress; -extern bool abort_on_gc; extern Lisp_Object make_float (double); extern void display_malloc_warning (void); extern ptrdiff_t inhibit_garbage_collection (void); @@ -3756,6 +3694,15 @@ extern void check_cons_list (void); INLINE void (check_cons_list) (void) { lisp_h_check_cons_list (); } #endif +/* Defined in gmalloc.c. */ +#if !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC && !defined SYSTEM_MALLOC +extern size_t __malloc_extra_blocks; +#endif +#if !HAVE_DECL_ALIGNED_ALLOC +extern void *aligned_alloc (size_t, size_t) ATTRIBUTE_MALLOC_SIZE ((2)); +#endif +extern void malloc_enable_thread (void); + #ifdef REL_ALLOC /* Defined in ralloc.c. */ extern void *r_alloc (void **, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); @@ -3847,7 +3794,6 @@ extern Lisp_Object Vautoload_queue; extern Lisp_Object Vrun_hooks; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; -extern struct handler *handlerlist; /* To run a normal hook, use the appropriate function from the list below. The calling convention: @@ -3861,13 +3807,20 @@ extern void run_hook_with_args_2 (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args, Lisp_Object (*funcall) (ptrdiff_t nargs, Lisp_Object *args)); -extern _Noreturn void xsignal (Lisp_Object, Lisp_Object); +extern Lisp_Object quit (void); +INLINE _Noreturn void +xsignal (Lisp_Object error_symbol, Lisp_Object data) +{ + Fsignal (error_symbol, data); +} extern _Noreturn void xsignal0 (Lisp_Object); extern _Noreturn void xsignal1 (Lisp_Object, Lisp_Object); extern _Noreturn void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object); extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern _Noreturn void signal_error (const char *, Lisp_Object); +extern bool FUNCTIONP (Lisp_Object); +extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector); extern Lisp_Object eval_sub (Lisp_Object form); extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); extern Lisp_Object call0 (Lisp_Object); @@ -3898,9 +3851,13 @@ extern void clear_unwind_protect (ptrdiff_t); extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *); extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); +extern void rebind_for_thread_switch (void); +extern void unbind_for_thread_switch (struct thread_state *); extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); extern _Noreturn void verror (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); +extern Lisp_Object vformat_string (const char *, va_list) + ATTRIBUTE_FORMAT_PRINTF (1, 0); extern void un_autoload (Lisp_Object); extern Lisp_Object call_debugger (Lisp_Object arg); extern void *near_C_stack_top (void); @@ -3910,9 +3867,9 @@ extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object); extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object); extern void init_eval (void); extern void syms_of_eval (void); -extern void unwind_body (Lisp_Object); +extern void prog_ignore (Lisp_Object); extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); -extern void mark_specpdl (void); +extern void mark_specpdl (union specbinding *first, union specbinding *ptr); extern void get_backtrace (Lisp_Object array); Lisp_Object backtrace_top_function (void); extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol); @@ -3923,10 +3880,12 @@ extern bool let_shadows_global_binding_p (Lisp_Object symbol); extern Lisp_Object make_user_ptr (void (*finalizer) (void *), void *p); /* Defined in emacs-module.c. */ -extern void module_init (void); extern void syms_of_module (void); #endif +/* Defined in thread.c. */ +extern void mark_threads (void); + /* Defined in editfns.c. */ extern void insert1 (Lisp_Object); extern Lisp_Object save_excursion_save (void); @@ -4119,6 +4078,7 @@ INLINE void fixup_locale (void) {} INLINE void synchronize_system_messages_locale (void) {} INLINE void synchronize_system_time_locale (void) {} #endif +extern char *emacs_strerror (int); extern void shut_down_emacs (int, Lisp_Object); /* True means don't do interactive redisplay and don't change tty modes. */ @@ -4127,12 +4087,14 @@ extern bool noninteractive; /* True means remove site-lisp directories from load-path. */ extern bool no_site_lisp; -/* Pipe used to send exit notification to the daemon parent at - startup. On Windows, we use a kernel event instead. */ +/* True means put details like time stamps into builds. */ +extern bool build_details; + #ifndef WINDOWSNT -extern int daemon_pipe[2]; -#define IS_DAEMON (daemon_pipe[1] != 0) -#define DAEMON_RUNNING (daemon_pipe[1] >= 0) +/* 0 not a daemon, 1 new-style (foreground), 2 old-style (background). */ +extern int daemon_type; +#define IS_DAEMON (daemon_type != 0) +#define DAEMON_RUNNING (daemon_type >= 0) #else /* WINDOWSNT */ extern void *w32_daemon_event; #define IS_DAEMON (w32_daemon_event != NULL) @@ -4148,12 +4110,13 @@ extern bool inhibit_window_system; extern bool running_asynch_code; /* Defined in process.c. */ +struct Lisp_Process; extern void kill_buffer_processes (Lisp_Object); extern int wait_reading_process_output (intmax_t, int, int, bool, Lisp_Object, struct Lisp_Process *, int); /* Max value for the first argument of wait_reading_process_output. */ -#if __GNUC__ == 3 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 5) -/* Work around a bug in GCC 3.4.2, known to be fixed in GCC 4.6.3. +#if GNUC_PREREQ (3, 0, 0) && ! GNUC_PREREQ (4, 6, 0) +/* Work around a bug in GCC 3.4.2, known to be fixed in GCC 4.6.0. The bug merely causes a bogus warning, but the warning is annoying. */ # define WAIT_READING_MAX min (TYPE_MAXIMUM (time_t), INTMAX_MAX) #else @@ -4168,15 +4131,17 @@ extern void delete_keyboard_wait_descriptor (int); extern void add_gpm_wait_descriptor (int); extern void delete_gpm_wait_descriptor (int); #endif -extern void init_process_emacs (void); +extern void init_process_emacs (int); extern void syms_of_process (void); extern void setup_process_coding_systems (Lisp_Object); /* Defined in callproc.c. */ #ifndef DOS_NT - _Noreturn +# define CHILD_SETUP_TYPE _Noreturn void +#else +# define CHILD_SETUP_TYPE int #endif -extern int child_setup (int, int, int, char **, bool, Lisp_Object); +extern CHILD_SETUP_TYPE child_setup (int, int, int, char **, bool, Lisp_Object); extern void init_callproc_1 (void); extern void init_callproc (void); extern void set_initial_environment (void); @@ -4202,10 +4167,9 @@ extern int read_bytecode_char (bool); /* Defined in bytecode.c. */ extern void syms_of_bytecode (void); -extern struct byte_stack *byte_stack_list; -extern void relocate_byte_stack (void); extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, Lisp_Object *); +extern Lisp_Object get_byte_code_arity (Lisp_Object); /* Defined in macros.c. */ extern void init_macros (void); @@ -4234,13 +4198,15 @@ extern void syms_of_xmenu (void); /* Defined in termchar.h. */ struct tty_display_info; -/* Defined in termhooks.h. */ -struct terminal; - /* Defined in sysdep.c. */ -#ifndef HAVE_GET_CURRENT_DIR_NAME -extern char *get_current_dir_name (void); +#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE +extern bool disable_address_randomization (void); +#else +INLINE bool disable_address_randomization (void) { return false; } #endif +extern int emacs_exec_file (char const *, char *const *, char *const *); +extern void init_standard_fds (void); +extern char *emacs_get_current_dir_name (void); extern void stuff_char (char c); extern void init_foreground_group (void); extern void sys_subshell (void); @@ -4495,12 +4461,14 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); } \ } while (false) -/* SAFE_ALLOCA_LISP allocates an array of Lisp_Objects. */ +/* Set BUF to point to an allocated array of NELT Lisp_Objects, + immediately followed by EXTRA spare bytes. */ -#define SAFE_ALLOCA_LISP(buf, nelt) \ +#define SAFE_ALLOCA_LISP_EXTRA(buf, nelt, extra) \ do { \ ptrdiff_t alloca_nbytes; \ if (INT_MULTIPLY_WRAPV (nelt, word_size, &alloca_nbytes) \ + || INT_ADD_WRAPV (alloca_nbytes, extra, &alloca_nbytes) \ || SIZE_MAX < alloca_nbytes) \ memory_full (SIZE_MAX); \ else if (alloca_nbytes <= sa_avail) \ @@ -4515,6 +4483,10 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); } \ } while (false) +/* Set BUF to point to an allocated array of NELT Lisp_Objects. */ + +#define SAFE_ALLOCA_LISP(buf, nelt) SAFE_ALLOCA_LISP_EXTRA (buf, nelt, 0) + /* If USE_STACK_LISP_OBJECTS, define macros that and functions that allocate block-scoped conses and strings. These objects are not @@ -4526,8 +4498,7 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); Build with CPPFLAGS='-DUSE_STACK_LISP_OBJECTS=0' to disable it. */ #if (!defined USE_STACK_LISP_OBJECTS \ - && defined __GNUC__ && !defined __clang__ \ - && !(4 < __GNUC__ + (3 < __GNUC_MINOR__ + (2 <= __GNUC_PATCHLEVEL__)))) + && defined __GNUC__ && !defined __clang__ && ! GNUC_PREREQ (4, 3, 2)) /* Work around GCC bugs 36584 and 35271, which were fixed in GCC 4.3.2. */ # define USE_STACK_LISP_OBJECTS false #endif @@ -4600,27 +4571,29 @@ enum STACK_CONS (d, Qnil)))) \ : list4 (a, b, c, d)) -/* Check whether stack-allocated strings are ASCII-only. */ +/* Declare NAME as an auto Lisp string if possible, a GC-based one if not. + Take its unibyte value from the null-terminated string STR, + an expression that should not have side effects. + STR's value is not necessarily copied. The resulting Lisp string + should not be modified or made visible to user code. */ -#if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS -extern const char *verify_ascii (const char *); -#else -# define verify_ascii(str) (str) -#endif +#define AUTO_STRING(name, str) \ + AUTO_STRING_WITH_LEN (name, str, strlen (str)) /* Declare NAME as an auto Lisp string if possible, a GC-based one if not. - Take its value from STR. STR is not necessarily copied and should - contain only ASCII characters. The resulting Lisp string should - not be modified or made visible to user code. */ + Take its unibyte value from the null-terminated string STR with length LEN. + STR may have side effects and may contain null bytes. + STR's value is not necessarily copied. The resulting Lisp string + should not be modified or made visible to user code. */ -#define AUTO_STRING(name, str) \ +#define AUTO_STRING_WITH_LEN(name, str, len) \ Lisp_Object name = \ (USE_STACK_STRING \ ? (make_lisp_ptr \ ((&(union Aligned_String) \ - {{strlen (str), -1, 0, (unsigned char *) verify_ascii (str)}}.s), \ - Lisp_String)) \ - : build_string (verify_ascii (str))) + {{len, -1, 0, (unsigned char *) (str)}}.s), \ + Lisp_String)) \ + : make_unibyte_string (str, len)) /* Loop over all tails of a list, checking for cycles. FIXME: Make tortoise and n internal declarations. @@ -4656,38 +4629,6 @@ maybe_gc (void) Fgarbage_collect (); } -INLINE bool -functionp (Lisp_Object object) -{ - if (SYMBOLP (object) && !NILP (Ffboundp (object))) - { - object = Findirect_function (object, Qt); - - if (CONSP (object) && EQ (XCAR (object), Qautoload)) - { - /* Autoloaded symbols are functions, except if they load - macros or keymaps. */ - int i; - for (i = 0; i < 4 && CONSP (object); i++) - object = XCDR (object); - - return ! (CONSP (object) && !NILP (XCAR (object))); - } - } - - if (SUBRP (object)) - return XSUBR (object)->max_args != UNEVALLED; - else if (COMPILEDP (object)) - return true; - else if (CONSP (object)) - { - Lisp_Object car = XCAR (object); - return EQ (car, Qlambda) || EQ (car, Qclosure); - } - else - return false; -} - INLINE_HEADER_END #endif /* EMACS_LISP_H */ diff --git a/src/lread.c b/src/lread.c index b978e6ed09f..6005a7ce2d2 100644 --- a/src/lread.c +++ b/src/lread.c @@ -23,11 +23,11 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include "sysstdio.h" +#include <stdlib.h> #include <sys/types.h> #include <sys/stat.h> #include <sys/file.h> #include <errno.h> -#include <limits.h> /* For CHAR_BIT. */ #include <math.h> #include <stat-time.h> #include "lisp.h" @@ -36,13 +36,13 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "character.h" #include "buffer.h" #include "charset.h" -#include "coding.h" #include <epaths.h> #include "commands.h" #include "keyboard.h" #include "systime.h" #include "termhooks.h" #include "blockinput.h" +#include <c-ctype.h> #ifdef MSDOS #include "msdos.h" @@ -1039,7 +1039,7 @@ Return t if the file exists and loads successfully. */) { FILE *stream; int fd; - int fd_index; + int fd_index UNINIT; ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object found, efound, hist_file_name; /* True means we printed the ".el is newer" message. */ @@ -1155,12 +1155,7 @@ Return t if the file exists and loads successfully. */) #endif } - if (fd < 0) - { - /* Pacify older GCC with --enable-gcc-warnings. */ - IF_LINT (fd_index = 0); - } - else + if (0 <= fd) { fd_index = SPECPDL_INDEX (); record_unwind_protect_int (close_file_unwind, fd); @@ -1209,7 +1204,11 @@ Return t if the file exists and loads successfully. */) specbind (Qold_style_backquotes, Qnil); record_unwind_protect (load_warn_old_style_backquotes, file); - if (suffix_p (found, ".elc") || (fd >= 0 && (version = safe_to_load_version (fd)) > 0)) + int is_elc; + if ((is_elc = suffix_p (found, ".elc")) != 0 + /* version = 1 means the file is empty, in which case we can + treat it as not byte-compiled. */ + || (fd >= 0 && (version = safe_to_load_version (fd)) > 1)) /* Load .elc files directly, but not when they are remote and have no handler! */ { @@ -1236,7 +1235,7 @@ Return t if the file exists and loads successfully. */) /* openp already checked for newness, no point doing it again. FIXME would be nice to get a message when openp ignores suffix order due to load_prefer_newer. */ - if (!load_prefer_newer) + if (!load_prefer_newer && is_elc) { result = stat (SSDATA (efound), &s1); if (result == 0) @@ -1465,6 +1464,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, for (; CONSP (path); path = XCDR (path)) { + ptrdiff_t baselen, prefixlen; + filename = Fexpand_file_name (str, XCAR (path)); if (!complete_filename_p (filename)) /* If there are non-absolute elts in PATH (eg "."). */ @@ -1486,6 +1487,14 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, fn = SAFE_ALLOCA (fn_size); } + /* Copy FILENAME's data to FN but remove starting /: if any. */ + prefixlen = ((SCHARS (filename) > 2 + && SREF (filename, 0) == '/' + && SREF (filename, 1) == ':') + ? 2 : 0); + baselen = SBYTES (filename) - prefixlen; + memcpy (fn, SDATA (filename) + prefixlen, baselen); + /* Loop over suffixes. */ for (tail = NILP (suffixes) ? list1 (empty_unibyte_string) : suffixes; CONSP (tail); tail = XCDR (tail)) @@ -1494,16 +1503,10 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, ptrdiff_t fnlen, lsuffix = SBYTES (suffix); Lisp_Object handler; - /* Concatenate path element/specified name with the suffix. - If the directory starts with /:, remove that. */ - int prefixlen = ((SCHARS (filename) > 2 - && SREF (filename, 0) == '/' - && SREF (filename, 1) == ':') - ? 2 : 0); - fnlen = SBYTES (filename) - prefixlen; - memcpy (fn, SDATA (filename) + prefixlen, fnlen); - memcpy (fn + fnlen, SDATA (suffix), lsuffix + 1); - fnlen += lsuffix; + /* Make complete filename by appending SUFFIX. */ + memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); + fnlen = baselen + lsuffix; + /* Check that the file exists and is not a directory. */ /* We used to only check for handlers on non-absolute file names: if (absolute) @@ -1582,8 +1585,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { - int oflags = O_RDONLY + (NILP (predicate) ? 0 : O_BINARY); - fd = emacs_open (pfn, oflags, 0); + fd = emacs_open (pfn, O_RDONLY, 0); if (fd < 0) { if (errno != ENOENT) @@ -2142,18 +2144,57 @@ read0 (Lisp_Object readcharfun) Fmake_string (make_number (1), make_number (c))); } -static ptrdiff_t read_buffer_size; -static char *read_buffer; - -/* Grow the read buffer by at least MAX_MULTIBYTE_LENGTH bytes. */ +/* Grow a read buffer BUF that contains OFFSET useful bytes of data, + by at least MAX_MULTIBYTE_LENGTH bytes. Update *BUF_ADDR and + *BUF_SIZE accordingly; 0 <= OFFSET <= *BUF_SIZE. If *BUF_ADDR is + initially null, BUF is on the stack: copy its data to the new heap + buffer. Otherwise, BUF must equal *BUF_ADDR and can simply be + reallocated. Either way, remember the heap allocation (which is at + pdl slot COUNT) so that it can be freed when unwinding the stack.*/ + +static char * +grow_read_buffer (char *buf, ptrdiff_t offset, + char **buf_addr, ptrdiff_t *buf_size, ptrdiff_t count) +{ + char *p = xpalloc (*buf_addr, buf_size, MAX_MULTIBYTE_LENGTH, -1, 1); + if (!*buf_addr) + { + memcpy (p, buf, offset); + record_unwind_protect_ptr (xfree, p); + } + else + set_unwind_protect_ptr (count, xfree, p); + *buf_addr = p; + return p; +} -static void -grow_read_buffer (void) +/* Return the scalar value that has the Unicode character name NAME. + Raise 'invalid-read-syntax' if there is no such character. */ +static int +character_name_to_code (char const *name, ptrdiff_t name_len) { - read_buffer = xpalloc (read_buffer, &read_buffer_size, - MAX_MULTIBYTE_LENGTH, -1, 1); + /* For "U+XXXX", pass the leading '+' to string_to_number to reject + monstrosities like "U+-0000". */ + Lisp_Object code + = (name[0] == 'U' && name[1] == '+' + ? string_to_number (name + 1, 16, false) + : call2 (Qchar_from_name, make_unibyte_string (name, name_len), Qt)); + + if (! RANGED_INTEGERP (0, code, MAX_UNICODE_CHAR) + || char_surrogate_p (XINT (code))) + { + AUTO_STRING (format, "\\N{%s}"); + AUTO_STRING_WITH_LEN (namestr, name, name_len); + xsignal1 (Qinvalid_read_syntax, CALLN (Fformat, format, namestr)); + } + + return XINT (code); } +/* Bound on the length of a Unicode character name. As of + Unicode 9.0.0 the maximum is 83, so this should be safe. */ +enum { UNICODE_CHARACTER_NAME_LENGTH_BOUND = 200 }; + /* Read a \-escape sequence, assuming we already read the `\'. If the escape sequence forces unibyte, return eight-bit char. */ @@ -2361,6 +2402,54 @@ read_escape (Lisp_Object readcharfun, bool stringp) return i; } + case 'N': + /* Named character. */ + { + c = READCHAR; + if (c != '{') + invalid_syntax ("Expected opening brace after \\N"); + char name[UNICODE_CHARACTER_NAME_LENGTH_BOUND + 1]; + bool whitespace = false; + ptrdiff_t length = 0; + while (true) + { + c = READCHAR; + if (c < 0) + end_of_file_error (); + if (c == '}') + break; + if (! (0 < c && c < 0x80)) + { + AUTO_STRING (format, + "Invalid character U+%04X in character name"); + xsignal1 (Qinvalid_read_syntax, + CALLN (Fformat, format, make_natnum (c))); + } + /* Treat multiple adjacent whitespace characters as a + single space character. This makes it easier to use + character names in e.g. multi-line strings. */ + if (c_isspace (c)) + { + if (whitespace) + continue; + c = ' '; + whitespace = true; + } + else + whitespace = false; + name[length++] = c; + if (length >= sizeof name) + invalid_syntax ("Character name too long"); + } + if (length == 0) + invalid_syntax ("Empty character name"); + name[length] = '\0'; + + /* character_name_to_code can invoke read1, recursively. + This is why read1's buffer is not static. */ + return character_name_to_code (name, length); + } + default: return c; } @@ -2397,7 +2486,7 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) { /* Room for sign, leading 0, other digits, trailing null byte. Also, room for invalid syntax diagnostic. */ - char buf[max (1 + 1 + sizeof (uintmax_t) * CHAR_BIT + 1, + char buf[max (1 + 1 + UINTMAX_WIDTH + 1, sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT))]; int valid = -1; /* 1 if valid, 0 if not, -1 if incomplete. */ @@ -2447,7 +2536,7 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) *p = '\0'; } - if (! valid) + if (valid != 1) { sprintf (buf, "integer, radix %"pI"d", radix); invalid_syntax (buf); @@ -2467,8 +2556,9 @@ static Lisp_Object read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { int c; - bool uninterned_symbol = 0; + bool uninterned_symbol = false; bool multibyte; + char stackbuf[MAX_ALLOCA]; *pch = 0; @@ -2799,7 +2889,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* #:foo is the uninterned symbol named foo. */ if (c == ':') { - uninterned_symbol = 1; + uninterned_symbol = true; c = READCHAR; if (!(c > 040 && c != NO_BREAK_SPACE @@ -2821,19 +2911,17 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { EMACS_INT n = 0; Lisp_Object tem; + bool overflow = false; /* Read a non-negative integer. */ while (c >= '0' && c <= '9') { - if (MOST_POSITIVE_FIXNUM / 10 < n - || MOST_POSITIVE_FIXNUM < n * 10 + c - '0') - n = MOST_POSITIVE_FIXNUM + 1; - else - n = n * 10 + c - '0'; + overflow |= INT_MULTIPLY_WRAPV (n, 10, &n); + overflow |= INT_ADD_WRAPV (n, c - '0', &n); c = READCHAR; } - if (n <= MOST_POSITIVE_FIXNUM) + if (!overflow && n <= MOST_POSITIVE_FIXNUM) { if (c == 'r' || c == 'R') return read_integer (readcharfun, n); @@ -3012,16 +3100,20 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) case '"': { + ptrdiff_t count = SPECPDL_INDEX (); + char *read_buffer = stackbuf; + ptrdiff_t read_buffer_size = sizeof stackbuf; + char *heapbuf = NULL; char *p = read_buffer; char *end = read_buffer + read_buffer_size; int ch; /* True if we saw an escape sequence specifying a multibyte character. */ - bool force_multibyte = 0; + bool force_multibyte = false; /* True if we saw an escape sequence specifying a single-byte character. */ - bool force_singlebyte = 0; - bool cancel = 0; + bool force_singlebyte = false; + bool cancel = false; ptrdiff_t nchars = 0; while ((ch = READCHAR) >= 0 @@ -3030,7 +3122,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (end - p < MAX_MULTIBYTE_LENGTH) { ptrdiff_t offset = p - read_buffer; - grow_read_buffer (); + read_buffer = grow_read_buffer (read_buffer, offset, + &heapbuf, &read_buffer_size, + count); p = read_buffer + offset; end = read_buffer + read_buffer_size; } @@ -3045,7 +3139,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (ch == -1) { if (p == read_buffer) - cancel = 1; + cancel = true; continue; } @@ -3053,9 +3147,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) ch = ch & ~CHAR_MODIFIER_MASK; if (CHAR_BYTE8_P (ch)) - force_singlebyte = 1; + force_singlebyte = true; else if (! ASCII_CHAR_P (ch)) - force_multibyte = 1; + force_multibyte = true; else /* I.e. ASCII_CHAR_P (ch). */ { /* Allow `\C- ' and `\C-?'. */ @@ -3081,7 +3175,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) string. */ modifiers &= ~CHAR_META; ch = BYTE8_TO_CHAR (ch | 0x80); - force_singlebyte = 1; + force_singlebyte = true; } } @@ -3094,9 +3188,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { p += CHAR_STRING (ch, (unsigned char *) p); if (CHAR_BYTE8_P (ch)) - force_singlebyte = 1; + force_singlebyte = true; else if (! ASCII_CHAR_P (ch)) - force_multibyte = 1; + force_multibyte = true; } nchars++; } @@ -3108,7 +3202,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return zero instead. This is for doc strings that we are really going to find in etc/DOC.nn.nn. */ if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel) - return make_number (0); + return unbind_to (count, make_number (0)); if (! force_multibyte && force_singlebyte) { @@ -3119,9 +3213,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) p = read_buffer + nchars; } - return make_specified_string (read_buffer, nchars, p - read_buffer, - (force_multibyte - || (p - read_buffer != nchars))); + Lisp_Object result + = make_specified_string (read_buffer, nchars, p - read_buffer, + (force_multibyte + || (p - read_buffer != nchars))); + return unbind_to (count, result); } case '.': @@ -3149,81 +3245,74 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) read_symbol: { + ptrdiff_t count = SPECPDL_INDEX (); + char *read_buffer = stackbuf; + ptrdiff_t read_buffer_size = sizeof stackbuf; + char *heapbuf = NULL; char *p = read_buffer; - bool quoted = 0; + char *end = read_buffer + read_buffer_size; + bool quoted = false; EMACS_INT start_position = readchar_count - 1; - { - char *end = read_buffer + read_buffer_size; - - do - { - if (end - p < MAX_MULTIBYTE_LENGTH) - { - ptrdiff_t offset = p - read_buffer; - grow_read_buffer (); - p = read_buffer + offset; - end = read_buffer + read_buffer_size; - } + do + { + if (end - p < MAX_MULTIBYTE_LENGTH + 1) + { + ptrdiff_t offset = p - read_buffer; + read_buffer = grow_read_buffer (read_buffer, offset, + &heapbuf, &read_buffer_size, + count); + p = read_buffer + offset; + end = read_buffer + read_buffer_size; + } - if (c == '\\') - { - c = READCHAR; - if (c == -1) - end_of_file_error (); - quoted = 1; - } + if (c == '\\') + { + c = READCHAR; + if (c == -1) + end_of_file_error (); + quoted = true; + } - if (multibyte) - p += CHAR_STRING (c, (unsigned char *) p); - else - *p++ = c; - c = READCHAR; - } - while (c > 040 - && c != NO_BREAK_SPACE - && (c >= 0200 - || strchr ("\"';()[]#`,", c) == NULL)); + if (multibyte) + p += CHAR_STRING (c, (unsigned char *) p); + else + *p++ = c; + c = READCHAR; + } + while (c > 040 + && c != NO_BREAK_SPACE + && (c >= 0200 + || strchr ("\"';()[]#`,", c) == NULL)); - if (p == end) - { - ptrdiff_t offset = p - read_buffer; - grow_read_buffer (); - p = read_buffer + offset; - end = read_buffer + read_buffer_size; - } - *p = 0; - UNREAD (c); - } + *p = 0; + UNREAD (c); if (!quoted && !uninterned_symbol) { Lisp_Object result = string_to_number (read_buffer, 10, 0); if (! NILP (result)) - return result; + return unbind_to (count, result); } - { - Lisp_Object name, result; - ptrdiff_t nbytes = p - read_buffer; - ptrdiff_t nchars - = (multibyte - ? multibyte_chars_in_text ((unsigned char *) read_buffer, - nbytes) - : nbytes); - - name = ((uninterned_symbol && ! NILP (Vpurify_flag) - ? make_pure_string : make_specified_string) - (read_buffer, nchars, nbytes, multibyte)); - result = (uninterned_symbol ? Fmake_symbol (name) - : Fintern (name, Qnil)); - - if (EQ (Vread_with_symbol_positions, Qt) - || EQ (Vread_with_symbol_positions, readcharfun)) - Vread_symbol_positions_list - = Fcons (Fcons (result, make_number (start_position)), - Vread_symbol_positions_list); - return result; - } + + ptrdiff_t nbytes = p - read_buffer; + ptrdiff_t nchars + = (multibyte + ? multibyte_chars_in_text ((unsigned char *) read_buffer, + nbytes) + : nbytes); + Lisp_Object name = ((uninterned_symbol && ! NILP (Vpurify_flag) + ? make_pure_string : make_specified_string) + (read_buffer, nchars, nbytes, multibyte)); + Lisp_Object result = (uninterned_symbol ? Fmake_symbol (name) + : Fintern (name, Qnil)); + + if (EQ (Vread_with_symbol_positions, Qt) + || EQ (Vread_with_symbol_positions, readcharfun)) + Vread_symbol_positions_list + = Fcons (Fcons (result, make_number (start_position)), + Vread_symbol_positions_list); + return unbind_to (count, result); } } } @@ -3761,7 +3850,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray)) { - XSYMBOL (sym)->constant = 1; + make_symbol_constant (sym); XSYMBOL (sym)->redirect = SYMBOL_PLAINVAL; SET_SYMBOL_VAL (XSYMBOL (sym), sym); } @@ -4027,17 +4116,12 @@ OBARRAY defaults to the value of `obarray'. */) return Qnil; } -#define OBARRAY_SIZE 1511 +#define OBARRAY_SIZE 15121 void init_obarray (void) { - Lisp_Object oblength; - ptrdiff_t size = 100 + MAX_MULTIBYTE_LENGTH; - - XSETFASTINT (oblength, OBARRAY_SIZE); - - Vobarray = Fmake_vector (oblength, make_number (0)); + Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0)); initial_obarray = Vobarray; staticpro (&initial_obarray); @@ -4048,21 +4132,18 @@ init_obarray (void) DEFSYM (Qnil, "nil"); SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil); - XSYMBOL (Qnil)->constant = 1; + make_symbol_constant (Qnil); XSYMBOL (Qnil)->declared_special = true; DEFSYM (Qt, "t"); SET_SYMBOL_VAL (XSYMBOL (Qt), Qt); - XSYMBOL (Qt)->constant = 1; + make_symbol_constant (Qt); XSYMBOL (Qt)->declared_special = true; /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */ Vpurify_flag = Qt; DEFSYM (Qvariable_documentation, "variable-documentation"); - - read_buffer = xmalloc (size); - read_buffer_size = size; } void @@ -4190,7 +4271,9 @@ load_path_check (Lisp_Object lpath) are running uninstalled. Uses the following logic: - If CANNOT_DUMP: Use PATH_LOADSEARCH. + If CANNOT_DUMP: + If Vinstallation_directory is not nil (ie, running uninstalled), + use PATH_DUMPLOADSEARCH (ie, build path). Else use PATH_LOADSEARCH. The remainder is what happens when dumping works: If purify-flag (ie dumping) just use PATH_DUMPLOADSEARCH. Otherwise use PATH_LOADSEARCH. @@ -4224,6 +4307,8 @@ load_path_default (void) #endif normal = PATH_LOADSEARCH; + if (!NILP (Vinstallation_directory)) normal = PATH_DUMPLOADSEARCH; + #ifdef HAVE_NS lpath = decode_env_path (0, loadpath ? loadpath : normal, 0); #else @@ -4428,18 +4513,24 @@ void dir_warning (char const *use, Lisp_Object dirname) { static char const format[] = "Warning: %s '%s': %s\n"; - int access_errno = errno; - fprintf (stderr, format, use, SSDATA (ENCODE_SYSTEM (dirname)), - strerror (access_errno)); + char *diagnostic = emacs_strerror (errno); + fprintf (stderr, format, use, SSDATA (ENCODE_SYSTEM (dirname)), diagnostic); /* Don't log the warning before we've initialized!! */ if (initialized) { - char const *diagnostic = emacs_strerror (access_errno); + ptrdiff_t diaglen = strlen (diagnostic); + AUTO_STRING_WITH_LEN (diag, diagnostic, diaglen); + if (! NILP (Vlocale_coding_system)) + { + Lisp_Object s + = code_convert_string_norecord (diag, Vlocale_coding_system, false); + diagnostic = SSDATA (s); + diaglen = SBYTES (s); + } USE_SAFE_ALLOCA; char *buffer = SAFE_ALLOCA (sizeof format - 3 * (sizeof "%s" - 1) - + strlen (use) + SBYTES (dirname) - + strlen (diagnostic)); + + strlen (use) + SBYTES (dirname) + diaglen); ptrdiff_t message_len = esprintf (buffer, format, use, SSDATA (dirname), diagnostic); message_dolog (buffer, message_len, 0, STRING_MULTIBYTE (dirname)); @@ -4761,4 +4852,6 @@ that are loaded before your customizations are read! */); DEFSYM (Qweakness, "weakness"); DEFSYM (Qrehash_size, "rehash-size"); DEFSYM (Qrehash_threshold, "rehash-threshold"); + + DEFSYM (Qchar_from_name, "char-from-name"); } diff --git a/src/macfont.m b/src/macfont.m index ed7c1e3bd7a..855b3fe7f7a 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -38,8 +38,6 @@ Original author: YAMAMOTO Mitsuharu #include <libkern/OSByteOrder.h> -static struct font_driver macfont_driver; - static double mac_font_get_advance_width_for_glyph (CTFontRef, CGGlyph); static CGRect mac_font_get_bounding_rect_for_glyph (CTFontRef, CGGlyph); static CFArrayRef mac_font_create_available_families (void); @@ -893,7 +891,7 @@ macfont_descriptor_entity (CTFontDescriptorRef desc, Lisp_Object extra, entity = font_make_entity (); - ASET (entity, FONT_TYPE_INDEX, macfont_driver.type); + ASET (entity, FONT_TYPE_INDEX, Qmac_ct); ASET (entity, FONT_REGISTRY_INDEX, Qiso10646_1); macfont_store_descriptor_attributes (desc, entity); @@ -1663,34 +1661,23 @@ static int macfont_variation_glyphs (struct font *, int c, unsigned variations[256]); static void macfont_filter_properties (Lisp_Object, Lisp_Object); -static struct font_driver macfont_driver = +static struct font_driver const macfont_driver = { - LISP_INITIALLY_ZERO, /* Qmac_ct */ - 0, /* case insensitive */ - macfont_get_cache, - macfont_list, - macfont_match, - macfont_list_family, - macfont_free_entity, - macfont_open, - macfont_close, - NULL, /* prepare_face */ - NULL, /* done_face */ - macfont_has_char, - macfont_encode_char, - macfont_text_extents, - macfont_draw, - NULL, /* get_bitmap */ - NULL, /* free_bitmap */ - NULL, /* anchor_point */ - NULL, /* otf_capability */ - NULL, /* otf_drive */ - NULL, /* start_for_frame */ - NULL, /* end_for_frame */ - macfont_shape, - NULL, /* check */ - macfont_variation_glyphs, - macfont_filter_properties, + .type = LISPSYM_INITIALLY (Qmac_ct), + .get_cache = macfont_get_cache, + .list = macfont_list, + .match = macfont_match, + .list_family = macfont_list_family, + .free_entity = macfont_free_entity, + .open = macfont_open, + .close = macfont_close, + .has_char = macfont_has_char, + .encode_char = macfont_encode_char, + .text_extents = macfont_text_extents, + .draw = macfont_draw, + .shape = macfont_shape, + .get_variation_glyphs = macfont_variation_glyphs, + .filter_properties = macfont_filter_properties, }; static Lisp_Object @@ -2856,7 +2843,8 @@ macfont_draw (struct glyph_string *s, int from, int to, int x, int y, { if (s->hl == DRAW_MOUSE_FACE) { - face = FACE_FROM_ID (s->f, MOUSE_HL_INFO (s->f)->mouse_face_face_id); + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); if (!face) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); } @@ -2877,7 +2865,19 @@ macfont_draw (struct glyph_string *s, int from, int to, int x, int y, if (macfont_info->synthetic_bold_p && ! no_antialias_p) { CGContextSetTextDrawingMode (context, kCGTextFillStroke); + + /* Stroke line width for text drawing is not correctly + scaled on Retina display/HiDPI mode when drawn to screen + (whereas it is correctly scaled when drawn to bitmaps), + and synthetic bold looks thinner on such environments. + Apple says there are no plans to address this issue + (rdar://11644870) currently. So we add a workaround. */ +#if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_7 + CGContextSetLineWidth (context, synthetic_bold_factor * font_size + * [[FRAME_NS_VIEW(f) window] backingScaleFactor]); +#else CGContextSetLineWidth (context, synthetic_bold_factor * font_size); +#endif CG_SET_STROKE_COLOR_WITH_FACE_FOREGROUND (context, face, f); } if (no_antialias_p) @@ -3766,6 +3766,7 @@ mac_font_shape (CTFontRef font, CFStringRef string, { struct mac_glyph_layout *gl; CGPoint position; + CGFloat max_x; if (!RIGHT_TO_LEFT_P) gl = glbuf + range.location; @@ -3787,12 +3788,13 @@ mac_font_shape (CTFontRef font, CFStringRef string, CTRunGetGlyphs (ctrun, range, &gl->glyph_id); CTRunGetPositions (ctrun, range, &position); + max_x = position.x + CTRunGetTypographicBounds (ctrun, range, + NULL, NULL, NULL); + max_x = max (max_x, total_advance); gl->advance_delta = position.x - total_advance; gl->baseline_delta = position.y; - gl->advance = (gl->advance_delta - + CTRunGetTypographicBounds (ctrun, range, - NULL, NULL, NULL)); - total_advance += gl->advance; + gl->advance = max_x - total_advance; + total_advance = max_x; } if (RIGHT_TO_LEFT_P) @@ -4044,7 +4046,6 @@ syms_of_macfont (void) { /* Core Text, for macOS. */ DEFSYM (Qmac_ct, "mac-ct"); - macfont_driver.type = Qmac_ct; register_font_driver (&macfont_driver, NULL); /* The font property key specifying the font design destination. The diff --git a/src/marker.c b/src/marker.c index febdb17689a..05e5bb87474 100644 --- a/src/marker.c +++ b/src/marker.c @@ -507,7 +507,11 @@ set_marker_internal (Lisp_Object marker, Lisp_Object position, charpos = clip_to_bounds (restricted ? BUF_BEGV (b) : BUF_BEG (b), charpos, restricted ? BUF_ZV (b) : BUF_Z (b)); - if (bytepos == -1) + /* Don't believe BYTEPOS if it comes from a different buffer, + since that buffer might have a very different correspondence + between character and byte positions. */ + if (bytepos == -1 + || !(MARKERP (position) && XMARKER (position)->buffer == b)) bytepos = buf_charpos_to_bytepos (b, charpos); else bytepos = clip_to_bounds diff --git a/src/menu.c b/src/menu.c index 9504cee5923..80709679513 100644 --- a/src/menu.c +++ b/src/menu.c @@ -42,12 +42,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #endif /* HAVE_WINDOW_SYSTEM */ #ifdef HAVE_NTGUI -# ifdef NTGUI_UNICODE -# define unicode_append_menu AppendMenuW -# else /* !NTGUI_UNICODE */ extern AppendMenuW_Proc unicode_append_menu; -# endif /* NTGUI_UNICODE */ -extern HMENU current_popup_menu; #endif /* HAVE_NTGUI */ #include "menu.h" @@ -408,7 +403,7 @@ single_menu_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy, void *sk if (prefix) { - AUTO_STRING (prefix_obj, prefix); + AUTO_STRING_WITH_LEN (prefix_obj, prefix, 4); item_string = concat2 (prefix_obj, item_string); } } @@ -1050,7 +1045,7 @@ menu_item_width (const unsigned char *str) int ch_len; int ch = STRING_CHAR_AND_LENGTH (p, ch_len); - len += CHAR_WIDTH (ch); + len += CHARACTER_WIDTH (ch); p += ch_len; } return len; @@ -1545,7 +1540,7 @@ for instance using the window manager, then this produces a quit and /* Note that xw_popup_dialog can call menu code, so Vmenu_updating_frame should be set (Bug#17891). */ - eassert (f && FRAME_LIVE_P (f)); + eassume (f && FRAME_LIVE_P (f)); XSETFRAME (Vmenu_updating_frame, f); /* Force a redisplay before showing the dialog. If a frame is created diff --git a/src/minibuf.c b/src/minibuf.c index 3d34635c6c0..7c5af34102b 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -194,7 +194,7 @@ read_minibuf_noninteractive (Lisp_Object map, Lisp_Object initial, int c; unsigned char hide_char = 0; struct emacs_tty etty; - bool etty_valid; + bool etty_valid UNINIT; /* Check, whether we need to suppress echoing. */ if (CHARACTERP (Vread_hide_char)) @@ -203,10 +203,10 @@ read_minibuf_noninteractive (Lisp_Object map, Lisp_Object initial, /* Manipulate tty. */ if (hide_char) { - etty_valid = emacs_get_tty (fileno (stdin), &etty) == 0; + etty_valid = emacs_get_tty (STDIN_FILENO, &etty) == 0; if (etty_valid) - set_binary_mode (fileno (stdin), O_BINARY); - suppress_echo_on_tty (fileno (stdin)); + set_binary_mode (STDIN_FILENO, O_BINARY); + suppress_echo_on_tty (STDIN_FILENO); } fwrite (SDATA (prompt), 1, SBYTES (prompt), stdout); @@ -240,8 +240,8 @@ read_minibuf_noninteractive (Lisp_Object map, Lisp_Object initial, fprintf (stdout, "\n"); if (etty_valid) { - emacs_set_tty (fileno (stdin), &etty, 0); - set_binary_mode (fileno (stdin), O_TEXT); + emacs_set_tty (STDIN_FILENO, &etty, 0); + set_binary_mode (STDIN_FILENO, O_TEXT); } } @@ -630,8 +630,31 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, Qrear_nonsticky, Qt, Qnil); Fput_text_property (make_number (BEG), make_number (PT), Qfield, Qt, Qnil); - Fadd_text_properties (make_number (BEG), make_number (PT), - Vminibuffer_prompt_properties, Qnil); + if (CONSP (Vminibuffer_prompt_properties)) + { + /* We want to apply all properties from + `minibuffer-prompt-properties' to the region normally, + but if the `face' property is present, add that + property to the end of the face properties to avoid + overwriting faces. */ + Lisp_Object list = Vminibuffer_prompt_properties; + while (CONSP (list)) + { + Lisp_Object key = XCAR (list); + list = XCDR (list); + if (CONSP (list)) + { + Lisp_Object val = XCAR (list); + list = XCDR (list); + if (EQ (key, Qface)) + Fadd_face_text_property (make_number (BEG), + make_number (PT), val, Qt, Qnil); + else + Fput_text_property (make_number (BEG), make_number (PT), + key, val, Qnil); + } + } + } } unbind_to (count1, Qnil); } @@ -742,27 +765,25 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, } /* Return a buffer to be used as the minibuffer at depth `depth'. - depth = 0 is the lowest allowed argument, and that is the value - used for nonrecursive minibuffer invocations. */ + depth = 0 is the lowest allowed argument, and that is the value + used for nonrecursive minibuffer invocations. */ Lisp_Object get_minibuffer (EMACS_INT depth) { - Lisp_Object tail, num, buf; - char name[sizeof " *Minibuf-*" + INT_STRLEN_BOUND (EMACS_INT)]; - - XSETFASTINT (num, depth); - tail = Fnthcdr (num, Vminibuffer_list); + Lisp_Object tail = Fnthcdr (make_number (depth), Vminibuffer_list); if (NILP (tail)) { tail = list1 (Qnil); Vminibuffer_list = nconc2 (Vminibuffer_list, tail); } - buf = Fcar (tail); + Lisp_Object buf = Fcar (tail); if (NILP (buf) || !BUFFER_LIVE_P (XBUFFER (buf))) { - buf = Fget_buffer_create - (make_formatted_string (name, " *Minibuf-%"pI"d*", depth)); + static char const name_fmt[] = " *Minibuf-%"pI"d*"; + char name[sizeof name_fmt + INT_STRLEN_BOUND (EMACS_INT)]; + AUTO_STRING_WITH_LEN (lname, name, sprintf (name, name_fmt, depth)); + buf = Fget_buffer_create (lname); /* Although the buffer's name starts with a space, undo should be enabled in it. */ @@ -1715,26 +1736,27 @@ the values STRING, PREDICATE and `lambda'. */) else if (HASH_TABLE_P (collection)) { struct Lisp_Hash_Table *h = XHASH_TABLE (collection); - Lisp_Object key = Qnil; i = hash_lookup (h, string, NULL); if (i >= 0) - tem = HASH_KEY (h, i); + { + tem = HASH_KEY (h, i); + goto found_matching_key; + } else for (i = 0; i < HASH_TABLE_SIZE (h); ++i) - if (!NILP (HASH_HASH (h, i)) - && (key = HASH_KEY (h, i), - SYMBOLP (key) ? key = Fsymbol_name (key) : key, - STRINGP (key)) - && EQ (Fcompare_strings (string, make_number (0), Qnil, - key, make_number (0) , Qnil, - completion_ignore_case ? Qt : Qnil), - Qt)) - { - tem = key; - break; - } - if (!STRINGP (tem)) - return Qnil; + { + if (NILP (HASH_HASH (h, i))) continue; + tem = HASH_KEY (h, i); + Lisp_Object strkey = (SYMBOLP (tem) ? Fsymbol_name (tem) : tem); + if (!STRINGP (strkey)) continue; + if (EQ (Fcompare_strings (string, Qnil, Qnil, + strkey, Qnil, Qnil, + completion_ignore_case ? Qt : Qnil), + Qt)) + goto found_matching_key; + } + return Qnil; + found_matching_key: ; } else return call3 (collection, string, predicate, Qlambda); @@ -1747,9 +1769,9 @@ the values STRING, PREDICATE and `lambda'. */) for (regexps = Vcompletion_regexp_list; CONSP (regexps); regexps = XCDR (regexps)) { - if (NILP (Fstring_match (XCAR (regexps), - SYMBOLP (tem) ? string : tem, - Qnil))) + /* We can test against STRING, because if we got here, then + the element is equivalent to it. */ + if (NILP (Fstring_match (XCAR (regexps), string, Qnil))) return unbind_to (count, Qnil); } unbind_to (count, Qnil); diff --git a/src/msdos.c b/src/msdos.c index 62411ea2f6d..74109ae1bbd 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -795,8 +795,8 @@ static void IT_set_face (int face) { struct frame *sf = SELECTED_FRAME (); - struct face *fp = FACE_FROM_ID (sf, face); - struct face *dfp = FACE_FROM_ID (sf, DEFAULT_FACE_ID); + struct face *fp = FACE_FROM_ID_OR_NULL (sf, face); + struct face *dfp = FACE_FROM_ID_OR_NULL (sf, DEFAULT_FACE_ID); unsigned long fg, bg, dflt_fg, dflt_bg; struct tty_display_info *tty = FRAME_TTY (sf); @@ -1076,7 +1076,7 @@ IT_clear_screen (struct frame *f) any valid faces and will abort. Instead, use the initial screen colors; that should mimic what a Unix tty does, which simply clears the screen with whatever default colors are in use. */ - if (FACE_FROM_ID (SELECTED_FRAME (), DEFAULT_FACE_ID) == NULL) + if (FACE_FROM_ID_OR_NULL (SELECTED_FRAME (), DEFAULT_FACE_ID) == NULL) ScreenAttrib = (initial_screen_colors[0] << 4) | initial_screen_colors[1]; else IT_set_face (0); @@ -1791,7 +1791,7 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_number (25); /* RE Emacs version */ + Vwindow_system_version = make_number (26); /* RE Emacs version */ tty->terminal->type = output_msdos_raw; /* If Emacs was dumped on DOS/V machine, forget the stale VRAM diff --git a/src/nsfns.m b/src/nsfns.m index 82bb84a147a..cfaaf53cbc6 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -52,12 +52,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #ifdef HAVE_NS -extern NSArray *ns_send_types, *ns_return_types, *ns_drag_types; - -EmacsTooltip *ns_tooltip = nil; - -/* Need forward declaration here to preserve organizational integrity of file */ -Lisp_Object Fx_open_connection (Lisp_Object, Lisp_Object, Lisp_Object); +static EmacsTooltip *ns_tooltip = nil; /* Static variables to handle applescript execution. */ static Lisp_Object as_script, *as_result; @@ -65,6 +60,8 @@ static int as_status; static ptrdiff_t image_cache_refcount; +static struct ns_display_info *ns_display_info_for_name (Lisp_Object); +static void ns_set_name_as_filename (struct frame *); /* ========================================================================== @@ -132,7 +129,7 @@ ns_get_window (Lisp_Object maybeFrame) /* Return the X display structure for the display named NAME. Open a new connection if necessary. */ -struct ns_display_info * +static struct ns_display_info * ns_display_info_for_name (Lisp_Object name) { struct ns_display_info *dpyinfo; @@ -523,7 +520,7 @@ x_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name) } -void +static void ns_set_name_as_filename (struct frame *f) { NSView *view; @@ -622,7 +619,7 @@ ns_set_doc_edited (void) } -void +static void x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) { int nlines; @@ -652,7 +649,7 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) /* toolbar support */ -void +static void x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) { /* Currently, when the tool bar change state, the frame is resized. @@ -720,15 +717,15 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) } -void +static void x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old_width = FRAME_INTERNAL_BORDER_WIDTH (f); CHECK_TYPE_RANGED_INTEGER (int, arg); - FRAME_INTERNAL_BORDER_WIDTH (f) = XINT (arg); + f->internal_border_width = XINT (arg); if (FRAME_INTERNAL_BORDER_WIDTH (f) < 0) - FRAME_INTERNAL_BORDER_WIDTH (f) = 0; + f->internal_border_width = 0; if (FRAME_INTERNAL_BORDER_WIDTH (f) == old_width) return; @@ -850,40 +847,6 @@ x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) [view setMiniwindowImage: setMini]; } - -/* TODO: move to nsterm? */ -int -ns_lisp_to_cursor_type (Lisp_Object arg) -{ - char *str; - if (XTYPE (arg) == Lisp_String) - str = SSDATA (arg); - else if (XTYPE (arg) == Lisp_Symbol) - str = SSDATA (SYMBOL_NAME (arg)); - else return -1; - if (!strcmp (str, "box")) return FILLED_BOX_CURSOR; - if (!strcmp (str, "hollow")) return HOLLOW_BOX_CURSOR; - if (!strcmp (str, "hbar")) return HBAR_CURSOR; - if (!strcmp (str, "bar")) return BAR_CURSOR; - if (!strcmp (str, "no")) return NO_CURSOR; - return -1; -} - - -Lisp_Object -ns_cursor_type_to_lisp (int arg) -{ - switch (arg) - { - case FILLED_BOX_CURSOR: return Qbox; - case HOLLOW_BOX_CURSOR: return Qhollow; - case HBAR_CURSOR: return Qhbar; - case BAR_CURSOR: return Qbar; - case NO_CURSOR: - default: return intern ("no"); - } -} - /* This is the same as the xfns.c definition. */ static void x_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) @@ -983,8 +946,8 @@ frame_parm_handler ns_frame_parm_handlers[] = x_set_icon_name, x_set_icon_type, x_set_internal_border_width, /* generic OK */ - 0, /* x_set_right_divider_width */ - 0, /* x_set_bottom_divider_width */ + x_set_right_divider_width, + x_set_bottom_divider_width, x_set_menu_bar_lines, x_set_mouse_color, x_explicitly_set_name, @@ -1008,6 +971,7 @@ frame_parm_handler ns_frame_parm_handlers[] = x_set_alpha, 0, /* x_set_sticky */ 0, /* x_set_tool_bar_position */ + 0, /* x_set_inhibit_double_buffering */ }; @@ -1582,7 +1546,7 @@ Optional arg DIR_ONLY_P, if non-nil, means choose only directories. */) The file dialog may pop up a confirm dialog after Ok has been pressed, so we can not simply pop down on the Ok/Cancel press. */ - nxev = [NSEvent otherEventWithType: NSApplicationDefined + nxev = [NSEvent otherEventWithType: NSEventTypeApplicationDefined location: NSMakePoint (0, 0) modifierFlags: 0 timestamp: 0 @@ -2193,7 +2157,7 @@ In case the execution fails, an error is signaled. */) errors aren't returned and executeAndReturnError hangs forever. Post an event that runs applescript and then start the event loop. The event loop is exited when the script is done. */ - nxev = [NSEvent otherEventWithType: NSApplicationDefined + nxev = [NSEvent otherEventWithType: NSEventTypeApplicationDefined location: NSMakePoint (0, 0) modifierFlags: 0 timestamp: 0 @@ -2273,9 +2237,10 @@ x_get_string_resource (XrmDatabase rdb, const char *name, const char *class) return NULL; res = ns_get_defaults_value (toCheck); - return (!res ? NULL : - (!c_strncasecmp (res, "YES", 3) ? "true" : - (!c_strncasecmp (res, "NO", 2) ? "false" : (char *) res))); + return (char *) (!res ? NULL + : !c_strncasecmp (res, "YES", 3) ? "true" + : !c_strncasecmp (res, "NO", 2) ? "false" + : res); } @@ -2987,7 +2952,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) int i; BOOL ret = NO; - if ([theEvent type] != NSKeyDown) return NO; + if ([theEvent type] != NSEventTypeKeyDown) return NO; s = [theEvent characters]; for (i = 0; i < [s length]; ++i) @@ -3006,7 +2971,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) /* Don't send command modified keys, as those are handled in the performKeyEquivalent method of the super class. */ - if (! ([theEvent modifierFlags] & NSCommandKeyMask)) + if (! ([theEvent modifierFlags] & NSEventModifierFlagCommand)) { [panel sendEvent: theEvent]; ret = YES; @@ -3023,7 +2988,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) case 'c': // Copy case 'v': // Paste case 'a': // Select all - if ([theEvent modifierFlags] & NSCommandKeyMask) + if ([theEvent modifierFlags] & NSEventModifierFlagCommand) { [NSApp sendAction: (ch == 'x' @@ -3039,7 +3004,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) default: // Send all control keys, as the text field supports C-a, C-f, C-e // C-b and more. - if ([theEvent modifierFlags] & NSControlKeyMask) + if ([theEvent modifierFlags] & NSEventModifierFlagControl) { [panel sendEvent: theEvent]; ret = YES; diff --git a/src/nsfont.m b/src/nsfont.m index 4f95ee3a1a8..757b217597a 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -45,9 +45,6 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu) #define NSFONT_TRACE 0 #define LCD_SMOOTHING_MARGIN 2 -extern float ns_antialias_threshold; - - /* font glyph and metrics caching functions, implemented at end */ static void ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block); @@ -613,43 +610,6 @@ ns_findfonts (Lisp_Object font_spec, BOOL isMatch) ========================================================================== */ -static Lisp_Object nsfont_get_cache (struct frame *frame); -static Lisp_Object nsfont_list (struct frame *, Lisp_Object); -static Lisp_Object nsfont_match (struct frame *, Lisp_Object); -static Lisp_Object nsfont_list_family (struct frame *); -static Lisp_Object nsfont_open (struct frame *f, Lisp_Object font_entity, - int pixel_size); -static void nsfont_close (struct font *font); -static int nsfont_has_char (Lisp_Object entity, int c); -static unsigned int nsfont_encode_char (struct font *font, int c); -static void nsfont_text_extents (struct font *font, unsigned int *code, - int nglyphs, struct font_metrics *metrics); -static int nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, - bool with_background); - -struct font_driver nsfont_driver = - { - 0, /* Qns */ - 1, /* case sensitive */ - nsfont_get_cache, - nsfont_list, - nsfont_match, - nsfont_list_family, - NULL, /*free_entity */ - nsfont_open, - nsfont_close, - NULL, /* prepare_face */ - NULL, /* done_face */ - nsfont_has_char, - nsfont_encode_char, - nsfont_text_extents, - nsfont_draw, - /* excluded: get_bitmap, free_bitmap, - anchor_point, otf_capability, otf_driver, - start_for_frame, end_for_frame, shape */ - }; - - /* Return a cache of font-entities on FRAME. The cache must be a cons whose cdr part is the actual cache area. */ static Lisp_Object @@ -791,7 +751,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) font_object = font_make_object (VECSIZE (struct nsfont_info), font_entity, pixel_size); - ASET (font_object, FONT_TYPE_INDEX, nsfont_driver.type); + ASET (font_object, FONT_TYPE_INDEX, Qns); font_info = (struct nsfont_info *) XFONT_OBJECT (font_object); font = (struct font *) font_info; if (!font) @@ -1071,7 +1031,8 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, face = s->face; break; case NS_DUMPGLYPH_MOUSEFACE: - face = FACE_FROM_ID (s->f, MOUSE_HL_INFO (s->f)->mouse_face_face_id); + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); if (!face) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); break; @@ -1515,15 +1476,32 @@ ns_dump_glyphstring (struct glyph_string *s) s->nchars, s->x, s->y, s->left_overhang, s->right_overhang, s->row->overlapping_p, s->background_filled_p); for (i =0; i<s->nchars; i++) - fprintf (stderr, "%c", s->first_glyph[i].u.ch); + { + int c = s->first_glyph[i].u.ch; + fprintf (stderr, "%c", c); + } fprintf (stderr, "\n"); } +struct font_driver const nsfont_driver = + { + .type = LISPSYM_INITIALLY (Qns), + .case_sensitive = true, + .get_cache = nsfont_get_cache, + .list = nsfont_list, + .match = nsfont_match, + .list_family = nsfont_list_family, + .open = nsfont_open, + .close = nsfont_close, + .has_char = nsfont_has_char, + .encode_char = nsfont_encode_char, + .text_extents = nsfont_text_extents, + .draw = nsfont_draw, + }; void syms_of_nsfont (void) { - nsfont_driver.type = Qns; register_font_driver (&nsfont_driver, NULL); DEFSYM (Qcondensed, "condensed"); DEFSYM (Qexpanded, "expanded"); diff --git a/src/nsimage.m b/src/nsimage.m index 66aecd4289d..32bcea76ccd 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -46,11 +46,11 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) ========================================================================== */ void * -ns_image_from_XBM (unsigned char *bits, int width, int height, +ns_image_from_XBM (char *bits, int width, int height, unsigned long fg, unsigned long bg) { NSTRACE ("ns_image_from_XBM"); - return [[EmacsImage alloc] initFromXBM: bits + return [[EmacsImage alloc] initFromXBM: (unsigned char *) bits width: width height: height fg: fg bg: bg]; } diff --git a/src/nsmenu.m b/src/nsmenu.m index f73c184dce7..3e9887acf5d 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -53,8 +53,7 @@ Carbon version by Yamamoto Mitsuharu. */ #endif extern long context_menu_value; -EmacsMenu *mainMenu, *svcsMenu, *dockMenu; - +EmacsMenu *svcsMenu; /* Nonzero means a menu is currently active. */ static int popup_activated_flag; @@ -136,12 +135,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) menu = [[EmacsMenu alloc] initWithTitle: ns_app_name]; needsSet = YES; } - else - { /* close up anything on there */ - id attMenu = [menu attachedMenu]; - if (attMenu != nil) - [attMenu close]; - } #if NSMENUPROFILE ftime (&tb); @@ -610,7 +603,7 @@ x_activate_menubar (struct frame *f) -(NSString *)parseKeyEquiv: (const char *)key { const char *tpos = key; - keyEquivModMask = NSCommandKeyMask; + keyEquivModMask = NSEventModifierFlagCommand; if (!key || !strlen (key)) return @""; @@ -698,7 +691,6 @@ x_activate_menubar (struct frame *f) widget_value *wv = (widget_value *)wvptr; /* clear existing contents */ - [self setMenuChangedMessagesEnabled: NO]; [self clear]; /* add new contents */ @@ -722,7 +714,6 @@ x_activate_menubar (struct frame *f) } } - [self setMenuChangedMessagesEnabled: YES]; #ifdef NS_IMPL_GNUSTEP if ([[self window] isVisible]) [self sizeToFit]; @@ -754,7 +745,7 @@ x_activate_menubar (struct frame *f) /* p = [view convertPoint:p fromView: nil]; */ p.y = NSHeight ([view frame]) - p.y; e = [[view window] currentEvent]; - event = [NSEvent mouseEventWithType: NSRightMouseDown + event = [NSEvent mouseEventWithType: NSEventTypeRightMouseDown location: p modifierFlags: 0 timestamp: [e timestamp] @@ -1426,29 +1417,19 @@ update_frame_tool_bar (struct frame *f) ========================================================================== */ -struct Popdown_data -{ - NSAutoreleasePool *pool; - EmacsDialogPanel *dialog; -}; - static void pop_down_menu (void *arg) { - struct Popdown_data *unwind_data = arg; + EmacsDialogPanel *panel = arg; - block_input (); if (popup_activated_flag) { - EmacsDialogPanel *panel = unwind_data->dialog; + block_input (); popup_activated_flag = 0; [panel close]; - [unwind_data->pool release]; [[FRAME_NS_VIEW (SELECTED_FRAME ()) window] makeKeyWindow]; + unblock_input (); } - - xfree (unwind_data); - unblock_input (); } @@ -1459,7 +1440,6 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) Lisp_Object tem, title; NSPoint p; BOOL isQ; - NSAutoreleasePool *pool; NSTRACE ("ns_popup_dialog"); @@ -1479,18 +1459,13 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) contents = list2 (title, Fcons (build_string ("Ok"), Qt)); block_input (); - pool = [[NSAutoreleasePool alloc] init]; dialog = [[EmacsDialogPanel alloc] initFromContents: contents isQuestion: isQ]; { ptrdiff_t specpdl_count = SPECPDL_INDEX (); - struct Popdown_data *unwind_data = xmalloc (sizeof (*unwind_data)); - - unwind_data->pool = pool; - unwind_data->dialog = dialog; - record_unwind_protect_ptr (pop_down_menu, unwind_data); + record_unwind_protect_ptr (pop_down_menu, dialog); popup_activated_flag = 1; tem = [dialog runDialogAt: p]; unbind_to (specpdl_count, Qnil); /* calls pop_down_menu */ @@ -1556,7 +1531,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) [img autorelease]; [imgView autorelease]; - aStyle = NSTitledWindowMask|NSClosableWindowMask|NSUtilityWindowMask; + aStyle = NSWindowStyleMaskTitled|NSWindowStyleMaskClosable|NSUtilityWindowMask; flag = YES; rows = 0; cols = 1; @@ -1814,7 +1789,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) - (void)timeout_handler: (NSTimer *)timedEntry { - NSEvent *nxev = [NSEvent otherEventWithType: NSApplicationDefined + NSEvent *nxev = [NSEvent otherEventWithType: NSEventTypeApplicationDefined location: NSMakePoint (0, 0) modifierFlags: 0 timestamp: 0 @@ -1865,7 +1840,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) if (EQ (ret, Qundefined) && window_closed) /* Make close button pressed equivalent to C-g. */ - Fsignal (Qquit, Qnil); + quit (); return ret; } diff --git a/src/nsterm.h b/src/nsterm.h index 4b246bd3d0f..dc222a75e74 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -39,6 +39,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #ifndef MAC_OS_X_VERSION_10_9 #define MAC_OS_X_VERSION_10_9 1090 #endif +#ifndef MAC_OS_X_VERSION_10_12 +#define MAC_OS_X_VERSION_10_12 101200 +#endif #if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_7 #define HAVE_NATIVE_FS @@ -389,7 +392,6 @@ char const * nstrace_fullscreen_type_name (int); - (void)sendEvent: (NSEvent *)theEvent; - (void)showPreferencesWindow: (id)sender; - (BOOL) openFile: (NSString *)fileName; -- (void)fd_handler: (id)unused; - (void)timeout_handler: (NSTimer *)timedEntry; - (BOOL)fulfillService: (NSString *)name withArg: (NSString *)arg; #ifdef NS_IMPL_GNUSTEP @@ -676,11 +678,13 @@ char const * nstrace_fullscreen_type_name (int); /* offset to the bottom of knob of last mouse down */ CGFloat last_mouse_offset; float min_portion; - int pixel_height; + int pixel_length; enum scroll_bar_part last_hit_part; BOOL condemned; + BOOL horizontal; + /* optimize against excessive positioning calls generated by emacs */ int em_position; int em_portion; @@ -726,7 +730,7 @@ char const * nstrace_fullscreen_type_name (int); extern NSArray *ns_send_types, *ns_return_types; extern NSString *ns_app_name; -extern EmacsMenu *mainMenu, *svcsMenu, *dockMenu; +extern EmacsMenu *svcsMenu; /* Apple removed the declaration, but kept the implementation */ #if defined (NS_IMPL_COCOA) @@ -919,8 +923,6 @@ struct ns_display_info /* This is a chain of structures for all the NS displays currently in use. */ extern struct ns_display_info *x_display_list; -extern struct ns_display_info *ns_display_info_for_name (Lisp_Object name); - struct ns_output { #ifdef __OBJC__ @@ -1012,7 +1014,7 @@ struct x_output #define FRAME_NS_TITLEBAR_HEIGHT(f) ((f)->output_data.ns->titlebar_height) #define FRAME_TOOLBAR_HEIGHT(f) ((f)->output_data.ns->toolbar_height) -#define FRAME_DEFAULT_FACE(f) FACE_FROM_ID (f, DEFAULT_FACE_ID) +#define FRAME_DEFAULT_FACE(f) FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID) #define FRAME_NS_VIEW(f) ((f)->output_data.ns->view) #define FRAME_CURSOR_COLOR(f) ((f)->output_data.ns->cursor_color) @@ -1094,7 +1096,7 @@ extern void nsfont_make_fontset_for_font (Lisp_Object name, /* In nsfont, for debugging */ struct glyph_string; -void ns_dump_glyphstring (struct glyph_string *s); +void ns_dump_glyphstring (struct glyph_string *s) EXTERNALLY_VISIBLE; /* Implemented in nsterm, published in or needed from nsfns. */ extern Lisp_Object ns_list_fonts (struct frame *f, Lisp_Object pattern, @@ -1111,9 +1113,6 @@ extern void ns_string_to_pasteboard (id pb, Lisp_Object str); extern Lisp_Object ns_get_local_selection (Lisp_Object selection_name, Lisp_Object target_type); extern void nxatoms_of_nsselect (void); -extern int ns_lisp_to_cursor_type (Lisp_Object arg); -extern Lisp_Object ns_cursor_type_to_lisp (int arg); -extern void ns_set_name_as_filename (struct frame *f); extern void ns_set_doc_edited (void); extern bool @@ -1125,11 +1124,9 @@ extern void ns_query_color (void *col, XColor *color_def, int setPixel); #ifdef __OBJC__ -extern Lisp_Object ns_color_to_lisp (NSColor *col); extern int ns_lisp_to_color (Lisp_Object color, NSColor **col); extern NSColor *ns_lookup_indexed_color (unsigned long idx, struct frame *f); extern unsigned long ns_index_color (NSColor *color, struct frame *f); -extern void ns_free_indexed_color (unsigned long idx, struct frame *f); extern const char *ns_get_pending_menu_title (void); extern void ns_check_menu_open (NSMenu *menu); extern void ns_check_pending_open_menu (void); @@ -1147,8 +1144,6 @@ extern void ns_init_locale (void); /* in nsmenu */ extern void update_frame_tool_bar (struct frame *f); extern void free_frame_tool_bar (struct frame *f); -extern void find_and_call_menu_selection (struct frame *f, - int menu_bar_items_used, Lisp_Object vector, void *client_data); extern Lisp_Object find_and_return_menu_selection (struct frame *f, bool keymaps, void *client_data); @@ -1171,7 +1166,7 @@ extern void syms_of_nsselect (void); /* From nsimage.m, needed in image.c */ struct image; -extern void *ns_image_from_XBM (unsigned char *bits, int width, int height, +extern void *ns_image_from_XBM (char *bits, int width, int height, unsigned long fg, unsigned long bg); extern void *ns_image_for_XPM (int width, int height, int depth); extern void *ns_image_from_file (Lisp_Object file); @@ -1187,6 +1182,7 @@ extern int x_display_pixel_height (struct ns_display_info *); extern int x_display_pixel_width (struct ns_display_info *); /* This in nsterm.m */ +extern float ns_antialias_threshold; extern void x_destroy_window (struct frame *f); extern int ns_select (int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struct timespec const *timeout, @@ -1194,14 +1190,11 @@ extern int ns_select (int nfds, fd_set *readfds, fd_set *writefds, extern unsigned long ns_get_rgb_color (struct frame *f, float r, float g, float b, float a); -extern void ns_init_events (); -extern void ns_finish_events (); +struct input_event; +extern void ns_init_events (struct input_event *); +extern void ns_finish_events (void); #ifdef __OBJC__ -/* From nsterm.m, needed in nsfont.m. */ -extern void -ns_draw_text_decoration (struct glyph_string *s, struct face *face, - NSColor *defaultCol, CGFloat width, CGFloat x); /* Needed in nsfns.m. */ extern void ns_set_represented_filename (NSString* fstr, struct frame *f); @@ -1231,4 +1224,42 @@ extern char gnustep_base_version[]; /* version tracking */ ? (min) : (((x)>(max)) ? (max) : (x))) #define SCREENMAXBOUND(x) (IN_BOUND (-SCREENMAX, x, SCREENMAX)) +/* macOS 10.12 deprecates a bunch of constants. */ +#if !defined (NS_IMPL_COCOA) || \ + MAC_OS_X_VERSION_MAX_ALLOWED < MAC_OS_X_VERSION_10_12 +#define NSEventModifierFlagCommand NSCommandKeyMask +#define NSEventModifierFlagControl NSControlKeyMask +#define NSEventModifierFlagHelp NSHelpKeyMask +#define NSEventModifierFlagNumericPad NSNumericPadKeyMask +#define NSEventModifierFlagOption NSAlternateKeyMask +#define NSEventModifierFlagShift NSShiftKeyMask +#define NSCompositingOperationSourceOver NSCompositeSourceOver +#define NSEventMaskApplicationDefined NSApplicationDefinedMask +#define NSEventTypeApplicationDefined NSApplicationDefined +#define NSEventTypeCursorUpdate NSCursorUpdate +#define NSEventTypeMouseMoved NSMouseMoved +#define NSEventTypeLeftMouseDown NSLeftMouseDown +#define NSEventTypeRightMouseDown NSRightMouseDown +#define NSEventTypeOtherMouseDown NSOtherMouseDown +#define NSEventTypeLeftMouseUp NSLeftMouseUp +#define NSEventTypeRightMouseUp NSRightMouseUp +#define NSEventTypeOtherMouseUp NSOtherMouseUp +#define NSEventTypeLeftMouseDragged NSLeftMouseDragged +#define NSEventTypeRightMouseDragged NSRightMouseDragged +#define NSEventTypeOtherMouseDragged NSOtherMouseDragged +#define NSEventTypeScrollWheel NSScrollWheel +#define NSEventTypeKeyDown NSKeyDown +#define NSEventTypeKeyUp NSKeyUp +#define NSEventTypeFlagsChanged NSFlagsChanged +#define NSEventMaskAny NSAnyEventMask +#define NSWindowStyleMaskBorderless NSBorderlessWindowMask +#define NSWindowStyleMaskClosable NSClosableWindowMask +#define NSWindowStyleMaskFullScreen NSFullScreenWindowMask +#define NSWindowStyleMaskMiniaturizable NSMiniaturizableWindowMask +#define NSWindowStyleMaskResizable NSResizableWindowMask +#define NSWindowStyleMaskTitled NSTitledWindowMask +#define NSAlertStyleCritical NSCriticalAlertStyle +#define NSControlSizeRegular NSRegularControlSize +#endif + #endif /* HAVE_NS */ diff --git a/src/nsterm.m b/src/nsterm.m index 4f99a13c44e..98fd8ab8558 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -68,9 +68,10 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #include "macfont.h" #endif - -extern NSString *NSMenuDidBeginTrackingNotification; - +static EmacsMenu *dockMenu; +#ifdef NS_IMPL_COCOA +static EmacsMenu *mainMenu; +#endif /* ========================================================================== @@ -230,22 +231,22 @@ static unsigned convert_ns_to_X_keysym[] = NSNewlineCharacter, 0x0D, NSEnterCharacter, 0x8D, - 0x41|NSNumericPadKeyMask, 0xAE, /* KP_Decimal */ - 0x43|NSNumericPadKeyMask, 0xAA, /* KP_Multiply */ - 0x45|NSNumericPadKeyMask, 0xAB, /* KP_Add */ - 0x4B|NSNumericPadKeyMask, 0xAF, /* KP_Divide */ - 0x4E|NSNumericPadKeyMask, 0xAD, /* KP_Subtract */ - 0x51|NSNumericPadKeyMask, 0xBD, /* KP_Equal */ - 0x52|NSNumericPadKeyMask, 0xB0, /* KP_0 */ - 0x53|NSNumericPadKeyMask, 0xB1, /* KP_1 */ - 0x54|NSNumericPadKeyMask, 0xB2, /* KP_2 */ - 0x55|NSNumericPadKeyMask, 0xB3, /* KP_3 */ - 0x56|NSNumericPadKeyMask, 0xB4, /* KP_4 */ - 0x57|NSNumericPadKeyMask, 0xB5, /* KP_5 */ - 0x58|NSNumericPadKeyMask, 0xB6, /* KP_6 */ - 0x59|NSNumericPadKeyMask, 0xB7, /* KP_7 */ - 0x5B|NSNumericPadKeyMask, 0xB8, /* KP_8 */ - 0x5C|NSNumericPadKeyMask, 0xB9, /* KP_9 */ + 0x41|NSEventModifierFlagNumericPad, 0xAE, /* KP_Decimal */ + 0x43|NSEventModifierFlagNumericPad, 0xAA, /* KP_Multiply */ + 0x45|NSEventModifierFlagNumericPad, 0xAB, /* KP_Add */ + 0x4B|NSEventModifierFlagNumericPad, 0xAF, /* KP_Divide */ + 0x4E|NSEventModifierFlagNumericPad, 0xAD, /* KP_Subtract */ + 0x51|NSEventModifierFlagNumericPad, 0xBD, /* KP_Equal */ + 0x52|NSEventModifierFlagNumericPad, 0xB0, /* KP_0 */ + 0x53|NSEventModifierFlagNumericPad, 0xB1, /* KP_1 */ + 0x54|NSEventModifierFlagNumericPad, 0xB2, /* KP_2 */ + 0x55|NSEventModifierFlagNumericPad, 0xB3, /* KP_3 */ + 0x56|NSEventModifierFlagNumericPad, 0xB4, /* KP_4 */ + 0x57|NSEventModifierFlagNumericPad, 0xB5, /* KP_5 */ + 0x58|NSEventModifierFlagNumericPad, 0xB6, /* KP_6 */ + 0x59|NSEventModifierFlagNumericPad, 0xB7, /* KP_7 */ + 0x5B|NSEventModifierFlagNumericPad, 0xB8, /* KP_8 */ + 0x5C|NSEventModifierFlagNumericPad, 0xB9, /* KP_9 */ 0x1B, 0x1B /* escape */ }; @@ -255,7 +256,8 @@ static unsigned convert_ns_to_X_keysym[] = no way to control this behavior. */ float ns_antialias_threshold; -NSArray *ns_send_types =0, *ns_return_types =0, *ns_drag_types =0; +NSArray *ns_send_types = 0, *ns_return_types = 0; +static NSArray *ns_drag_types = 0; NSString *ns_app_name = @"Emacs"; /* default changed later */ /* Display variables */ @@ -277,18 +279,10 @@ static BOOL ns_menu_bar_is_hidden = NO; /*static int debug_lock = 0; */ /* event loop */ -static BOOL send_appdefined = YES; #define NO_APPDEFINED_DATA (-8) static int last_appdefined_event_data = NO_APPDEFINED_DATA; static NSTimer *timed_entry = 0; static NSTimer *scroll_repeat_entry = nil; -static fd_set select_readfds, select_writefds; -enum { SELECT_HAVE_READ = 1, SELECT_HAVE_WRITE = 2, SELECT_HAVE_TMO = 4 }; -static int select_nfds = 0, select_valid = 0; -static struct timespec select_timeout = { 0, 0 }; -static int selfds[2] = { -1, -1 }; -static pthread_mutex_t select_mutex; -static int apploopnr = 0; static NSAutoreleasePool *outerpool; static struct input_event *emacs_event = NULL; static struct input_event *q_event_ptr = NULL; @@ -333,28 +327,28 @@ static CGPoint menu_mouse_point; /* Convert modifiers in a NeXTstep event to emacs style modifiers. */ #define NS_FUNCTION_KEY_MASK 0x800000 -#define NSLeftControlKeyMask (0x000001 | NSControlKeyMask) -#define NSRightControlKeyMask (0x002000 | NSControlKeyMask) -#define NSLeftCommandKeyMask (0x000008 | NSCommandKeyMask) -#define NSRightCommandKeyMask (0x000010 | NSCommandKeyMask) -#define NSLeftAlternateKeyMask (0x000020 | NSAlternateKeyMask) -#define NSRightAlternateKeyMask (0x000040 | NSAlternateKeyMask) +#define NSLeftControlKeyMask (0x000001 | NSEventModifierFlagControl) +#define NSRightControlKeyMask (0x002000 | NSEventModifierFlagControl) +#define NSLeftCommandKeyMask (0x000008 | NSEventModifierFlagCommand) +#define NSRightCommandKeyMask (0x000010 | NSEventModifierFlagCommand) +#define NSLeftAlternateKeyMask (0x000020 | NSEventModifierFlagOption) +#define NSRightAlternateKeyMask (0x000040 | NSEventModifierFlagOption) #define EV_MODIFIERS2(flags) \ - (((flags & NSHelpKeyMask) ? \ + (((flags & NSEventModifierFlagHelp) ? \ hyper_modifier : 0) \ | (!EQ (ns_right_alternate_modifier, Qleft) && \ ((flags & NSRightAlternateKeyMask) \ == NSRightAlternateKeyMask) ? \ parse_solitary_modifier (ns_right_alternate_modifier) : 0) \ - | ((flags & NSAlternateKeyMask) ? \ + | ((flags & NSEventModifierFlagOption) ? \ parse_solitary_modifier (ns_alternate_modifier) : 0) \ - | ((flags & NSShiftKeyMask) ? \ + | ((flags & NSEventModifierFlagShift) ? \ shift_modifier : 0) \ | (!EQ (ns_right_control_modifier, Qleft) && \ ((flags & NSRightControlKeyMask) \ == NSRightControlKeyMask) ? \ parse_solitary_modifier (ns_right_control_modifier) : 0) \ - | ((flags & NSControlKeyMask) ? \ + | ((flags & NSEventModifierFlagControl) ? \ parse_solitary_modifier (ns_control_modifier) : 0) \ | ((flags & NS_FUNCTION_KEY_MASK) ? \ parse_solitary_modifier (ns_function_modifier) : 0) \ @@ -362,24 +356,24 @@ static CGPoint menu_mouse_point; ((flags & NSRightCommandKeyMask) \ == NSRightCommandKeyMask) ? \ parse_solitary_modifier (ns_right_command_modifier) : 0) \ - | ((flags & NSCommandKeyMask) ? \ + | ((flags & NSEventModifierFlagCommand) ? \ parse_solitary_modifier (ns_command_modifier):0)) #define EV_MODIFIERS(e) EV_MODIFIERS2 ([e modifierFlags]) #define EV_UDMODIFIERS(e) \ - ((([e type] == NSLeftMouseDown) ? down_modifier : 0) \ - | (([e type] == NSRightMouseDown) ? down_modifier : 0) \ - | (([e type] == NSOtherMouseDown) ? down_modifier : 0) \ - | (([e type] == NSLeftMouseDragged) ? down_modifier : 0) \ - | (([e type] == NSRightMouseDragged) ? down_modifier : 0) \ - | (([e type] == NSOtherMouseDragged) ? down_modifier : 0) \ - | (([e type] == NSLeftMouseUp) ? up_modifier : 0) \ - | (([e type] == NSRightMouseUp) ? up_modifier : 0) \ - | (([e type] == NSOtherMouseUp) ? up_modifier : 0)) + ((([e type] == NSEventTypeLeftMouseDown) ? down_modifier : 0) \ + | (([e type] == NSEventTypeRightMouseDown) ? down_modifier : 0) \ + | (([e type] == NSEventTypeOtherMouseDown) ? down_modifier : 0) \ + | (([e type] == NSEventTypeLeftMouseDragged) ? down_modifier : 0) \ + | (([e type] == NSEventTypeRightMouseDragged) ? down_modifier : 0) \ + | (([e type] == NSEventTypeOtherMouseDragged) ? down_modifier : 0) \ + | (([e type] == NSEventTypeLeftMouseUp) ? up_modifier : 0) \ + | (([e type] == NSEventTypeRightMouseUp) ? up_modifier : 0) \ + | (([e type] == NSEventTypeOtherMouseUp) ? up_modifier : 0)) #define EV_BUTTON(e) \ - ((([e type] == NSLeftMouseDown) || ([e type] == NSLeftMouseUp)) ? 0 : \ - (([e type] == NSRightMouseDown) || ([e type] == NSRightMouseUp)) ? 2 : \ + ((([e type] == NSEventTypeLeftMouseDown) || ([e type] == NSEventTypeLeftMouseUp)) ? 0 : \ + (([e type] == NSEventTypeRightMouseDown) || ([e type] == NSEventTypeRightMouseUp)) ? 2 : \ [e buttonNumber] - 1) /* Convert the time field to a timestamp in milliseconds. */ @@ -413,7 +407,6 @@ static CGPoint menu_mouse_point; /* TODO: get rid of need for these forward declarations */ static void ns_condemn_scroll_bars (struct frame *f); static void ns_judge_scroll_bars (struct frame *f); -void x_set_frame_alpha (struct frame *f); /* ========================================================================== @@ -437,7 +430,7 @@ ns_init_events (struct input_event* ev) } void -ns_finish_events () +ns_finish_events (void) { emacs_event = NULL; } @@ -456,7 +449,6 @@ hold_event (struct input_event *event) hold_event_q.q[hold_event_q.nr++] = *event; /* Make sure ns_read_socket is called, i.e. we have input. */ raise (SIGIO); - send_appdefined = YES; } static Lisp_Object @@ -1423,7 +1415,8 @@ ns_ring_bell (struct frame *f) } -static void hide_bell () +static void +hide_bell (void) /* -------------------------------------------------------------------------- Ensure the bell is hidden. -------------------------------------------------------------------------- */ @@ -1806,23 +1799,6 @@ x_set_window_size (struct frame *f, [window setFrame: wr display: YES]; - /* This is a trick to compensate for Emacs' managing the scrollbar area - as a fixed number of standard character columns. Instead of leaving - blank space for the extra, we chopped it off above. Now for - left-hand scrollbars, we shift all rendering to the left by the - difference between the real width and Emacs' imagined one. For - right-hand bars, don't worry about it since the extra is never used. - (Obviously doesn't work for vertically split windows tho..) */ - { - NSPoint origin = FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f) - ? NSMakePoint (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f) - - NS_SCROLL_BAR_WIDTH (f), 0) - : NSMakePoint (0, 0); - - [view setFrame: NSMakeRect (0, 0, pixelwidth, pixelheight)]; - [view setBoundsOrigin: origin]; - } - [view updateFrameSize: NO]; unblock_input (); } @@ -1914,37 +1890,6 @@ ns_index_color (NSColor *color, struct frame *f) } -void -ns_free_indexed_color (unsigned long idx, struct frame *f) -{ - struct ns_color_table *color_table; - NSColor *color; - NSNumber *index; - - if (!f) - return; - - color_table = FRAME_DISPLAY_INFO (f)->color_table; - - if (idx <= 0 || idx >= color_table->size) { - message1 ("ns_free_indexed_color: Color index out of range.\n"); - return; - } - - index = [NSNumber numberWithUnsignedInt: idx]; - if ([color_table->empty_indices containsObject: index]) { - message1 ("ns_free_indexed_color: attempt to free already freed color.\n"); - return; - } - - color = color_table->colors[idx]; - [color release]; - color_table->colors[idx] = nil; - [color_table->empty_indices addObject: index]; -/*fprintf(stderr, "color_table: FREED %d\n",idx);*/ -} - - static int ns_get_color (const char *name, NSColor **col) /* -------------------------------------------------------------------------- @@ -2026,7 +1971,7 @@ ns_get_color (const char *name, NSColor **col) if (hex[0]) { - int rr, gg, bb; + unsigned int rr, gg, bb; float fscale = scaling == 4 ? 65535.0 : (scaling == 2 ? 255.0 : 15.0); if (sscanf (hex, "%x/%x/%x", &rr, &gg, &bb)) { @@ -2091,46 +2036,6 @@ ns_lisp_to_color (Lisp_Object color, NSColor **col) } -Lisp_Object -ns_color_to_lisp (NSColor *col) -/* -------------------------------------------------------------------------- - Convert a color to a lisp string with the RGB equivalent - -------------------------------------------------------------------------- */ -{ - EmacsCGFloat red, green, blue, alpha, gray; - char buf[1024]; - const char *str; - NSTRACE ("ns_color_to_lisp"); - - block_input (); - if ([[col colorSpaceName] isEqualToString: NSNamedColorSpace]) - - if ((str =[[col colorNameComponent] UTF8String])) - { - unblock_input (); - return build_string ((char *)str); - } - - [[col colorUsingDefaultColorSpace] - getRed: &red green: &green blue: &blue alpha: &alpha]; - if (red == green && red == blue) - { - [[col colorUsingColorSpaceName: NSCalibratedWhiteColorSpace] - getWhite: &gray alpha: &alpha]; - snprintf (buf, sizeof (buf), "#%2.2lx%2.2lx%2.2lx", - lrint (gray * 0xff), lrint (gray * 0xff), lrint (gray * 0xff)); - unblock_input (); - return build_string (buf); - } - - snprintf (buf, sizeof (buf), "#%2.2lx%2.2lx%2.2lx", - lrint (red*0xff), lrint (green*0xff), lrint (blue*0xff)); - - unblock_input (); - return build_string (buf); -} - - void ns_query_color(void *col, XColor *color_def, int setPixel) /* -------------------------------------------------------------------------- @@ -2479,7 +2384,8 @@ ns_clear_frame (struct frame *f) block_input (); ns_focus (f, &r, 1); - [ns_lookup_indexed_color (NS_FACE_BACKGROUND (FRAME_DEFAULT_FACE (f)), f) set]; + [ns_lookup_indexed_color (NS_FACE_BACKGROUND + (FACE_FROM_ID (f, DEFAULT_FACE_ID)), f) set]; NSRectFill (r); ns_unfocus (f); @@ -2804,7 +2710,7 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row, [img drawInRect: r fromRect: fromRect - operation: NSCompositeSourceOver + operation: NSCompositingOperationSourceOver fraction: 1.0 respectFlipped: YES hints: nil]; @@ -2812,7 +2718,7 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row, { NSPoint pt = r.origin; pt.y += p->h; - [img compositeToPoint: pt operation: NSCompositeSourceOver]; + [img compositeToPoint: pt operation: NSCompositingOperationSourceOver]; } #endif } @@ -2878,7 +2784,10 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, { if (cursor_width < 1) cursor_width = max (FRAME_CURSOR_WIDTH (f), 1); - w->phys_cursor_width = cursor_width; + + /* The bar cursor should never be wider than the glyph. */ + if (cursor_width < w->phys_cursor_width) + w->phys_cursor_width = cursor_width; } /* If we have an HBAR, "cursor_width" MAY specify height. */ else if (cursor_type == HBAR_CURSOR) @@ -2895,12 +2804,11 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, r.size.height = h; r.size.width = w->phys_cursor_width; - /* TODO: only needed in rare cases with last-resort font in HELLO.. - should we do this more efficiently? */ - ns_clip_to_row (w, glyph_row, ANY_AREA, NO); /* do ns_focus(f, &r, 1); if remove */ + /* Prevent the cursor from being drawn outside the text area. */ + ns_clip_to_row (w, glyph_row, TEXT_AREA, NO); /* do ns_focus(f, &r, 1); if remove */ - face = FACE_FROM_ID (f, phys_cursor_glyph->face_id); + face = FACE_FROM_ID_OR_NULL (f, phys_cursor_glyph->face_id); if (face && NS_FACE_BACKGROUND (face) == ns_index_color (FRAME_CURSOR_COLOR (f), f)) { @@ -2972,11 +2880,12 @@ ns_draw_vertical_window_border (struct window *w, int x, int y0, int y1) NSTRACE ("ns_draw_vertical_window_border"); - face = FACE_FROM_ID (f, VERTICAL_BORDER_FACE_ID); - if (face) - [ns_lookup_indexed_color(face->foreground, f) set]; + face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); ns_focus (f, &r, 1); + if (face) + [ns_lookup_indexed_color(face->foreground, f) set]; + NSRectFill(r); ns_unfocus (f); } @@ -2994,11 +2903,12 @@ ns_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) NSTRACE ("ns_draw_window_divider"); - face = FACE_FROM_ID (f, WINDOW_DIVIDER_FACE_ID); - if (face) - [ns_lookup_indexed_color(face->foreground, f) set]; + face = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FACE_ID); ns_focus (f, &r, 1); + if (face) + [ns_lookup_indexed_color(face->foreground, f) set]; + NSRectFill(r); ns_unfocus (f); } @@ -3087,7 +2997,7 @@ ns_draw_underwave (struct glyph_string *s, EmacsCGFloat width, EmacsCGFloat x) -void +static void ns_draw_text_decoration (struct glyph_string *s, struct face *face, NSColor *defaultCol, CGFloat width, CGFloat x) /* -------------------------------------------------------------------------- @@ -3327,7 +3237,8 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) if (s->hl == DRAW_MOUSE_FACE) { - face = FACE_FROM_ID (s->f, MOUSE_HL_INFO (s->f)->mouse_face_face_id); + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); if (!face) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); } @@ -3394,8 +3305,9 @@ ns_maybe_dumpglyphs_background (struct glyph_string *s, char force_p) struct face *face; if (s->hl == DRAW_MOUSE_FACE) { - face = FACE_FROM_ID (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); + face + = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); if (!face) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); } @@ -3461,7 +3373,8 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) with its background color), we must clear just the image area. */ if (s->hl == DRAW_MOUSE_FACE) { - face = FACE_FROM_ID (s->f, MOUSE_HL_INFO (s->f)->mouse_face_face_id); + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); if (!face) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); } @@ -3488,17 +3401,18 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) { #ifdef NS_IMPL_COCOA NSRect dr = NSMakeRect (x, y, s->slice.width, s->slice.height); - NSRect ir = NSMakeRect (s->slice.x, s->slice.y, + NSRect ir = NSMakeRect (s->slice.x, + s->img->height - s->slice.y - s->slice.height, s->slice.width, s->slice.height); [img drawInRect: dr fromRect: ir - operation: NSCompositeSourceOver + operation: NSCompositingOperationSourceOver fraction: 1.0 respectFlipped: YES hints: nil]; #else [img compositeToPoint: NSMakePoint (x, y + s->slice.height) - operation: NSCompositeSourceOver]; + operation: NSCompositingOperationSourceOver]; #endif } @@ -3578,7 +3492,8 @@ ns_dumpglyphs_stretch (struct glyph_string *s) if (s->hl == DRAW_MOUSE_FACE) { - face = FACE_FROM_ID (s->f, MOUSE_HL_INFO (s->f)->mouse_face_face_id); + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); if (!face) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); } @@ -3656,6 +3571,32 @@ ns_dumpglyphs_stretch (struct glyph_string *s) static void +ns_draw_glyph_string_foreground (struct glyph_string *s) +{ + int x, flags; + struct font *font = s->font; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (s->face && s->face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + eabs (s->face->box_line_width); + else + x = s->x; + + flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR : + (s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE : + (s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND : + NS_DUMPGLYPH_NORMAL)); + + font->driver->draw + (s, s->cmp_from, s->nchars, x, s->ybase, + (flags == NS_DUMPGLYPH_NORMAL && !s->background_filled_p) + || flags == NS_DUMPGLYPH_MOUSEFACE); +} + + +static void ns_draw_composite_glyph_string_foreground (struct glyph_string *s) { int i, j, x; @@ -3753,7 +3694,7 @@ ns_draw_glyph_string (struct glyph_string *s) { /* TODO (optimize): focus for box and contents draw */ NSRect r[2]; - int n, flags; + int n; char box_drawn_p = 0; struct font *font = s->face->font; if (! font) font = FRAME_FONT (s->f); @@ -3823,11 +3764,6 @@ ns_draw_glyph_string (struct glyph_string *s) ns_maybe_dumpglyphs_background (s, s->first_glyph->type == COMPOSITE_GLYPH); - flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR : - (s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE : - (s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND : - NS_DUMPGLYPH_NORMAL)); - if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) { unsigned long tmp = NS_FACE_BACKGROUND (s->face); @@ -3841,10 +3777,7 @@ ns_draw_glyph_string (struct glyph_string *s) if (isComposite) ns_draw_composite_glyph_string_foreground (s); else - font->driver->draw - (s, s->cmp_from, s->nchars, s->x, s->ybase, - (flags == NS_DUMPGLYPH_NORMAL && !s->background_filled_p) - || flags == NS_DUMPGLYPH_MOUSEFACE); + ns_draw_glyph_string_foreground (s); } { @@ -3930,31 +3863,17 @@ ns_send_appdefined (int value) return; } - /* Only post this event if we haven't already posted one. This will end - the [NXApp run] main loop after having processed all events queued at - this moment. */ - -#ifdef NS_IMPL_COCOA - if (! send_appdefined) - { - /* OS X 10.10.1 swallows the AppDefined event we are sending ourselves - in certain situations (rapid incoming events). - So check if we have one, if not add one. */ - NSEvent *appev = [NSApp nextEventMatchingMask:NSApplicationDefinedMask - untilDate:[NSDate distantPast] - inMode:NSDefaultRunLoopMode - dequeue:NO]; - if (! appev) send_appdefined = YES; - } -#endif - - if (send_appdefined) + /* Only post this event if we haven't already posted one. This will + end the [NXApp run] main loop after having processed all events + queued at this moment. */ + NSEvent *appev = [NSApp nextEventMatchingMask:NSEventMaskApplicationDefined + untilDate:[NSDate distantPast] + inMode:NSDefaultRunLoopMode + dequeue:NO]; + if (! appev) { NSEvent *nxev; - /* We only need one NX_APPDEFINED event to stop NXApp from running. */ - send_appdefined = NO; - /* Don't need wakeup timer any more */ if (timed_entry) { @@ -3963,7 +3882,7 @@ ns_send_appdefined (int value) timed_entry = nil; } - nxev = [NSEvent otherEventWithType: NSApplicationDefined + nxev = [NSEvent otherEventWithType: NSEventTypeApplicationDefined location: NSMakePoint (0, 0) modifierFlags: 0 timestamp: 0 @@ -4069,14 +3988,6 @@ ns_check_pending_open_menu () } #endif /* NS_IMPL_COCOA */ -static void -unwind_apploopnr (Lisp_Object not_used) -{ - --apploopnr; - n_emacs_events_pending = 0; - ns_finish_events (); - q_event_ptr = NULL; -} static int ns_read_socket (struct terminal *terminal, struct input_event *hold_quit) @@ -4087,7 +3998,7 @@ ns_read_socket (struct terminal *terminal, struct input_event *hold_quit) -------------------------------------------------------------------------- */ { struct input_event ev; - int nevents; + int nevents = 0; NSTRACE_WHEN (NSTRACE_GROUP_EVENTS, "ns_read_socket"); @@ -4107,54 +4018,49 @@ ns_read_socket (struct terminal *terminal, struct input_event *hold_quit) return i; } - block_input (); - n_emacs_events_pending = 0; - ns_init_events (&ev); - q_event_ptr = hold_quit; - - /* we manage autorelease pools by allocate/reallocate each time around - the loop; strict nesting is occasionally violated but seems not to - matter.. earlier methods using full nesting caused major memory leaks */ - [outerpool release]; - outerpool = [[NSAutoreleasePool alloc] init]; - - /* If have pending open-file requests, attend to the next one of those. */ - if (ns_pending_files && [ns_pending_files count] != 0 - && [(EmacsApp *)NSApp openFile: [ns_pending_files objectAtIndex: 0]]) + if ([NSThread isMainThread]) { - [ns_pending_files removeObjectAtIndex: 0]; - } - /* Deal with pending service requests. */ - else if (ns_pending_service_names && [ns_pending_service_names count] != 0 - && [(EmacsApp *) - NSApp fulfillService: [ns_pending_service_names objectAtIndex: 0] - withArg: [ns_pending_service_args objectAtIndex: 0]]) - { - [ns_pending_service_names removeObjectAtIndex: 0]; - [ns_pending_service_args removeObjectAtIndex: 0]; - } - else - { - ptrdiff_t specpdl_count = SPECPDL_INDEX (); - /* Run and wait for events. We must always send one NX_APPDEFINED event - to ourself, otherwise [NXApp run] will never exit. */ - send_appdefined = YES; - ns_send_appdefined (-1); - - if (++apploopnr != 1) + block_input (); + n_emacs_events_pending = 0; + ns_init_events (&ev); + q_event_ptr = hold_quit; + + /* we manage autorelease pools by allocate/reallocate each time around + the loop; strict nesting is occasionally violated but seems not to + matter.. earlier methods using full nesting caused major memory leaks */ + [outerpool release]; + outerpool = [[NSAutoreleasePool alloc] init]; + + /* If have pending open-file requests, attend to the next one of those. */ + if (ns_pending_files && [ns_pending_files count] != 0 + && [(EmacsApp *)NSApp openFile: [ns_pending_files objectAtIndex: 0]]) { - emacs_abort (); + [ns_pending_files removeObjectAtIndex: 0]; } - record_unwind_protect (unwind_apploopnr, Qt); - [NSApp run]; - unbind_to (specpdl_count, Qnil); /* calls unwind_apploopnr */ - } + /* Deal with pending service requests. */ + else if (ns_pending_service_names && [ns_pending_service_names count] != 0 + && [(EmacsApp *) + NSApp fulfillService: [ns_pending_service_names objectAtIndex: 0] + withArg: [ns_pending_service_args objectAtIndex: 0]]) + { + [ns_pending_service_names removeObjectAtIndex: 0]; + [ns_pending_service_args removeObjectAtIndex: 0]; + } + else + { + /* Run and wait for events. We must always send one NX_APPDEFINED event + to ourself, otherwise [NXApp run] will never exit. */ + ns_send_appdefined (-1); - nevents = n_emacs_events_pending; - n_emacs_events_pending = 0; - ns_finish_events (); - q_event_ptr = NULL; - unblock_input (); + [NSApp run]; + } + + nevents = n_emacs_events_pending; + n_emacs_events_pending = 0; + ns_finish_events (); + q_event_ptr = NULL; + unblock_input (); + } return nevents; } @@ -4169,9 +4075,8 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, -------------------------------------------------------------------------- */ { int result; - int t, k, nr = 0; - struct input_event event; - char c; + NSDate *timeout_date = nil; + NSEvent *ns_event; NSTRACE_WHEN (NSTRACE_GROUP_EVENTS, "ns_select"); @@ -4187,121 +4092,34 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, return -1; } - for (k = 0; k < nfds+1; k++) - { - if (readfds && FD_ISSET(k, readfds)) ++nr; - if (writefds && FD_ISSET(k, writefds)) ++nr; - } - if (NSApp == nil + || ![NSThread isMainThread] || (timeout && timeout->tv_sec == 0 && timeout->tv_nsec == 0)) - return pselect (nfds, readfds, writefds, exceptfds, timeout, sigmask); + return pselect(nfds, readfds, writefds, + exceptfds, timeout, sigmask); + + result = pselect(nfds, readfds, writefds, exceptfds, + &(struct timespec){.tv_sec = 0, .tv_nsec = 100}, + sigmask); [outerpool release]; outerpool = [[NSAutoreleasePool alloc] init]; - - send_appdefined = YES; - if (nr > 0) - { - pthread_mutex_lock (&select_mutex); - select_nfds = nfds; - select_valid = 0; - if (readfds) - { - select_readfds = *readfds; - select_valid += SELECT_HAVE_READ; - } - if (writefds) - { - select_writefds = *writefds; - select_valid += SELECT_HAVE_WRITE; - } - - if (timeout) - { - select_timeout = *timeout; - select_valid += SELECT_HAVE_TMO; - } - - pthread_mutex_unlock (&select_mutex); - - /* Inform fd_handler that select should be called */ - c = 'g'; - emacs_write_sig (selfds[1], &c, 1); - } - else if (nr == 0 && timeout) + if (timeout) { - /* No file descriptor, just a timeout, no need to wake fd_handler */ double time = timespectod (*timeout); - timed_entry = [[NSTimer scheduledTimerWithTimeInterval: time - target: NSApp - selector: - @selector (timeout_handler:) - userInfo: 0 - repeats: NO] - retain]; - } - else /* No timeout and no file descriptors, can this happen? */ - { - /* Send appdefined so we exit from the loop */ - ns_send_appdefined (-1); + timeout_date = [NSDate dateWithTimeIntervalSinceNow:time]; } - block_input (); - ns_init_events (&event); - if (++apploopnr != 1) - { - emacs_abort (); - } + /* Listen for a new NSEvent. */ + ns_event = [NSApp nextEventMatchingMask:NSEventMaskAny + untilDate:timeout_date + inMode:NSDefaultRunLoopMode + dequeue:NO]; - { - ptrdiff_t specpdl_count = SPECPDL_INDEX (); - record_unwind_protect (unwind_apploopnr, Qt); - [NSApp run]; - unbind_to (specpdl_count, Qnil); /* calls unwind_apploopnr */ - } - - ns_finish_events (); - if (nr > 0 && readfds) + if (ns_event != nil) { - c = 's'; - emacs_write_sig (selfds[1], &c, 1); - } - unblock_input (); - - t = last_appdefined_event_data; - - if (t != NO_APPDEFINED_DATA) - { - last_appdefined_event_data = NO_APPDEFINED_DATA; - - if (t == -2) - { - /* The NX_APPDEFINED event we received was a timeout. */ - result = 0; - } - else if (t == -1) - { - /* The NX_APPDEFINED event we received was the result of - at least one real input event arriving. */ - errno = EINTR; - result = -1; - } - else - { - /* Received back from select () in fd_handler; copy the results */ - pthread_mutex_lock (&select_mutex); - if (readfds) *readfds = select_readfds; - if (writefds) *writefds = select_writefds; - pthread_mutex_unlock (&select_mutex); - result = t; - } - } - else - { - errno = EINTR; - result = -1; + raise (SIGIO); } return result; @@ -4355,7 +4173,7 @@ ns_set_vertical_scroll_bar (struct window *window, window_box (window, ANY_AREA, 0, &window_y, 0, &window_height); top = window_y; height = window_height; - width = WINDOW_CONFIG_SCROLL_BAR_COLS (window) * FRAME_COLUMN_WIDTH (f); + width = NS_SCROLL_BAR_WIDTH (f); left = WINDOW_SCROLL_BAR_AREA_X (window); r = NSMakeRect (left, top, width, height); @@ -4446,34 +4264,20 @@ ns_set_horizontal_scroll_bar (struct window *window, NSTRACE ("ns_set_horizontal_scroll_bar"); /* Get dimensions. */ - window_box (window, ANY_AREA, 0, &window_x, &window_width, 0); + window_box (window, ANY_AREA, &window_x, 0, &window_width, 0); left = window_x; width = window_width; - height = WINDOW_CONFIG_SCROLL_BAR_LINES (window) * FRAME_LINE_HEIGHT (f); + height = NS_SCROLL_BAR_HEIGHT (f); top = WINDOW_SCROLL_BAR_AREA_Y (window); r = NSMakeRect (left, top, width, height); /* the parent view is flipped, so we need to flip y value */ v = [view frame]; - /* ??????? PXW/scrollbars !!!!!!!!!!!!!!!!!!!! */ r.origin.y = (v.size.height - r.size.height - r.origin.y); XSETWINDOW (win, window); block_input (); - if (WINDOW_TOTAL_COLS (window) < 5) - { - if (!NILP (window->horizontal_scroll_bar)) - { - bar = XNS_SCROLL_BAR (window->horizontal_scroll_bar); - [bar removeFromSuperview]; - wset_horizontal_scroll_bar (window, Qnil); - } - ns_clear_frame_area (f, left, top, width, height); - unblock_input (); - return; - } - if (NILP (window->horizontal_scroll_bar)) { if (width > 0 && height > 0) @@ -4488,16 +4292,22 @@ ns_set_horizontal_scroll_bar (struct window *window, NSRect oldRect; bar = XNS_SCROLL_BAR (window->horizontal_scroll_bar); oldRect = [bar frame]; - r.size.width = oldRect.size.width; if (FRAME_LIVE_P (f) && !NSEqualRects (oldRect, r)) { - if (oldRect.origin.x != r.origin.x) - ns_clear_frame_area (f, left, top, width, height); + if (oldRect.origin.y != r.origin.y) + ns_clear_frame_area (f, left, top, width, height); [bar setFrame: r]; update_p = YES; } } + /* If there are both horizontal and vertical scroll-bars they leave + a square that belongs to neither. We need to clear it otherwise + it fills with junk. */ + if (!NILP (window->vertical_scroll_bar)) + ns_clear_frame_area (f, WINDOW_SCROLL_BAR_AREA_X (window), top, + NS_SCROLL_BAR_HEIGHT (f), height); + if (update_p) [bar setPosition: position portion: portion whole: whole]; unblock_input (); @@ -4535,13 +4345,15 @@ ns_redeem_scroll_bar (struct window *window) { id bar; NSTRACE ("ns_redeem_scroll_bar"); - if (!NILP (window->vertical_scroll_bar)) + if (!NILP (window->vertical_scroll_bar) + && WINDOW_HAS_VERTICAL_SCROLL_BAR (window)) { bar = XNS_SCROLL_BAR (window->vertical_scroll_bar); [bar reprieve]; } - if (!NILP (window->horizontal_scroll_bar)) + if (!NILP (window->horizontal_scroll_bar) + && WINDOW_HAS_HORIZONTAL_SCROLL_BAR (window)) { bar = XNS_SCROLL_BAR (window->horizontal_scroll_bar); [bar reprieve]; @@ -4823,21 +4635,6 @@ ns_term_init (Lisp_Object display_name) baud_rate = 38400; Fset_input_interrupt_mode (Qnil); - if (selfds[0] == -1) - { - if (emacs_pipe (selfds) != 0) - { - fprintf (stderr, "Failed to create pipe: %s\n", - emacs_strerror (errno)); - emacs_abort (); - } - - fcntl (selfds[0], F_SETFL, O_NONBLOCK|fcntl (selfds[0], F_GETFL)); - FD_ZERO (&select_readfds); - FD_ZERO (&select_writefds); - pthread_mutex_init (&select_mutex, NULL); - } - ns_pending_files = [[NSMutableArray alloc] init]; ns_pending_service_names = [[NSMutableArray alloc] init]; ns_pending_service_args = [[NSMutableArray alloc] init]; @@ -4850,11 +4647,6 @@ ns_term_init (Lisp_Object display_name) return NULL; [NSApp setDelegate: NSApp]; - /* Start the select thread. */ - [NSThread detachNewThreadSelector:@selector (fd_handler:) - toTarget:NSApp - withObject:nil]; - /* debugging: log all notifications */ /* [[NSNotificationCenter defaultCenter] addObserver: NSApp selector: @selector (logNotification:) @@ -4985,7 +4777,7 @@ ns_term_init (Lisp_Object display_name) action: @selector (hideOtherApplications:) keyEquivalent: @"h" atIndex: 7]; - [item setKeyEquivalentModifierMask: NSCommandKeyMask | NSAlternateKeyMask]; + [item setKeyEquivalentModifierMask: NSEventModifierFlagCommand | NSEventModifierFlagOption]; [appMenu insertItem: [NSMenuItem separatorItem] atIndex: 8]; [appMenu insertItemWithTitle: @"Quit Emacs" action: @selector (terminate:) @@ -5129,7 +4921,7 @@ ns_term_shutdown (int sig) pool = [[NSAutoreleasePool alloc] init]; NSEvent *event = - [self nextEventMatchingMask:NSAnyEventMask + [self nextEventMatchingMask:NSEventMaskAny untilDate:[NSDate distantFuture] inMode:NSDefaultRunLoopMode dequeue:YES]; @@ -5178,7 +4970,7 @@ ns_term_shutdown (int sig) #ifdef NS_IMPL_GNUSTEP // Keyboard events aren't propagated to file dialogs for some reason. if ([NSApp modalWindow] != nil && - (type == NSKeyDown || type == NSKeyUp || type == NSFlagsChanged)) + (type == NSEventTypeKeyDown || type == NSEventTypeKeyUp || type == NSEventTypeFlagsChanged)) { [[NSApp modalWindow] sendEvent: theEvent]; return; @@ -5202,7 +4994,7 @@ ns_term_shutdown (int sig) represented_frame = NULL; } - if (type == NSApplicationDefined) + if (type == NSEventTypeApplicationDefined) { switch ([theEvent data2]) { @@ -5219,13 +5011,13 @@ ns_term_shutdown (int sig) } } - if (type == NSCursorUpdate && window == nil) + if (type == NSEventTypeCursorUpdate && window == nil) { fprintf (stderr, "Dropping external cursor update event.\n"); return; } - if (type == NSApplicationDefined) + if (type == NSEventTypeApplicationDefined) { /* Events posted by ns_send_appdefined interrupt the run loop here. But, if a modal window is up, an appdefined can still come through, @@ -5236,10 +5028,6 @@ ns_term_shutdown (int sig) last_appdefined_event_data = [theEvent data1]; [self stop: self]; } - else - { - send_appdefined = YES; - } } @@ -5248,7 +5036,7 @@ ns_term_shutdown (int sig) It is a mouse move in an auxiliary menu, i.e. on the top right on macOS, such as Wifi, sound, date or similar. This prevents "spooky" highlighting in the frame under the menu. */ - if (type == NSMouseMoved && [NSApp modalWindow] == nil) + if (type == NSEventTypeMouseMoved && [NSApp modalWindow] == nil) { struct ns_display_info *di; BOOL has_focus = NO; @@ -5403,7 +5191,7 @@ runAlertPanel(NSString *title, == NSAlertDefaultReturn; #else NSAlert *alert = [[NSAlert alloc] init]; - [alert setAlertStyle: NSCriticalAlertStyle]; + [alert setAlertStyle: NSAlertStyleCritical]; [alert setMessageText: msgFormat]; [alert addButtonWithTitle: defaultButton]; [alert addButtonWithTitle: alternateButton]; @@ -5423,15 +5211,11 @@ runAlertPanel(NSString *title, if (NILP (ns_confirm_quit)) // || ns_shutdown_properly --> TO DO return NSTerminateNow; - ret = runAlertPanel(ns_app_name, - @"Exit requested. Would you like to Save Buffers and Exit, or Cancel the request?", - @"Save Buffers and Exit", @"Cancel"); + ret = runAlertPanel(ns_app_name, + @"Exit requested. Would you like to Save Buffers and Exit, or Cancel the request?", + @"Save Buffers and Exit", @"Cancel"); - if (ret) - return NSTerminateNow; - else - return NSTerminateCancel; - return NSTerminateNow; /* just in case */ + return ret ? NSTerminateNow : NSTerminateCancel; } static int @@ -5546,95 +5330,6 @@ not_in_argv (NSString *arg) ns_send_appdefined (nextappdefined); } -- (void)fd_handler:(id)unused -/* -------------------------------------------------------------------------- - Check data waiting on file descriptors and terminate if so - -------------------------------------------------------------------------- */ -{ - int result; - int waiting = 1, nfds; - char c; - - fd_set readfds, writefds, *wfds; - struct timespec timeout, *tmo; - NSAutoreleasePool *pool = nil; - - /* NSTRACE ("fd_handler"); */ - - for (;;) - { - [pool release]; - pool = [[NSAutoreleasePool alloc] init]; - - if (waiting) - { - fd_set fds; - FD_ZERO (&fds); - FD_SET (selfds[0], &fds); - result = select (selfds[0]+1, &fds, NULL, NULL, NULL); - if (result > 0 && read (selfds[0], &c, 1) == 1 && c == 'g') - waiting = 0; - } - else - { - pthread_mutex_lock (&select_mutex); - nfds = select_nfds; - - if (select_valid & SELECT_HAVE_READ) - readfds = select_readfds; - else - FD_ZERO (&readfds); - - if (select_valid & SELECT_HAVE_WRITE) - { - writefds = select_writefds; - wfds = &writefds; - } - else - wfds = NULL; - if (select_valid & SELECT_HAVE_TMO) - { - timeout = select_timeout; - tmo = &timeout; - } - else - tmo = NULL; - - pthread_mutex_unlock (&select_mutex); - - FD_SET (selfds[0], &readfds); - if (selfds[0] >= nfds) nfds = selfds[0]+1; - - result = pselect (nfds, &readfds, wfds, NULL, tmo, NULL); - - if (result == 0) - ns_send_appdefined (-2); - else if (result > 0) - { - if (FD_ISSET (selfds[0], &readfds)) - { - if (read (selfds[0], &c, 1) == 1 && c == 's') - waiting = 1; - } - else - { - pthread_mutex_lock (&select_mutex); - if (select_valid & SELECT_HAVE_READ) - select_readfds = readfds; - if (select_valid & SELECT_HAVE_WRITE) - select_writefds = writefds; - if (select_valid & SELECT_HAVE_TMO) - select_timeout = timeout; - pthread_mutex_unlock (&select_mutex); - - ns_send_appdefined (result); - } - } - waiting = 1; - } - } -} - /* ========================================================================== @@ -5712,7 +5407,7 @@ not_in_argv (NSString *arg) - (void)changeFont: (id)sender { NSEvent *e = [[self window] currentEvent]; - struct face *face = FRAME_DEFAULT_FACE (emacsframe); + struct face *face = FACE_FROM_ID (emacsframe, DEFAULT_FACE_ID); struct font *font = face->font; id newFont; CGFloat size; @@ -5787,7 +5482,7 @@ not_in_argv (NSString *arg) /* Rhapsody and macOS give up and down events for the arrow keys */ if (ns_fake_keydown == YES) ns_fake_keydown = NO; - else if ([theEvent type] != NSKeyDown) + else if ([theEvent type] != NSEventTypeKeyDown) return; if (!emacs_event) @@ -5831,12 +5526,12 @@ not_in_argv (NSString *arg) /* (Carbon way: [theEvent keyCode]) */ /* is it a "function key"? */ - /* Note: Sometimes a plain key will have the NSNumericPadKeyMask + /* Note: Sometimes a plain key will have the NSEventModifierFlagNumericPad flag set (this is probably a bug in the OS). */ - if (code < 0x00ff && (flags&NSNumericPadKeyMask)) + if (code < 0x00ff && (flags&NSEventModifierFlagNumericPad)) { - fnKeysym = ns_convert_key ([theEvent keyCode] | NSNumericPadKeyMask); + fnKeysym = ns_convert_key ([theEvent keyCode] | NSEventModifierFlagNumericPad); } if (fnKeysym == 0) { @@ -5865,15 +5560,15 @@ not_in_argv (NSString *arg) /* are there modifiers? */ emacs_event->modifiers = 0; - if (flags & NSHelpKeyMask) + if (flags & NSEventModifierFlagHelp) emacs_event->modifiers |= hyper_modifier; - if (flags & NSShiftKeyMask) + if (flags & NSEventModifierFlagShift) emacs_event->modifiers |= shift_modifier; is_right_key = (flags & NSRightCommandKeyMask) == NSRightCommandKeyMask; is_left_key = (flags & NSLeftCommandKeyMask) == NSLeftCommandKeyMask - || (! is_right_key && (flags & NSCommandKeyMask) == NSCommandKeyMask); + || (! is_right_key && (flags & NSEventModifierFlagCommand) == NSEventModifierFlagCommand); if (is_right_key) emacs_event->modifiers |= parse_solitary_modifier @@ -5894,7 +5589,7 @@ not_in_argv (NSString *arg) { /* XXX: the code we get will be unshifted, so if we have a shift modifier, must convert ourselves */ - if (!(flags & NSShiftKeyMask)) + if (!(flags & NSEventModifierFlagShift)) code = [[theEvent characters] characterAtIndex: 0]; #if 0 /* this is ugly and also requires linking w/Carbon framework @@ -5909,7 +5604,7 @@ not_in_argv (NSString *arg) UCKeyTranslate ((UCKeyboardLayout*)*uchrHandle, [[theEvent characters] characterAtIndex: 0], kUCKeyActionDisplay, - (flags & ~NSCommandKeyMask) >> 8, + (flags & ~NSEventModifierFlagCommand) >> 8, LMGetKbdType (), kUCKeyTranslateNoDeadKeysMask, &dummy, 1, &dummy, &code); code &= 0xFF; @@ -5920,7 +5615,7 @@ not_in_argv (NSString *arg) is_right_key = (flags & NSRightControlKeyMask) == NSRightControlKeyMask; is_left_key = (flags & NSLeftControlKeyMask) == NSLeftControlKeyMask - || (! is_right_key && (flags & NSControlKeyMask) == NSControlKeyMask); + || (! is_right_key && (flags & NSEventModifierFlagControl) == NSEventModifierFlagControl); if (is_right_key) emacs_event->modifiers |= parse_solitary_modifier @@ -5943,7 +5638,7 @@ not_in_argv (NSString *arg) == NSRightAlternateKeyMask; is_left_key = (flags & NSLeftAlternateKeyMask) == NSLeftAlternateKeyMask || (! is_right_key - && (flags & NSAlternateKeyMask) == NSAlternateKeyMask); + && (flags & NSEventModifierFlagOption) == NSEventModifierFlagOption); if (is_right_key) { @@ -5982,7 +5677,7 @@ not_in_argv (NSString *arg) if (NS_KEYLOG) fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n", - code, fnKeysym, flags, emacs_event->modifiers); + (unsigned) code, fnKeysym, flags, emacs_event->modifiers); /* if it was a function key or had modifiers, pass it directly to emacs */ if (fnKeysym || (emacs_event->modifiers @@ -6031,7 +5726,7 @@ not_in_argv (NSString *arg) NSTRACE ("[EmacsView keyUp:]"); if (floor (NSAppKitVersionNumber) <= 824 /*NSAppKitVersionNumber10_4*/ && - code == 0x30 && (flags & NSControlKeyMask) && !(flags & NSCommandKeyMask)) + code == 0x30 && (flags & NSEventModifierFlagControl) && !(flags & NSEventModifierFlagCommand)) { if (NS_KEYLOG) fprintf (stderr, "keyUp: passed test"); @@ -6188,8 +5883,14 @@ not_in_argv (NSString *arg) +FRAME_LINE_HEIGHT (emacsframe)); pt = [self convertPoint: pt toView: nil]; +#if !defined (NS_IMPL_COCOA) || \ + MAC_OS_X_VERSION_MAX_ALLOWED < MAC_OS_X_VERSION_10_7 pt = [[self window] convertBaseToScreen: pt]; rect.origin = pt; +#else + rect.origin = pt; + rect = [[self window] convertRectToScreen: rect]; +#endif return rect; } @@ -6278,7 +5979,7 @@ not_in_argv (NSString *arg) button clicks */ emacsframe->mouse_moved = 0; - if ([theEvent type] == NSScrollWheel) + if ([theEvent type] == NSEventTypeScrollWheel) { CGFloat delta = [theEvent deltaY]; /* Mac notebooks send wheel events w/delta =0 when trackpad scrolling */ @@ -6417,7 +6118,7 @@ not_in_argv (NSString *arg) help_echo_object, help_echo_pos); } - if (emacsframe->mouse_moved && send_appdefined) + if (emacsframe->mouse_moved) ns_send_appdefined (-1); } @@ -6833,12 +6534,12 @@ not_in_argv (NSString *arg) win = [[EmacsWindow alloc] initWithContentRect: r - styleMask: (NSResizableWindowMask | + styleMask: (NSWindowStyleMaskResizable | #if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_7 - NSTitledWindowMask | + NSWindowStyleMaskTitled | #endif - NSMiniaturizableWindowMask | - NSClosableWindowMask) + NSWindowStyleMaskMiniaturizable | + NSWindowStyleMaskClosable) backing: NSBackingStoreBuffered defer: YES]; @@ -6914,7 +6615,8 @@ not_in_argv (NSString *arg) [win makeFirstResponder: self]; col = ns_lookup_indexed_color (NS_FACE_BACKGROUND - (FRAME_DEFAULT_FACE (emacsframe)), emacsframe); + (FACE_FROM_ID (emacsframe, DEFAULT_FACE_ID)), + emacsframe); [win setBackgroundColor: col]; if ([col alphaComponent] != (EmacsCGFloat) 1.0) [win setOpaque: NO]; @@ -7113,8 +6815,7 @@ not_in_argv (NSString *arg) SET_FRAME_VISIBLE (emacsframe, 1); SET_FRAME_GARBAGED (emacsframe); - if (send_appdefined) - ns_send_appdefined (-1); + ns_send_appdefined (-1); } @@ -7261,7 +6962,7 @@ not_in_argv (NSString *arg) else { #ifdef HAVE_NATIVE_FS - res = (([[self window] styleMask] & NSFullScreenWindowMask) != 0); + res = (([[self window] styleMask] & NSWindowStyleMaskFullScreen) != 0); #else res = NO; #endif @@ -7316,7 +7017,7 @@ not_in_argv (NSString *arg) f = emacsframe; wr = [w frame]; col = ns_lookup_indexed_color (NS_FACE_BACKGROUND - (FRAME_DEFAULT_FACE (f)), + (FACE_FROM_ID (f, DEFAULT_FACE_ID)), f); if (fs_state != FULLSCREEN_BOTH) @@ -7345,7 +7046,7 @@ not_in_argv (NSString *arg) fw = [[EmacsFSWindow alloc] initWithContentRect:[w contentRectForFrameRect:wr] - styleMask:NSBorderlessWindowMask + styleMask:NSWindowStyleMaskBorderless backing:NSBackingStoreBuffered defer:YES screen:screen]; @@ -7653,11 +7354,11 @@ not_in_argv (NSString *arg) (op & 0xf) != 0xf) { if (op & NSDragOperationLink) - modifiers |= NSControlKeyMask; + modifiers |= NSEventModifierFlagControl; if (op & NSDragOperationCopy) - modifiers |= NSAlternateKeyMask; + modifiers |= NSEventModifierFlagOption; if (op & NSDragOperationGeneric) - modifiers |= NSCommandKeyMask; + modifiers |= NSEventModifierFlagCommand; } modifiers = EV_MODIFIERS2 (modifiers); @@ -8106,18 +7807,21 @@ not_in_argv (NSString *arg) MAC_OS_X_VERSION_MAX_ALLOWED < MAC_OS_X_VERSION_10_7 r = [NSScroller scrollerWidth]; #else - r = [NSScroller scrollerWidthForControlSize: NSRegularControlSize + r = [NSScroller scrollerWidthForControlSize: NSControlSizeRegular scrollerStyle: NSScrollerStyleLegacy]; #endif return r; } - - initFrame: (NSRect )r window: (Lisp_Object)nwin { NSTRACE ("[EmacsScroller initFrame: window:]"); - r.size.width = [EmacsScroller scrollerWidth]; + if (r.size.width > r.size.height) + horizontal = YES; + else + horizontal = NO; + [super initWithFrame: r/*NSMakeRect (0, 0, 0, 0)*/]; [self setContinuous: YES]; [self setEnabled: YES]; @@ -8133,9 +7837,12 @@ not_in_argv (NSString *arg) window = XWINDOW (nwin); condemned = NO; - pixel_height = NSHeight (r); - if (pixel_height == 0) pixel_height = 1; - min_portion = 20 / pixel_height; + if (horizontal) + pixel_length = NSWidth (r); + else + pixel_length = NSHeight (r); + if (pixel_length == 0) pixel_length = 1; + min_portion = 20 / pixel_length; frame = XFRAME (window->frame); if (FRAME_LIVE_P (frame)) @@ -8164,9 +7871,12 @@ not_in_argv (NSString *arg) NSTRACE ("[EmacsScroller setFrame:]"); /* block_input (); */ - pixel_height = NSHeight (newRect); - if (pixel_height == 0) pixel_height = 1; - min_portion = 20 / pixel_height; + if (horizontal) + pixel_length = NSWidth (newRect); + else + pixel_length = NSHeight (newRect); + if (pixel_length == 0) pixel_length = 1; + min_portion = 20 / pixel_length; [super setFrame: newRect]; /* unblock_input (); */ } @@ -8176,7 +7886,12 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsScroller dealloc]"); if (window) - wset_vertical_scroll_bar (window, Qnil); + { + if (horizontal) + wset_horizontal_scroll_bar (window, Qnil); + else + wset_vertical_scroll_bar (window, Qnil); + } window = 0; [super dealloc]; } @@ -8211,7 +7926,12 @@ not_in_argv (NSString *arg) if (view != nil) view->scrollbarsNeedingUpdate++; if (window) - wset_vertical_scroll_bar (window, Qnil); + { + if (horizontal) + wset_horizontal_scroll_bar (window, Qnil); + else + wset_vertical_scroll_bar (window, Qnil); + } window = 0; [self removeFromSuperview]; [self release]; @@ -8261,7 +7981,7 @@ not_in_argv (NSString *arg) { float pos; CGFloat por; - portion = max ((float)whole*min_portion/pixel_height, portion); + portion = max ((float)whole*min_portion/pixel_length, portion); pos = (float)position / (whole - portion); por = (CGFloat)portion/whole; #ifdef NS_IMPL_COCOA @@ -8291,10 +8011,20 @@ not_in_argv (NSString *arg) XSETWINDOW (win, window); emacs_event->frame_or_window = win; emacs_event->timestamp = EV_TIMESTAMP (e); - emacs_event->kind = SCROLL_BAR_CLICK_EVENT; emacs_event->arg = Qnil; - XSETINT (emacs_event->x, loc * pixel_height); - XSETINT (emacs_event->y, pixel_height-20); + + if (horizontal) + { + emacs_event->kind = HORIZONTAL_SCROLL_BAR_CLICK_EVENT; + XSETINT (emacs_event->x, em_whole * loc / pixel_length); + XSETINT (emacs_event->y, em_whole); + } + else + { + emacs_event->kind = SCROLL_BAR_CLICK_EVENT; + XSETINT (emacs_event->x, loc); + XSETINT (emacs_event->y, pixel_length-20); + } if (q_event_ptr) { @@ -8349,7 +8079,7 @@ not_in_argv (NSString *arg) NSRect sr, kr; /* hitPart is only updated AFTER event is passed on */ NSScrollerPart part = [self testPart: [e locationInWindow]]; - CGFloat inc = 0.0, loc, kloc, pos; + CGFloat loc, kloc, pos UNINIT; int edge = 0; NSTRACE ("[EmacsScroller mouseDown:]"); @@ -8357,15 +8087,15 @@ not_in_argv (NSString *arg) switch (part) { case NSScrollerDecrementPage: - last_hit_part = scroll_bar_above_handle; inc = -1.0; break; + last_hit_part = horizontal ? scroll_bar_before_handle : scroll_bar_above_handle; break; case NSScrollerIncrementPage: - last_hit_part = scroll_bar_below_handle; inc = 1.0; break; + last_hit_part = horizontal ? scroll_bar_after_handle : scroll_bar_below_handle; break; case NSScrollerDecrementLine: - last_hit_part = scroll_bar_up_arrow; inc = -0.1; break; + last_hit_part = horizontal ? scroll_bar_left_arrow : scroll_bar_up_arrow; break; case NSScrollerIncrementLine: - last_hit_part = scroll_bar_down_arrow; inc = 0.1; break; + last_hit_part = horizontal ? scroll_bar_right_arrow : scroll_bar_down_arrow; break; case NSScrollerKnob: - last_hit_part = scroll_bar_handle; break; + last_hit_part = horizontal ? scroll_bar_horizontal_handle : scroll_bar_handle; break; case NSScrollerKnobSlot: /* GNUstep-only */ last_hit_part = scroll_bar_move_ratio; break; default: /* NSScrollerNoPart? */ @@ -8374,36 +8104,34 @@ not_in_argv (NSString *arg) return; } - if (inc != 0.0) - { - pos = 0; /* ignored */ - - /* set a timer to repeat, as we can't let superclass do this modally */ - scroll_repeat_entry - = [[NSTimer scheduledTimerWithTimeInterval: SCROLL_BAR_FIRST_DELAY - target: self - selector: @selector (repeatScroll:) - userInfo: 0 - repeats: YES] - retain]; - } - else + if (part == NSScrollerKnob || part == NSScrollerKnobSlot) { /* handle, or on GNUstep possibly slot */ NSEvent *fake_event; + int length; /* compute float loc in slot and mouse offset on knob */ sr = [self convertRect: [self rectForPart: NSScrollerKnobSlot] toView: nil]; - loc = NSHeight (sr) - ([e locationInWindow].y - NSMinY (sr)); + if (horizontal) + { + length = NSWidth (sr); + loc = ([e locationInWindow].x - NSMinX (sr)); + } + else + { + length = NSHeight (sr); + loc = length - ([e locationInWindow].y - NSMinY (sr)); + } + if (loc <= 0.0) { loc = 0.0; edge = -1; } - else if (loc >= NSHeight (sr)) + else if (loc >= length) { - loc = NSHeight (sr); + loc = length; edge = 1; } @@ -8413,20 +8141,19 @@ not_in_argv (NSString *arg) { kr = [self convertRect: [self rectForPart: NSScrollerKnob] toView: nil]; - kloc = NSHeight (kr) - ([e locationInWindow].y - NSMinY (kr)); + if (horizontal) + kloc = ([e locationInWindow].x - NSMinX (kr)); + else + kloc = NSHeight (kr) - ([e locationInWindow].y - NSMinY (kr)); } last_mouse_offset = kloc; - /* if knob, tell emacs a location offset by knob pos - (to indicate top of handle) */ - if (part == NSScrollerKnob) - pos = (loc - last_mouse_offset) / NSHeight (sr); - else - /* else this is a slot click on GNUstep: go straight there */ - pos = loc / NSHeight (sr); + if (part != NSScrollerKnob) + /* this is a slot click on GNUstep: go straight there */ + pos = loc; /* send a fake mouse-up to super to preempt modal -trackKnob: mode */ - fake_event = [NSEvent mouseEventWithType: NSLeftMouseUp + fake_event = [NSEvent mouseEventWithType: NSEventTypeLeftMouseUp location: [e locationInWindow] modifierFlags: [e modifierFlags] timestamp: [e timestamp] @@ -8437,6 +8164,19 @@ not_in_argv (NSString *arg) pressure: [e pressure]]; [super mouseUp: fake_event]; } + else + { + pos = 0; /* ignored */ + + /* set a timer to repeat, as we can't let superclass do this modally */ + scroll_repeat_entry + = [[NSTimer scheduledTimerWithTimeInterval: SCROLL_BAR_FIRST_DELAY + target: self + selector: @selector (repeatScroll:) + userInfo: 0 + repeats: YES] + retain]; + } if (part != NSScrollerKnob) [self sendScrollEventAtLoc: pos fromEvent: e]; @@ -8448,23 +8188,34 @@ not_in_argv (NSString *arg) { NSRect sr; double loc, pos; + int length; NSTRACE ("[EmacsScroller mouseDragged:]"); sr = [self convertRect: [self rectForPart: NSScrollerKnobSlot] toView: nil]; - loc = NSHeight (sr) - ([e locationInWindow].y - NSMinY (sr)); + + if (horizontal) + { + length = NSWidth (sr); + loc = ([e locationInWindow].x - NSMinX (sr)); + } + else + { + length = NSHeight (sr); + loc = length - ([e locationInWindow].y - NSMinY (sr)); + } if (loc <= 0.0) { loc = 0.0; } - else if (loc >= NSHeight (sr) + last_mouse_offset) + else if (loc >= length + last_mouse_offset) { - loc = NSHeight (sr) + last_mouse_offset; + loc = length + last_mouse_offset; } - pos = (loc - last_mouse_offset) / NSHeight (sr); + pos = (loc - last_mouse_offset); [self sendScrollEventAtLoc: pos fromEvent: e]; } @@ -8674,14 +8425,16 @@ syms_of_nsterm (void) DEFVAR_LISP ("ns-alternate-modifier", ns_alternate_modifier, "This variable describes the behavior of the alternate or option key.\n\ -Set to control, meta, alt, super, or hyper means it is taken to be that key.\n\ +Set to the symbol control, meta, alt, super, or hyper means it is taken to be\n\ +that key.\n\ Set to none means that the alternate / option key is not interpreted by Emacs\n\ at all, allowing it to be used at a lower level for accented character entry."); ns_alternate_modifier = Qmeta; DEFVAR_LISP ("ns-right-alternate-modifier", ns_right_alternate_modifier, "This variable describes the behavior of the right alternate or option key.\n\ -Set to control, meta, alt, super, or hyper means it is taken to be that key.\n\ +Set to the symbol control, meta, alt, super, or hyper means it is taken to be\n\ +that key.\n\ Set to left means be the same key as `ns-alternate-modifier'.\n\ Set to none means that the alternate / option key is not interpreted by Emacs\n\ at all, allowing it to be used at a lower level for accented character entry."); @@ -8689,12 +8442,14 @@ at all, allowing it to be used at a lower level for accented character entry."); DEFVAR_LISP ("ns-command-modifier", ns_command_modifier, "This variable describes the behavior of the command key.\n\ -Set to control, meta, alt, super, or hyper means it is taken to be that key."); +Set to the symbol control, meta, alt, super, or hyper means it is taken to be\n\ +that key."); ns_command_modifier = Qsuper; DEFVAR_LISP ("ns-right-command-modifier", ns_right_command_modifier, "This variable describes the behavior of the right command key.\n\ -Set to control, meta, alt, super, or hyper means it is taken to be that key.\n\ +Set to the symbol control, meta, alt, super, or hyper means it is taken to be\n\ +that key.\n\ Set to left means be the same key as `ns-command-modifier'.\n\ Set to none means that the command / option key is not interpreted by Emacs\n\ at all, allowing it to be used at a lower level for accented character entry."); @@ -8702,12 +8457,14 @@ at all, allowing it to be used at a lower level for accented character entry."); DEFVAR_LISP ("ns-control-modifier", ns_control_modifier, "This variable describes the behavior of the control key.\n\ -Set to control, meta, alt, super, or hyper means it is taken to be that key."); +Set to the symbol control, meta, alt, super, or hyper means it is taken to be\n\ +that key."); ns_control_modifier = Qcontrol; DEFVAR_LISP ("ns-right-control-modifier", ns_right_control_modifier, "This variable describes the behavior of the right control key.\n\ -Set to control, meta, alt, super, or hyper means it is taken to be that key.\n\ +Set to the symbol control, meta, alt, super, or hyper means it is taken to be\n\ +that key.\n\ Set to left means be the same key as `ns-control-modifier'.\n\ Set to none means that the control / option key is not interpreted by Emacs\n\ at all, allowing it to be used at a lower level for accented character entry."); @@ -8715,7 +8472,8 @@ at all, allowing it to be used at a lower level for accented character entry."); DEFVAR_LISP ("ns-function-modifier", ns_function_modifier, "This variable describes the behavior of the function key (on laptops).\n\ -Set to control, meta, alt, super, or hyper means it is taken to be that key.\n\ +Set to the symbol control, meta, alt, super, or hyper means it is taken to be\n\ +that key.\n\ Set to none means that the function key is not interpreted by Emacs at all,\n\ allowing it to be used at a lower level for accented character entry."); ns_function_modifier = Qnone; diff --git a/src/print.c b/src/print.c index 2b53d7580b1..6c350fc86aa 100644 --- a/src/print.c +++ b/src/print.c @@ -38,6 +38,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <float.h> #include <ftoastr.h> +#ifdef WINDOWSNT +# include <sys/socket.h> /* for F_DUPFD_CLOEXEC */ +#endif + struct terminal; /* Avoid actual stack overflow in print. */ @@ -199,7 +203,7 @@ print_unwind (Lisp_Object saved_text) static void printchar_to_stream (unsigned int ch, FILE *stream) { - Lisp_Object dv IF_LINT (= Qnil); + Lisp_Object dv UNINIT; ptrdiff_t i = 0, n = 1; Lisp_Object coding_system = Vlocale_coding_system; bool encode_p = false; @@ -660,8 +664,6 @@ A printed representation of an object is text which describes that object. */) but we don't want to deactivate the mark just for that. No need for specbind, since errors deactivate the mark. */ Lisp_Object save_deactivate_mark = Vdeactivate_mark; - bool prev_abort_on_gc = abort_on_gc; - abort_on_gc = true; Lisp_Object printcharfun = Vprin1_to_string_buffer; PRINTPREPARE; @@ -683,7 +685,6 @@ A printed representation of an object is text which describes that object. */) Vdeactivate_mark = save_deactivate_mark; - abort_on_gc = prev_abort_on_gc; return unbind_to (count, object); } @@ -775,15 +776,6 @@ debug_output_compilation_hack (bool x) print_output_debug_flag = x; } -#if defined (GNU_LINUX) - -/* This functionality is not vitally important in general, so we rely on - non-portable ability to use stderr as lvalue. */ - -#define WITH_REDIRECT_DEBUGGING_OUTPUT 1 - -static FILE *initial_stderr_stream = NULL; - DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output, 1, 2, "FDebug output file: \nP", @@ -793,30 +785,38 @@ Optional arg APPEND non-nil (interactively, with prefix arg) means append to existing target file. */) (Lisp_Object file, Lisp_Object append) { - if (initial_stderr_stream != NULL) - { - block_input (); - fclose (stderr); - unblock_input (); - } - stderr = initial_stderr_stream; - initial_stderr_stream = NULL; + /* If equal to STDERR_FILENO, stderr has not been duplicated and is OK as-is. + Otherwise, this is a close-on-exec duplicate of the original stderr. */ + static int stderr_dup = STDERR_FILENO; + int fd = stderr_dup; - if (STRINGP (file)) + if (! NILP (file)) { file = Fexpand_file_name (file, Qnil); - initial_stderr_stream = stderr; - stderr = emacs_fopen (SSDATA (file), NILP (append) ? "w" : "a"); - if (stderr == NULL) + + if (stderr_dup == STDERR_FILENO) { - stderr = initial_stderr_stream; - initial_stderr_stream = NULL; - report_file_error ("Cannot open debugging output stream", file); + int n = fcntl (STDERR_FILENO, F_DUPFD_CLOEXEC, STDERR_FILENO + 1); + if (n < 0) + report_file_error ("dup", file); + stderr_dup = n; } + + fd = emacs_open (SSDATA (ENCODE_FILE (file)), + (O_WRONLY | O_CREAT + | (! NILP (append) ? O_APPEND : O_TRUNC)), + 0666); + if (fd < 0) + report_file_error ("Cannot open debugging output stream", file); } + + fflush (stderr); + if (dup2 (fd, STDERR_FILENO) < 0) + report_file_error ("dup2", file); + if (fd != stderr_dup) + emacs_close (fd); return Qnil; } -#endif /* GNU_LINUX */ /* This is the interface for debugging printing. */ @@ -917,7 +917,7 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, else { Lisp_Object error_conditions = Fget (errname, Qerror_conditions); - errmsg = Fget (errname, Qerror_message); + errmsg = Fsubstitute_command_keys (Fget (errname, Qerror_message)); file_error = Fmemq (Qfile_error, error_conditions); } @@ -936,7 +936,7 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, if (!STRINGP (errmsg)) write_string_1 ("peculiar error", stream); else if (SCHARS (errmsg)) - Fprinc (Fsubstitute_command_keys (errmsg), stream); + Fprinc (errmsg, stream); else sep = NULL; @@ -1911,6 +1911,42 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } printchar ('>', printcharfun); } + else if (THREADP (obj)) + { + print_c_string ("#<thread ", printcharfun); + if (STRINGP (XTHREAD (obj)->name)) + print_string (XTHREAD (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XTHREAD (obj)); + strout (buf, len, len, printcharfun); + } + printchar ('>', printcharfun); + } + else if (MUTEXP (obj)) + { + print_c_string ("#<mutex ", printcharfun); + if (STRINGP (XMUTEX (obj)->name)) + print_string (XMUTEX (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XMUTEX (obj)); + strout (buf, len, len, printcharfun); + } + printchar ('>', printcharfun); + } + else if (CONDVARP (obj)) + { + print_c_string ("#<condvar ", printcharfun); + if (STRINGP (XCONDVAR (obj)->name)) + print_string (XCONDVAR (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XCONDVAR (obj)); + strout (buf, len, len, printcharfun); + } + printchar ('>', printcharfun); + } else { ptrdiff_t size = ASIZE (obj); @@ -2305,9 +2341,7 @@ priorities. */); defsubr (&Sprint); defsubr (&Sterpri); defsubr (&Swrite_char); -#ifdef WITH_REDIRECT_DEBUGGING_OUTPUT defsubr (&Sredirect_debugging_output); -#endif DEFSYM (Qprint_escape_newlines, "print-escape-newlines"); DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte"); diff --git a/src/process.c b/src/process.c index e6ea2fbe8f7..0d88b2ce285 100644 --- a/src/process.c +++ b/src/process.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include <errno.h> #include <sys/types.h> /* Some typedefs are used in sys/file.h. */ #include <sys/file.h> @@ -39,6 +40,15 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <netinet/in.h> #include <arpa/inet.h> +#ifdef HAVE_SETRLIMIT +# include <sys/resource.h> + +/* If NOFILE_LIMIT.rlim_cur is greater than FD_SETSIZE, then + NOFILE_LIMIT is the initial limit on the number of open files, + which should be restored in child processes. */ +static struct rlimit nofile_limit; +#endif + /* Are local (unix) sockets supported? */ #if defined (HAVE_SYS_UN_H) #if !defined (AF_LOCAL) && defined (AF_UNIX) @@ -75,11 +85,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ # include <sys/stropts.h> #endif -#ifdef HAVE_RES_INIT -#include <arpa/nameser.h> -#include <resolv.h> -#endif - #ifdef HAVE_UTIL_H #include <util.h> #endif @@ -89,6 +94,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #endif #include <c-ctype.h> +#include <flexmember.h> #include <sig2str.h> #include <verify.h> @@ -125,15 +131,20 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #endif #endif +#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS +/* This is 0.1s in nanoseconds. */ +#define ASYNC_RETRY_NSEC 100000000 +#endif + #ifdef WINDOWSNT extern int sys_select (int, fd_set *, fd_set *, fd_set *, - struct timespec *, void *); + const struct timespec *, const sigset_t *); #endif -/* Work around GCC 4.7.0 bug with strict overflow checking; see +/* Work around GCC 4.3.0 bug with strict overflow checking; see <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=52904>. This bug appears to be fixed in GCC 5.1, so don't work around it there. */ -#if __GNUC__ == 4 && __GNUC_MINOR__ >= 3 +#if GNUC_PREREQ (4, 3, 0) && ! GNUC_PREREQ (5, 1, 0) # pragma GCC diagnostic ignored "-Wstrict-overflow" #endif @@ -150,6 +161,9 @@ bool inhibit_sentinels; #ifndef SOCK_CLOEXEC # define SOCK_CLOEXEC 0 #endif +#ifndef SOCK_NONBLOCK +# define SOCK_NONBLOCK 0 +#endif /* True if ERRNUM represents an error where the system call would block if a blocking variant were used. */ @@ -205,16 +219,6 @@ static EMACS_INT process_tick; /* Number of events for which the user or sentinel has been notified. */ static EMACS_INT update_tick; -/* Define NON_BLOCKING_CONNECT if we can support non-blocking connects. - The code can be simplified by assuming NON_BLOCKING_CONNECT once - Emacs starts assuming POSIX 1003.1-2001 or later. */ - -#if (defined HAVE_SELECT \ - && (defined GNU_LINUX || defined HAVE_GETPEERNAME) \ - && (defined EWOULDBLOCK || defined EINPROGRESS)) -# define NON_BLOCKING_CONNECT -#endif - /* Define DATAGRAM_SOCKETS if datagrams can be used safely on this system. We need to read full packets, so we need a "non-destructive" select. So we require either native select, @@ -245,6 +249,7 @@ static int process_output_delay_count; static bool process_output_skip; +static void start_process_unwind (Lisp_Object); static void create_process (Lisp_Object, char **, Lisp_Object); #ifdef USABLE_SIGIO static bool keyboard_bit_set (fd_set *); @@ -252,47 +257,24 @@ static bool keyboard_bit_set (fd_set *); static void deactivate_process (Lisp_Object); static int status_notify (struct Lisp_Process *, struct Lisp_Process *); static int read_process_output (Lisp_Object, int); -static void handle_child_signal (int); static void create_pty (Lisp_Object); - -static Lisp_Object get_process (register Lisp_Object name); -static void exec_sentinel (Lisp_Object proc, Lisp_Object reason); - -/* Mask of bits indicating the descriptors that we wait for input on. */ - -static fd_set input_wait_mask; - -/* Mask that excludes keyboard input descriptor(s). */ - -static fd_set non_keyboard_wait_mask; - -/* Mask that excludes process input descriptor(s). */ - -static fd_set non_process_wait_mask; - -/* Mask for selecting for write. */ - -static fd_set write_mask; - -#ifdef NON_BLOCKING_CONNECT -/* Mask of bits indicating the descriptors that we wait for connect to - complete on. Once they complete, they are removed from this mask - and added to the input_wait_mask and non_keyboard_wait_mask. */ - -static fd_set connect_wait_mask; +static void exec_sentinel (Lisp_Object, Lisp_Object); /* Number of bits set in connect_wait_mask. */ static int num_pending_connects; -#endif /* NON_BLOCKING_CONNECT */ -/* The largest descriptor currently in use for a process object; -1 if none. */ -static int max_process_desc; +/* The largest descriptor currently in use; -1 if none. */ +static int max_desc; -/* The largest descriptor currently in use for input; -1 if none. */ -static int max_input_desc; +/* Set the external socket descriptor for Emacs to use when + `make-network-process' is called with a non-nil + `:use-external-socket' option. The value should be either -1, or + the file descriptor of a socket that is already bound. */ +static int external_sock_fd; /* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; +static void wait_for_socket_fds (Lisp_Object, char const *); /* Alist of elements (NAME . PROCESS). */ static Lisp_Object Vprocess_alist; @@ -313,7 +295,7 @@ static struct coding_system *proc_encode_coding_system[FD_SETSIZE]; /* Table of `partner address' for datagram sockets. */ static struct sockaddr_and_len { struct sockaddr *sa; - int len; + ptrdiff_t len; } datagram_address[FD_SETSIZE]; #define DATAGRAM_CHAN_P(chan) (datagram_address[chan].sa != 0) #define DATAGRAM_CONN_P(proc) \ @@ -321,7 +303,6 @@ static struct sockaddr_and_len { XPROCESS (proc)->infd >= 0 && \ datagram_address[XPROCESS (proc)->infd].sa != 0) #else -#define DATAGRAM_CHAN_P(chan) (0) #define DATAGRAM_CONN_P(proc) (0) #endif @@ -378,6 +359,11 @@ pset_mark (struct Lisp_Process *p, Lisp_Object val) p->mark = val; } static void +pset_thread (struct Lisp_Process *p, Lisp_Object val) +{ + p->thread = val; +} +static void pset_name (struct Lisp_Process *p, Lisp_Object val) { p->name = val; @@ -393,11 +379,6 @@ pset_sentinel (struct Lisp_Process *p, Lisp_Object val) p->sentinel = NILP (val) ? Qinternal_default_process_sentinel : val; } static void -pset_status (struct Lisp_Process *p, Lisp_Object val) -{ - p->status = val; -} -static void pset_tty_name (struct Lisp_Process *p, Lisp_Object val) { p->tty_name = val; @@ -425,13 +406,34 @@ make_lisp_proc (struct Lisp_Process *p) return make_lisp_ptr (p, Lisp_Vectorlike); } +enum fd_bits +{ + /* Read from file descriptor. */ + FOR_READ = 1, + /* Write to file descriptor. */ + FOR_WRITE = 2, + /* This descriptor refers to a keyboard. Only valid if FOR_READ is + set. */ + KEYBOARD_FD = 4, + /* This descriptor refers to a process. */ + PROCESS_FD = 8, + /* A non-blocking connect. Only valid if FOR_WRITE is set. */ + NON_BLOCKING_CONNECT_FD = 16 +}; + static struct fd_callback_data { fd_callback func; void *data; -#define FOR_READ 1 -#define FOR_WRITE 2 - int condition; /* Mask of the defines above. */ + /* Flags from enum fd_bits. */ + int flags; + /* If this fd is locked to a certain thread, this points to it. + Otherwise, this is NULL. If an fd is locked to a thread, then + only that thread is permitted to wait on it. */ + struct thread_state *thread; + /* If this fd is currently being selected on by a thread, this + points to the thread. Otherwise it is NULL. */ + struct thread_state *waiting_thread; } fd_callback_info[FD_SETSIZE]; @@ -445,7 +447,25 @@ add_read_fd (int fd, fd_callback func, void *data) fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; - fd_callback_info[fd].condition |= FOR_READ; +} + +static void +add_non_keyboard_read_fd (int fd) +{ + eassert (fd >= 0 && fd < FD_SETSIZE); + eassert (fd_callback_info[fd].func == NULL); + + fd_callback_info[fd].flags &= ~KEYBOARD_FD; + fd_callback_info[fd].flags |= FOR_READ; + if (fd > max_desc) + max_desc = fd; +} + +static void +add_process_read_fd (int fd) +{ + add_non_keyboard_read_fd (fd); + fd_callback_info[fd].flags |= PROCESS_FD; } /* Stop monitoring file descriptor FD for when read is possible. */ @@ -455,8 +475,7 @@ delete_read_fd (int fd) { delete_keyboard_wait_descriptor (fd); - fd_callback_info[fd].condition &= ~FOR_READ; - if (fd_callback_info[fd].condition == 0) + if (fd_callback_info[fd].flags == 0) { fd_callback_info[fd].func = 0; fd_callback_info[fd].data = 0; @@ -469,28 +488,39 @@ delete_read_fd (int fd) void add_write_fd (int fd, fd_callback func, void *data) { - FD_SET (fd, &write_mask); - if (fd > max_input_desc) - max_input_desc = fd; + eassert (fd >= 0 && fd < FD_SETSIZE); fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; - fd_callback_info[fd].condition |= FOR_WRITE; + fd_callback_info[fd].flags |= FOR_WRITE; + if (fd > max_desc) + max_desc = fd; } -/* FD is no longer an input descriptor; update max_input_desc accordingly. */ +static void +add_non_blocking_write_fd (int fd) +{ + eassert (fd >= 0 && fd < FD_SETSIZE); + eassert (fd_callback_info[fd].func == NULL); + + fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD; + if (fd > max_desc) + max_desc = fd; + ++num_pending_connects; +} static void -delete_input_desc (int fd) +recompute_max_desc (void) { - if (fd == max_input_desc) - { - do - fd--; - while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask) - || FD_ISSET (fd, &write_mask))); + int fd; - max_input_desc = fd; + for (fd = max_desc; fd >= 0; --fd) + { + if (fd_callback_info[fd].flags != 0) + { + max_desc = fd; + break; + } } } @@ -499,13 +529,121 @@ delete_input_desc (int fd) void delete_write_fd (int fd) { - FD_CLR (fd, &write_mask); - fd_callback_info[fd].condition &= ~FOR_WRITE; - if (fd_callback_info[fd].condition == 0) + if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) + { + if (--num_pending_connects < 0) + emacs_abort (); + } + fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD); + if (fd_callback_info[fd].flags == 0) { fd_callback_info[fd].func = 0; fd_callback_info[fd].data = 0; - delete_input_desc (fd); + + if (fd == max_desc) + recompute_max_desc (); + } +} + +static void +compute_input_wait_mask (fd_set *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_READ) != 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +compute_non_process_wait_mask (fd_set *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_READ) != 0 + && (fd_callback_info[fd].flags & PROCESS_FD) == 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +compute_non_keyboard_wait_mask (fd_set *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_READ) != 0 + && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +compute_write_mask (fd_set *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; + if ((fd_callback_info[fd].flags & FOR_WRITE) != 0) + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } + } +} + +static void +clear_waiting_thread_info (void) +{ + int fd; + + for (fd = 0; fd <= max_desc; ++fd) + { + if (fd_callback_info[fd].waiting_thread == current_thread) + fd_callback_info[fd].waiting_thread = NULL; } } @@ -541,25 +679,37 @@ status_convert (int w) return Qrun; } +/* True if STATUS is that of a process attempting connection. */ + +static bool +connecting_status (Lisp_Object status) +{ + return CONSP (status) && EQ (XCAR (status), Qconnect); +} + /* Given a status-list, extract the three pieces of information and store them individually through the three pointers. */ static void -decode_status (Lisp_Object l, Lisp_Object *symbol, int *code, bool *coredump) +decode_status (Lisp_Object l, Lisp_Object *symbol, Lisp_Object *code, + bool *coredump) { Lisp_Object tem; + if (connecting_status (l)) + l = XCAR (l); + if (SYMBOLP (l)) { *symbol = l; - *code = 0; + *code = make_number (0); *coredump = 0; } else { *symbol = XCAR (l); tem = XCDR (l); - *code = XFASTINT (XCAR (tem)); + *code = XCAR (tem); tem = XCDR (tem); *coredump = !NILP (tem); } @@ -571,8 +721,7 @@ static Lisp_Object status_message (struct Lisp_Process *p) { Lisp_Object status = p->status; - Lisp_Object symbol; - int code; + Lisp_Object symbol, code; bool coredump; Lisp_Object string; @@ -582,7 +731,7 @@ status_message (struct Lisp_Process *p) { char const *signame; synchronize_system_messages_locale (); - signame = strsignal (code); + signame = strsignal (XFASTINT (code)); if (signame == 0) string = build_string ("unknown"); else @@ -604,20 +753,20 @@ status_message (struct Lisp_Process *p) else if (EQ (symbol, Qexit)) { if (NETCONN1_P (p)) - return build_string (code == 0 ? "deleted\n" : "connection broken by remote peer\n"); - if (code == 0) + return build_string (XFASTINT (code) == 0 + ? "deleted\n" + : "connection broken by remote peer\n"); + if (XFASTINT (code) == 0) return build_string ("finished\n"); AUTO_STRING (prefix, "exited abnormally with code "); - string = Fnumber_to_string (make_number (code)); + string = Fnumber_to_string (code); AUTO_STRING (suffix, coredump ? " (core dumped)\n" : "\n"); return concat3 (prefix, string, suffix); } else if (EQ (symbol, Qfailed)) { - AUTO_STRING (prefix, "failed with code "); - string = Fnumber_to_string (make_number (code)); - AUTO_STRING (suffix, "\n"); - return concat3 (prefix, string, suffix); + AUTO_STRING (format, "failed with code %s\n"); + return CALLN (Fformat, format, code); } else return Fcopy_sequence (Fsymbol_name (symbol)); @@ -678,11 +827,7 @@ allocate_pty (char pty_name[PTY_NAME_SIZE]) if (faccessat (AT_FDCWD, pty_name, R_OK | W_OK, AT_EACCESS) != 0) { emacs_close (fd); -# ifndef __sgi continue; -# else - return -1; -# endif /* __sgi */ } setup_pty (fd); return fd; @@ -703,41 +848,44 @@ allocate_process (void) static Lisp_Object make_process (Lisp_Object name) { - register Lisp_Object val, tem, name1; - register struct Lisp_Process *p; - char suffix[sizeof "<>" + INT_STRLEN_BOUND (printmax_t)]; - printmax_t i; - - p = allocate_process (); + struct Lisp_Process *p = allocate_process (); /* Initialize Lisp data. Note that allocate_process initializes all Lisp data to nil, so do it only for slots which should not be nil. */ pset_status (p, Qrun); pset_mark (p, Fmake_marker ()); + pset_thread (p, Fcurrent_thread ()); /* Initialize non-Lisp data. Note that allocate_process zeroes out all non-Lisp data, so do it only for slots which should not be zero. */ p->infd = -1; p->outfd = -1; - for (i = 0; i < PROCESS_OPEN_FDS; i++) + for (int i = 0; i < PROCESS_OPEN_FDS; i++) p->open_fd[i] = -1; #ifdef HAVE_GNUTLS - p->gnutls_initstage = GNUTLS_STAGE_EMPTY; + verify (GNUTLS_STAGE_EMPTY == 0); + eassert (p->gnutls_initstage == GNUTLS_STAGE_EMPTY); + eassert (NILP (p->gnutls_boot_parameters)); #endif /* If name is already in use, modify it until it is unused. */ - name1 = name; - for (i = 1; ; i++) + Lisp_Object name1 = name; + for (printmax_t i = 1; ; i++) { - tem = Fget_process (name1); - if (NILP (tem)) break; - name1 = concat2 (name, make_formatted_string (suffix, "<%"pMd">", i)); + Lisp_Object tem = Fget_process (name1); + if (NILP (tem)) + break; + char const suffix_fmt[] = "<%"pMd">"; + char suffix[sizeof suffix_fmt + INT_STRLEN_BOUND (printmax_t)]; + AUTO_STRING_WITH_LEN (lsuffix, suffix, sprintf (suffix, suffix_fmt, i)); + name1 = concat2 (name, lsuffix); } name = name1; pset_name (p, name); pset_sentinel (p, Qinternal_default_process_sentinel); pset_filter (p, Qinternal_default_process_filter); + Lisp_Object val; XSETPROCESS (val, p); Vprocess_alist = Fcons (Fcons (name, val), Vprocess_alist); return val; @@ -754,6 +902,40 @@ remove_process (register Lisp_Object proc) deactivate_process (proc); } +void +update_processes_for_thread_death (Lisp_Object dying_thread) +{ + Lisp_Object pair; + + for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair)) + { + Lisp_Object process = XCDR (XCAR (pair)); + if (EQ (XPROCESS (process)->thread, dying_thread)) + { + struct Lisp_Process *proc = XPROCESS (process); + + pset_thread (proc, Qnil); + if (proc->infd >= 0) + fd_callback_info[proc->infd].thread = NULL; + if (proc->outfd >= 0) + fd_callback_info[proc->outfd].thread = NULL; + } + } +} + +#ifdef HAVE_GETADDRINFO_A +static void +free_dns_request (Lisp_Object proc) +{ + struct Lisp_Process *p = XPROCESS (proc); + + if (p->dns_request->ar_result) + freeaddrinfo (p->dns_request->ar_result); + xfree (p->dns_request); + p->dns_request = NULL; +} +#endif + DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, doc: /* Return t if OBJECT is a process. */) @@ -844,6 +1026,25 @@ nil, indicating the current buffer's process. */) process = get_process (process); p = XPROCESS (process); +#ifdef HAVE_GETADDRINFO_A + if (p->dns_request) + { + /* Cancel the request. Unless shutting down, wait until + completion. Free the request if completely canceled. */ + + bool canceled = gai_cancel (p->dns_request) != EAI_NOTCANCELED; + if (!canceled && !inhibit_sentinels) + { + struct gaicb const *req = p->dns_request; + while (gai_suspend (&req, 1, NULL) != 0) + continue; + canceled = true; + } + if (canceled) + free_dns_request (process); + } +#endif + p->raw_status_new = 0; if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) { @@ -1020,6 +1221,17 @@ DEFUN ("process-mark", Fprocess_mark, Sprocess_mark, return XPROCESS (process)->mark; } +static void +set_process_filter_masks (struct Lisp_Process *p) +{ + if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten)) + delete_read_fd (p->infd); + else if (EQ (p->filter, Qt) + /* Network or serial process not stopped: */ + && !EQ (p->command, Qt)) + add_process_read_fd (p->infd); +} + DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, 2, 2, 0, doc: /* Give PROCESS the filter function FILTER; nil means default. @@ -1036,12 +1248,10 @@ The string argument is normally a multibyte string, except: - if `default-enable-multibyte-characters' is nil, it is a unibyte string (the result of converting the decoded input multibyte string to unibyte with `string-make-unibyte'). */) - (register Lisp_Object process, Lisp_Object filter) + (Lisp_Object process, Lisp_Object filter) { - struct Lisp_Process *p; - CHECK_PROCESS (process); - p = XPROCESS (process); + struct Lisp_Process *p = XPROCESS (process); /* Don't signal an error if the process's input file descriptor is closed. This could make debugging Lisp more difficult, @@ -1054,23 +1264,11 @@ The string argument is normally a multibyte string, except: if (NILP (filter)) filter = Qinternal_default_process_filter; + pset_filter (p, filter); + if (p->infd >= 0) - { - if (EQ (filter, Qt) && !EQ (p->status, Qlisten)) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } - else if (EQ (p->filter, Qt) - /* Network or serial process not stopped: */ - && !EQ (p->command, Qt)) - { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); - } - } + set_process_filter_masks (p); - pset_filter (p, filter); if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) pset_childp (p, Fplist_put (p->childp, QCfilter, filter)); setup_process_coding_systems (process); @@ -1118,6 +1316,44 @@ See `set-process-sentinel' for more info on sentinels. */) return XPROCESS (process)->sentinel; } +DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread, + 2, 2, 0, + doc: /* Set the locking thread of PROCESS to be THREAD. +If THREAD is nil, the process is unlocked. */) + (Lisp_Object process, Lisp_Object thread) +{ + struct Lisp_Process *proc; + struct thread_state *tstate; + + CHECK_PROCESS (process); + if (NILP (thread)) + tstate = NULL; + else + { + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + } + + proc = XPROCESS (process); + pset_thread (proc, thread); + if (proc->infd >= 0) + fd_callback_info[proc->infd].thread = tstate; + if (proc->outfd >= 0) + fd_callback_info[proc->outfd].thread = tstate; + + return thread; +} + +DEFUN ("process-thread", Fprocess_thread, Sprocess_thread, + 1, 1, 0, + doc: /* Ret the locking thread of PROCESS. +If PROCESS is unlocked, this function returns nil. */) + (Lisp_Object process) +{ + CHECK_PROCESS (process); + return XPROCESS (process)->thread; +} + DEFUN ("set-process-window-size", Fset_process_window_size, Sset_process_window_size, 3, 3, 0, doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT. @@ -1131,7 +1367,8 @@ nil otherwise. */) CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); CHECK_RANGED_INTEGER (width, 0, USHRT_MAX); - if (XPROCESS (process)->infd < 0 + if (NETCONN_P (process) + || XPROCESS (process)->infd < 0 || (set_window_size (XPROCESS (process)->infd, XINT (height), XINT (width)) < 0)) @@ -1199,8 +1436,10 @@ optional KEY arg. If KEY is nil, value is a cons cell of the form connection; it is t for a pipe connection. If KEY is t, the complete contact information for the connection is returned, else the specific value for the keyword KEY is returned. See `make-network-process', -\`make-serial-process', or `make-pipe-process' for the list of keywords. */) - (register Lisp_Object process, Lisp_Object key) +`make-serial-process', or `make pipe-process' for the list of keywords. +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) + (Lisp_Object process, Lisp_Object key) { Lisp_Object contact; @@ -1208,6 +1447,10 @@ value for the keyword KEY is returned. See `make-network-process', contact = XPROCESS (process)->childp; #ifdef DATAGRAM_SOCKETS + + if (NETCONN_P (process)) + wait_for_socket_fds (process, "process-contact"); + if (DATAGRAM_CONN_P (process) && (EQ (key, Qt) || EQ (key, QCremote))) contact = Fplist_put (contact, QCremote, @@ -1242,8 +1485,8 @@ DEFUN ("process-plist", Fprocess_plist, Sprocess_plist, DEFUN ("set-process-plist", Fset_process_plist, Sset_process_plist, 2, 2, 0, - doc: /* Replace the plist of PROCESS with PLIST. Returns PLIST. */) - (register Lisp_Object process, Lisp_Object plist) + doc: /* Replace the plist of PROCESS with PLIST. Return PLIST. */) + (Lisp_Object process, Lisp_Object plist) { CHECK_PROCESS (process); CHECK_LIST (plist); @@ -1283,7 +1526,7 @@ A 4 or 5 element vector represents an IPv4 address (with port number). An 8 or 9 element vector represents an IPv6 address (with port number). If optional second argument OMIT-PORT is non-nil, don't include a port number in the string, even when present in ADDRESS. -Returns nil if format of ADDRESS is invalid. */) +Return nil if format of ADDRESS is invalid. */) (Lisp_Object address, Lisp_Object omit_port) { if (NILP (address)) @@ -1360,8 +1603,6 @@ DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0, /* Starting asynchronous inferior processes. */ -static void start_process_unwind (Lisp_Object proc); - DEFUN ("make-process", Fmake_process, Smake_process, 0, MANY, 0, doc: /* Start a program in a subprocess. Return the process object for it. @@ -1412,7 +1653,6 @@ usage: (make-process &rest ARGS) */) Lisp_Object buffer, name, command, program, proc, contact, current_dir, tem; Lisp_Object xstderr, stderrproc; ptrdiff_t count = SPECPDL_INDEX (); - USE_SAFE_ALLOCA; if (nargs == 0) return Qnil; @@ -1461,14 +1701,10 @@ usage: (make-process &rest ARGS) */) } proc = make_process (name); - /* If an error occurs and we can't start the process, we want to - remove it from the process list. This means that each error - check in create_process doesn't need to call remove_process - itself; it's all taken care of here. */ record_unwind_protect (start_process_unwind, proc); pset_childp (XPROCESS (proc), Qt); - pset_plist (XPROCESS (proc), Qnil); + eassert (NILP (XPROCESS (proc)->plist)); pset_type (XPROCESS (proc), Qreal); pset_buffer (XPROCESS (proc), buffer); pset_sentinel (XPROCESS (proc), Fplist_get (contact, QCsentinel)); @@ -1499,8 +1735,9 @@ usage: (make-process &rest ARGS) */) #ifdef HAVE_GNUTLS /* AKA GNUTLS_INITSTAGE(proc). */ - XPROCESS (proc)->gnutls_initstage = GNUTLS_STAGE_EMPTY; - pset_gnutls_cred_type (XPROCESS (proc), Qnil); + verify (GNUTLS_STAGE_EMPTY == 0); + eassert (XPROCESS (proc)->gnutls_initstage == GNUTLS_STAGE_EMPTY); + eassert (NILP (XPROCESS (proc)->gnutls_cred_type)); #endif XPROCESS (proc)->adaptive_read_buffering @@ -1513,6 +1750,8 @@ usage: (make-process &rest ARGS) */) BUF_ZV (XBUFFER (buffer)), BUF_ZV_BYTE (XBUFFER (buffer))); + USE_SAFE_ALLOCA; + { /* Decide coding systems for communicating with the process. Here we don't setup the structure coding_system nor pay attention to @@ -1590,7 +1829,7 @@ usage: (make-process &rest ARGS) */) pset_decoding_buf (XPROCESS (proc), empty_unibyte_string); - XPROCESS (proc)->decoding_carryover = 0; + eassert (XPROCESS (proc)->decoding_carryover == 0); pset_encoding_buf (XPROCESS (proc), empty_unibyte_string); XPROCESS (proc)->inherit_coding_system_flag @@ -1671,18 +1910,11 @@ usage: (make-process &rest ARGS) */) return unbind_to (count, proc); } -/* This function is the unwind_protect form for Fstart_process. If - PROC doesn't have its pid set, then we know someone has signaled - an error and the process wasn't started successfully, so we should - remove it from the process list. */ +/* If PROC doesn't have its pid set, then an error was signaled and + the process wasn't started successfully, so remove it. */ static void start_process_unwind (Lisp_Object proc) { - if (!PROCESSP (proc)) - emacs_abort (); - - /* Was PROC started successfully? - -2 is used for a pty with no process, eg for gdb. */ if (XPROCESS (proc)->pid <= 0 && XPROCESS (proc)->pid != -2) remove_process (proc); } @@ -1799,13 +2031,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) pset_status (p, Qrun); if (!EQ (p->command, Qt)) - { - FD_SET (inchannel, &input_wait_mask); - FD_SET (inchannel, &non_keyboard_wait_mask); - } - - if (inchannel > max_process_desc) - max_process_desc = inchannel; + add_process_read_fd (inchannel); /* This may signal an error. */ setup_process_coding_systems (process); @@ -1841,9 +2067,8 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) /* Make the pty be the controlling terminal of the process. */ #ifdef HAVE_PTYS /* First, disconnect its current controlling terminal. */ - /* We tried doing setsid only if pty_flag, but it caused - process_set_signal to fail on SGI when using a pipe. */ - setsid (); + if (pty_flag) + setsid (); /* Make the pty's terminal the controlling terminal. */ if (pty_flag && forkin >= 0) { @@ -1879,7 +2104,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) { /* I wonder: would just ioctl (0, TIOCNOTTY, 0) work here? I can't test it since I don't have 4.3. */ - int j = emacs_open ("/dev/tty", O_RDWR, 0); + int j = emacs_open (DEV_TTY, O_RDWR, 0); if (j >= 0) { ioctl (j, TIOCNOTTY, 0); @@ -2039,10 +2264,7 @@ create_pty (Lisp_Object process) pset_status (p, Qrun); setup_process_coding_systems (process); - FD_SET (pty_fd, &input_wait_mask); - FD_SET (pty_fd, &non_keyboard_wait_mask); - if (pty_fd > max_process_desc) - max_process_desc = pty_fd; + add_process_read_fd (pty_fd); pset_tty_name (p, build_string (pty_name)); } @@ -2126,8 +2348,8 @@ usage: (make-pipe-process &rest ARGS) */) p->infd = inchannel; p->outfd = outchannel; - if (inchannel > max_process_desc) - max_process_desc = inchannel; + if (inchannel > max_desc) + max_desc = inchannel; buffer = Fplist_get (contact, QCbuffer); if (NILP (buffer)) @@ -2140,7 +2362,7 @@ usage: (make-pipe-process &rest ARGS) */) pset_type (p, Qpipe); pset_sentinel (p, Fplist_get (contact, QCsentinel)); pset_filter (p, Fplist_get (contact, QCfilter)); - pset_log (p, Qnil); + eassert (NILP (p->log)); if (tem = Fplist_get (contact, QCnoquery), !NILP (tem)) p->kill_without_query = 1; if (tem = Fplist_get (contact, QCstop), !NILP (tem)) @@ -2148,10 +2370,7 @@ usage: (make-pipe-process &rest ARGS) */) eassert (! p->pty_flag); if (!EQ (p->command, Qt)) - { - FD_SET (inchannel, &input_wait_mask); - FD_SET (inchannel, &non_keyboard_wait_mask); - } + add_process_read_fd (inchannel); p->adaptive_read_buffering = (NILP (Vprocess_adaptive_read_buffering) ? 0 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2); @@ -2231,12 +2450,12 @@ usage: (make-pipe-process &rest ARGS) */) The address family of sa is not included in the result. */ Lisp_Object -conv_sockaddr_to_lisp (struct sockaddr *sa, int len) +conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len) { Lisp_Object address; - int i; + ptrdiff_t i; unsigned char *cp; - register struct Lisp_Vector *p; + struct Lisp_Vector *p; /* Workaround for a bug in getsockname on BSD: Names bound to sockets in the UNIX domain are inaccessible; getsockname returns @@ -2308,13 +2527,23 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, int len) return address; } +/* Convert an internal struct addrinfo to a Lisp object. */ + +static Lisp_Object +conv_addrinfo_to_lisp (struct addrinfo *res) +{ + Lisp_Object protocol = make_number (res->ai_protocol); + eassert (XINT (protocol) == res->ai_protocol); + return Fcons (protocol, conv_sockaddr_to_lisp (res->ai_addr, res->ai_addrlen)); +} + /* Get family and required size for sockaddr structure to hold ADDRESS. */ -static int +static ptrdiff_t get_lisp_to_sockaddr_size (Lisp_Object address, int *familyp) { - register struct Lisp_Vector *p; + struct Lisp_Vector *p; if (VECTORP (address)) { @@ -2430,13 +2659,18 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int #ifdef DATAGRAM_SOCKETS DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_address, 1, 1, 0, - doc: /* Get the current datagram address associated with PROCESS. */) + doc: /* Get the current datagram address associated with PROCESS. +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process) { int channel; CHECK_PROCESS (process); + if (NETCONN_P (process)) + wait_for_socket_fds (process, "process-datagram-address"); + if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2448,14 +2682,21 @@ DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_ DEFUN ("set-process-datagram-address", Fset_process_datagram_address, Sset_process_datagram_address, 2, 2, 0, doc: /* Set the datagram address for PROCESS to ADDRESS. -Returns nil upon error setting address, ADDRESS otherwise. */) +Return nil upon error setting address, ADDRESS otherwise. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object address) { int channel; - int family, len; + int family; + ptrdiff_t len; CHECK_PROCESS (process); + if (NETCONN_P (process)) + wait_for_socket_fds (process, "set-process-datagram-address"); + if (!DATAGRAM_CONN_P (process)) return Qnil; @@ -2511,7 +2752,7 @@ static const struct socket_options { /* Set option OPT to value VAL on socket S. - Returns (1<<socket_options[OPT].optbit) if option is known, 0 otherwise. + Return (1<<socket_options[OPT].optbit) if option is known, 0 otherwise. Signals an error if setting a known option fails. */ @@ -2613,7 +2854,10 @@ DEFUN ("set-network-process-option", doc: /* For network process PROCESS set option OPTION to value VALUE. See `make-network-process' for a list of options and values. If optional fourth arg NO-ERROR is non-nil, don't signal an error if -OPTION is not a supported option, return nil instead; otherwise return t. */) +OPTION is not a supported option, return nil instead; otherwise return t. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object option, Lisp_Object value, Lisp_Object no_error) { int s; @@ -2624,6 +2868,8 @@ OPTION is not a supported option, return nil instead; otherwise return t. */) if (!NETCONN1_P (p)) error ("Process is not a network process"); + wait_for_socket_fds (process, "set-network-process-option"); + s = p->infd; if (s < 0) error ("Process is not running"); @@ -2837,8 +3083,8 @@ usage: (make-serial-process &rest ARGS) */) p->open_fd[SUBPROCESS_STDIN] = fd; p->infd = fd; p->outfd = fd; - if (fd > max_process_desc) - max_process_desc = fd; + if (fd > max_desc) + max_desc = fd; chan_process[fd] = proc; buffer = Fplist_get (contact, QCbuffer); @@ -2852,7 +3098,7 @@ usage: (make-serial-process &rest ARGS) */) pset_type (p, Qserial); pset_sentinel (p, Fplist_get (contact, QCsentinel)); pset_filter (p, Fplist_get (contact, QCfilter)); - pset_log (p, Qnil); + eassert (NILP (p->log)); if (tem = Fplist_get (contact, QCnoquery), !NILP (tem)) p->kill_without_query = 1; if (tem = Fplist_get (contact, QCstop), !NILP (tem)) @@ -2860,10 +3106,7 @@ usage: (make-serial-process &rest ARGS) */) eassert (! p->pty_flag); if (!EQ (p->command, Qt)) - { - FD_SET (fd, &input_wait_mask); - FD_SET (fd, &non_keyboard_wait_mask); - } + add_process_read_fd (fd); if (BUFFERP (buffer)) { @@ -2906,7 +3149,7 @@ usage: (make-serial-process &rest ARGS) */) setup_process_coding_systems (proc); pset_decoding_buf (p, empty_unibyte_string); - p->decoding_carryover = 0; + eassert (p->decoding_carryover == 0); pset_encoding_buf (p, empty_unibyte_string); p->inherit_coding_system_flag = !(!NILP (tem) || NILP (buffer) || !inherit_process_coding_system); @@ -2918,6 +3161,477 @@ usage: (make-serial-process &rest ARGS) */) return proc; } +static void +set_network_socket_coding_system (Lisp_Object proc, Lisp_Object host, + Lisp_Object service, Lisp_Object name) +{ + Lisp_Object tem; + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object contact = p->childp; + Lisp_Object coding_systems = Qt; + Lisp_Object val; + + tem = Fplist_member (contact, QCcoding); + if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) + tem = Qnil; /* No error message (too late!). */ + + /* Setup coding systems for communicating with the network stream. */ + /* Qt denotes we have not yet called Ffind_operation_coding_system. */ + + if (!NILP (tem)) + { + val = XCAR (XCDR (tem)); + if (CONSP (val)) + val = XCAR (val); + } + else if (!NILP (Vcoding_system_for_read)) + val = Vcoding_system_for_read; + else if ((!NILP (p->buffer) + && NILP (BVAR (XBUFFER (p->buffer), enable_multibyte_characters))) + || (NILP (p->buffer) + && NILP (BVAR (&buffer_defaults, enable_multibyte_characters)))) + /* We dare not decode end-of-line format by setting VAL to + Qraw_text, because the existing Emacs Lisp libraries + assume that they receive bare code including a sequence of + CR LF. */ + val = Qnil; + else + { + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + coding_systems = CALLN (Ffind_operation_coding_system, + Qopen_network_stream, name, p->buffer, + host, service); + if (CONSP (coding_systems)) + val = XCAR (coding_systems); + else if (CONSP (Vdefault_process_coding_system)) + val = XCAR (Vdefault_process_coding_system); + else + val = Qnil; + } + pset_decode_coding_system (p, val); + + if (!NILP (tem)) + { + val = XCAR (XCDR (tem)); + if (CONSP (val)) + val = XCDR (val); + } + else if (!NILP (Vcoding_system_for_write)) + val = Vcoding_system_for_write; + else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) + val = Qnil; + else + { + if (EQ (coding_systems, Qt)) + { + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + coding_systems = CALLN (Ffind_operation_coding_system, + Qopen_network_stream, name, p->buffer, + host, service); + } + if (CONSP (coding_systems)) + val = XCDR (coding_systems); + else if (CONSP (Vdefault_process_coding_system)) + val = XCDR (Vdefault_process_coding_system); + else + val = Qnil; + } + pset_encode_coding_system (p, val); + + pset_decoding_buf (p, empty_unibyte_string); + p->decoding_carryover = 0; + pset_encoding_buf (p, empty_unibyte_string); + + p->inherit_coding_system_flag + = !(!NILP (tem) || NILP (p->buffer) || !inherit_process_coding_system); +} + +#ifdef HAVE_GNUTLS +static void +finish_after_tls_connection (Lisp_Object proc) +{ + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object contact = p->childp; + Lisp_Object result = Qt; + + if (!NILP (Ffboundp (Qnsm_verify_connection))) + result = call3 (Qnsm_verify_connection, + proc, + Fplist_get (contact, QChost), + Fplist_get (contact, QCservice)); + + if (NILP (result)) + { + pset_status (p, list2 (Qfailed, + build_string ("The Network Security Manager stopped the connections"))); + deactivate_process (proc); + } + else if (p->outfd < 0) + { + /* The counterparty may have closed the connection (especially + if the NSM prompt above take a long time), so recheck the file + descriptor here. */ + pset_status (p, Qfailed); + deactivate_process (proc); + } + else if ((fd_callback_info[p->outfd].flags & NON_BLOCKING_CONNECT_FD) == 0) + { + /* If we cleared the connection wait mask before we did the TLS + setup, then we have to say that the process is finally "open" + here. */ + pset_status (p, Qrun); + /* Execute the sentinel here. If we had relied on status_notify + to do it later, it will read input from the process before + calling the sentinel. */ + exec_sentinel (proc, build_string ("open\n")); + } +} +#endif + +static void +connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, + Lisp_Object use_external_socket_p) +{ + ptrdiff_t count = SPECPDL_INDEX (); + int s = -1, outch, inch; + int xerrno = 0; + int family; + struct sockaddr *sa = NULL; + int ret; + ptrdiff_t addrlen; + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object contact = p->childp; + int optbits = 0; + int socket_to_use = -1; + + if (!NILP (use_external_socket_p)) + { + socket_to_use = external_sock_fd; + + /* Ensure we don't consume the external socket twice. */ + external_sock_fd = -1; + } + + /* Do this in case we never enter the while-loop below. */ + s = -1; + + while (!NILP (addrinfos)) + { + Lisp_Object addrinfo = XCAR (addrinfos); + addrinfos = XCDR (addrinfos); + int protocol = XINT (XCAR (addrinfo)); + Lisp_Object ip_address = XCDR (addrinfo); + +#ifdef WINDOWSNT + retry_connect: +#endif + + addrlen = get_lisp_to_sockaddr_size (ip_address, &family); + if (sa) + free (sa); + sa = xmalloc (addrlen); + conv_lisp_to_sockaddr (family, ip_address, sa, addrlen); + + s = socket_to_use; + if (s < 0) + { + int socktype = p->socktype | SOCK_CLOEXEC; + if (p->is_non_blocking_client) + socktype |= SOCK_NONBLOCK; + s = socket (family, socktype, protocol); + if (s < 0) + { + xerrno = errno; + continue; + } + } + + if (p->is_non_blocking_client && ! (SOCK_NONBLOCK && socket_to_use < 0)) + { + ret = fcntl (s, F_SETFL, O_NONBLOCK); + if (ret < 0) + { + xerrno = errno; + emacs_close (s); + s = -1; + if (0 <= socket_to_use) + break; + continue; + } + } + +#ifdef DATAGRAM_SOCKETS + if (!p->is_server && p->socktype == SOCK_DGRAM) + break; +#endif /* DATAGRAM_SOCKETS */ + + /* Make us close S if quit. */ + record_unwind_protect_int (close_file_unwind, s); + + /* Parse network options in the arg list. We simply ignore anything + which isn't a known option (including other keywords). An error + is signaled if setting a known option fails. */ + { + Lisp_Object params = contact, key, val; + + while (!NILP (params)) + { + key = XCAR (params); + params = XCDR (params); + val = XCAR (params); + params = XCDR (params); + optbits |= set_socket_option (s, key, val); + } + } + + if (p->is_server) + { + /* Configure as a server socket. */ + + /* SO_REUSEADDR = 1 is default for server sockets; must specify + explicit :reuseaddr key to override this. */ +#ifdef HAVE_LOCAL_SOCKETS + if (family != AF_LOCAL) +#endif + if (!(optbits & (1 << OPIX_REUSEADDR))) + { + int optval = 1; + if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval)) + report_file_error ("Cannot set reuse option on server socket", Qnil); + } + + /* If passed a socket descriptor, it should be already bound. */ + if (socket_to_use < 0 && bind (s, sa, addrlen) != 0) + report_file_error ("Cannot bind server socket", Qnil); + +#ifdef HAVE_GETSOCKNAME + if (p->port == 0) + { + struct sockaddr_in sa1; + socklen_t len1 = sizeof (sa1); + if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) + { + Lisp_Object service; + service = make_number (ntohs (sa1.sin_port)); + contact = Fplist_put (contact, QCservice, service); + /* Save the port number so that we can stash it in + the process object later. */ + ((struct sockaddr_in *)sa)->sin_port = sa1.sin_port; + } + } +#endif + + if (p->socktype != SOCK_DGRAM && listen (s, p->backlog)) + report_file_error ("Cannot listen on server socket", Qnil); + + break; + } + + immediate_quit = 1; + QUIT; + + ret = connect (s, sa, addrlen); + xerrno = errno; + + if (ret == 0 || xerrno == EISCONN) + { + /* The unwind-protect will be discarded afterwards. + Likewise for immediate_quit. */ + break; + } + + if (p->is_non_blocking_client && xerrno == EINPROGRESS) + break; + +#ifndef WINDOWSNT + if (xerrno == EINTR) + { + /* Unlike most other syscalls connect() cannot be called + again. (That would return EALREADY.) The proper way to + wait for completion is pselect(). */ + int sc; + socklen_t len; + fd_set fdset; + retry_select: + FD_ZERO (&fdset); + FD_SET (s, &fdset); + QUIT; + sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL); + if (sc == -1) + { + if (errno == EINTR) + goto retry_select; + else + report_file_error ("Failed select", Qnil); + } + eassert (sc > 0); + + len = sizeof xerrno; + eassert (FD_ISSET (s, &fdset)); + if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) < 0) + report_file_error ("Failed getsockopt", Qnil); + if (xerrno == 0) + break; + if (NILP (addrinfos)) + report_file_errno ("Failed connect", Qnil, xerrno); + } +#endif /* !WINDOWSNT */ + + immediate_quit = 0; + + /* Discard the unwind protect closing S. */ + specpdl_ptr = specpdl + count; + emacs_close (s); + s = -1; + if (0 <= socket_to_use) + break; + +#ifdef WINDOWSNT + if (xerrno == EINTR) + goto retry_connect; +#endif + } + + if (s >= 0) + { +#ifdef DATAGRAM_SOCKETS + if (p->socktype == SOCK_DGRAM) + { + if (datagram_address[s].sa) + emacs_abort (); + + datagram_address[s].sa = xmalloc (addrlen); + datagram_address[s].len = addrlen; + if (p->is_server) + { + Lisp_Object remote; + memset (datagram_address[s].sa, 0, addrlen); + if (remote = Fplist_get (contact, QCremote), !NILP (remote)) + { + int rfamily; + ptrdiff_t rlen = get_lisp_to_sockaddr_size (remote, &rfamily); + if (rlen != 0 && rfamily == family + && rlen == addrlen) + conv_lisp_to_sockaddr (rfamily, remote, + datagram_address[s].sa, rlen); + } + } + else + memcpy (datagram_address[s].sa, sa, addrlen); + } +#endif + + contact = Fplist_put (contact, p->is_server? QClocal: QCremote, + conv_sockaddr_to_lisp (sa, addrlen)); +#ifdef HAVE_GETSOCKNAME + if (!p->is_server) + { + struct sockaddr_in sa1; + socklen_t len1 = sizeof (sa1); + if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) + contact = Fplist_put (contact, QClocal, + conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1)); + } +#endif + } + + immediate_quit = 0; + + if (s < 0) + { + /* If non-blocking got this far - and failed - assume non-blocking is + not supported after all. This is probably a wrong assumption, but + the normal blocking calls to open-network-stream handles this error + better. */ + if (p->is_non_blocking_client) + return; + + report_file_errno ((p->is_server + ? "make server process failed" + : "make client process failed"), + contact, xerrno); + } + + inch = s; + outch = s; + + chan_process[inch] = proc; + + fcntl (inch, F_SETFL, O_NONBLOCK); + + p = XPROCESS (proc); + p->open_fd[SUBPROCESS_STDIN] = inch; + p->infd = inch; + p->outfd = outch; + + /* Discard the unwind protect for closing S, if any. */ + specpdl_ptr = specpdl + count; + + if (p->is_server && p->socktype != SOCK_DGRAM) + pset_status (p, Qlisten); + + /* Make the process marker point into the process buffer (if any). */ + if (BUFFERP (p->buffer)) + set_marker_both (p->mark, p->buffer, + BUF_ZV (XBUFFER (p->buffer)), + BUF_ZV_BYTE (XBUFFER (p->buffer))); + + if (p->is_non_blocking_client) + { + /* We may get here if connect did succeed immediately. However, + in that case, we still need to signal this like a non-blocking + connection. */ + if (! (connecting_status (p->status) + && EQ (XCDR (p->status), addrinfos))) + pset_status (p, Fcons (Qconnect, addrinfos)); + if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0) + add_non_blocking_write_fd (inch); + } + else + /* A server may have a client filter setting of Qt, but it must + still listen for incoming connects unless it is stopped. */ + if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) + || (EQ (p->status, Qlisten) && NILP (p->command))) + add_process_read_fd (inch); + + if (inch > max_desc) + max_desc = inch; + + /* Set up the masks based on the process filter. */ + set_process_filter_masks (p); + + setup_process_coding_systems (proc); + +#ifdef HAVE_GNUTLS + /* Continue the asynchronous connection. */ + if (!NILP (p->gnutls_boot_parameters)) + { + Lisp_Object boot, params = p->gnutls_boot_parameters; + + boot = Fgnutls_boot (proc, XCAR (params), XCDR (params)); + p->gnutls_boot_parameters = Qnil; + + if (p->gnutls_initstage == GNUTLS_STAGE_READY) + /* Run sentinels, etc. */ + finish_after_tls_connection (proc); + else if (p->gnutls_initstage != GNUTLS_STAGE_HANDSHAKE_TRIED) + { + deactivate_process (proc); + if (NILP (boot)) + pset_status (p, list2 (Qfailed, + build_string ("TLS negotiation failed"))); + else + pset_status (p, list2 (Qfailed, boot)); + } + } +#endif + +} + /* Create a network stream/datagram client/server process. Treated exactly like a normal process when reading and writing. Primary differences are in status display and process deletion. A network @@ -2953,9 +3667,8 @@ host, and only clients connecting to that address will be accepted. :service SERVICE -- SERVICE is name of the service desired, or an integer specifying a port number to connect to. If SERVICE is t, -a random port number is selected for the server. (If Emacs was -compiled with getaddrinfo, a port number can also be specified as a -string, e.g. "80", as well as an integer. This is not portable.) +a random port number is selected for the server. A port number can +be specified as an integer string, e.g., "80", as well as an integer. :type TYPE -- TYPE is the type of connection. The default (nil) is a stream type connection, `datagram' creates a datagram type connection, @@ -2996,11 +3709,12 @@ system used for both reading and writing for this process. If CODING is a cons (DECODING . ENCODING), DECODING is used for reading, and ENCODING is used for writing. -:nowait BOOL -- If BOOL is non-nil for a stream type client process, -return without waiting for the connection to complete; instead, the -sentinel function will be called with second arg matching "open" (if -successful) or "failed" when the connect completes. Default is to use -a blocking connect (i.e. wait) for stream type connections. +:nowait BOOL -- If NOWAIT is non-nil for a stream type client +process, return without waiting for the connection to complete; +instead, the sentinel function will be called with second arg matching +"open" (if successful) or "failed" when the connect completes. +Default is to use a blocking connect (i.e. wait) for stream type +connections. :noquery BOOL -- Query the user unless BOOL is non-nil, and process is running when Emacs is exited. @@ -3028,6 +3742,12 @@ and MESSAGE is a string. :plist PLIST -- Install PLIST as the new process's initial plist. +:tls-parameters LIST -- is a list that should be supplied if you're +opening a TLS connection. The first element is the TLS type (either +`gnutls-x509pki' or `gnutls-anon'), and the remaining elements should +be a keyword list accepted by gnutls-boot (as returned by +`gnutls-boot-parameters'). + :server QLEN -- if QLEN is non-nil, create a server process for the specified FAMILY, SERVICE, and connection type (stream or datagram). If QLEN is an integer, it is used as the max. length of the server's @@ -3046,6 +3766,11 @@ The following network options can be specified for this connection: (this is allowed by default for a server process). :bindtodevice NAME -- bind to interface NAME. Using this may require special privileges on some systems. +:use-external-socket BOOL -- Use any pre-allocated sockets that have + been passed to Emacs. If Emacs wasn't + passed a socket, this option is silently + ignored. + Consult the relevant system programmer's manual pages for more information on using these options. @@ -3081,41 +3806,24 @@ usage: (make-network-process &rest ARGS) */) Lisp_Object proc; Lisp_Object contact; struct Lisp_Process *p; -#ifdef HAVE_GETADDRINFO - struct addrinfo ai, *res, *lres; - struct addrinfo hints; const char *portstring; - char portbuf[128]; -#else /* HAVE_GETADDRINFO */ - struct _emacs_addrinfo - { - int ai_family; - int ai_socktype; - int ai_protocol; - int ai_addrlen; - struct sockaddr *ai_addr; - struct _emacs_addrinfo *ai_next; - } ai, *res, *lres; -#endif /* HAVE_GETADDRINFO */ - struct sockaddr_in address_in; + ptrdiff_t portstringlen ATTRIBUTE_UNUSED; + char portbuf[INT_BUFSIZE_BOUND (EMACS_INT)]; #ifdef HAVE_LOCAL_SOCKETS struct sockaddr_un address_un; #endif - int port; - int ret = 0; - int xerrno = 0; - int s = -1, outch, inch; - ptrdiff_t count = SPECPDL_INDEX (); - ptrdiff_t count1; - Lisp_Object colon_address; /* Either QClocal or QCremote. */ + EMACS_INT port = 0; Lisp_Object tem; Lisp_Object name, buffer, host, service, address; - Lisp_Object filter, sentinel; - bool is_non_blocking_client = 0; - bool is_server = 0; - int backlog = 5; + Lisp_Object filter, sentinel, use_external_socket_p; + Lisp_Object addrinfos = Qnil; int socktype; int family = -1; + enum { any_protocol = 0 }; +#ifdef HAVE_GETADDRINFO_A + struct gaicb *dns_request = NULL; +#endif + ptrdiff_t count = SPECPDL_INDEX (); if (nargs == 0) return Qnil; @@ -3143,55 +3851,28 @@ usage: (make-network-process &rest ARGS) */) else error ("Unsupported connection type"); - /* :server BOOL */ - tem = Fplist_get (contact, QCserver); - if (!NILP (tem)) - { - /* Don't support network sockets when non-blocking mode is - not available, since a blocked Emacs is not useful. */ - is_server = 1; - if (TYPE_RANGED_INTEGERP (int, tem)) - backlog = XINT (tem); - } - - /* Make colon_address an alias for :local (server) or :remote (client). */ - colon_address = is_server ? QClocal : QCremote; - - /* :nowait BOOL */ - if (!is_server && socktype != SOCK_DGRAM - && (tem = Fplist_get (contact, QCnowait), !NILP (tem))) - { -#ifndef NON_BLOCKING_CONNECT - error ("Non-blocking connect not supported"); -#else - is_non_blocking_client = 1; -#endif - } - name = Fplist_get (contact, QCname); buffer = Fplist_get (contact, QCbuffer); filter = Fplist_get (contact, QCfilter); sentinel = Fplist_get (contact, QCsentinel); + use_external_socket_p = Fplist_get (contact, QCuse_external_socket); CHECK_STRING (name); - /* Initialize addrinfo structure in case we don't use getaddrinfo. */ - ai.ai_socktype = socktype; - ai.ai_protocol = 0; - ai.ai_next = NULL; - res = &ai; - /* :local ADDRESS or :remote ADDRESS */ - address = Fplist_get (contact, colon_address); + tem = Fplist_get (contact, QCserver); + if (NILP (tem)) + address = Fplist_get (contact, QCremote); + else + address = Fplist_get (contact, QClocal); if (!NILP (address)) { host = service = Qnil; - if (!(ai.ai_addrlen = get_lisp_to_sockaddr_size (address, &family))) + if (!get_lisp_to_sockaddr_size (address, &family)) error ("Malformed :address"); - ai.ai_family = family; - ai.ai_addr = alloca (ai.ai_addrlen); - conv_lisp_to_sockaddr (family, address, ai.ai_addr, ai.ai_addrlen); + + addrinfos = list1 (Fcons (make_number (any_protocol), address)); goto open_socket; } @@ -3199,7 +3880,7 @@ usage: (make-network-process &rest ARGS) */) tem = Fplist_get (contact, QCfamily); if (NILP (tem)) { -#if defined (HAVE_GETADDRINFO) && defined (AF_INET6) +#ifdef AF_INET6 family = AF_UNSPEC; #else family = AF_INET; @@ -3220,14 +3901,21 @@ usage: (make-network-process &rest ARGS) */) else error ("Unknown address family"); - ai.ai_family = family; - /* :service SERVICE -- string, integer (port number), or t (random port). */ service = Fplist_get (contact, QCservice); /* :host HOST -- hostname, ip address, or 'local for localhost. */ host = Fplist_get (contact, QChost); - if (!NILP (host)) + if (NILP (host)) + { + /* The "connection" function gets it bind info from the address we're + given, so use this dummy address if nothing is specified. */ +#ifdef HAVE_LOCAL_SOCKETS + if (family != AF_LOCAL) +#endif + host = build_string ("127.0.0.1"); + } + else { if (EQ (host, Qlocal)) /* Depending on setup, "localhost" may map to different IPv4 and/or @@ -3246,13 +3934,9 @@ usage: (make-network-process &rest ARGS) */) host = Qnil; } CHECK_STRING (service); - memset (&address_un, 0, sizeof address_un); - address_un.sun_family = AF_LOCAL; if (sizeof address_un.sun_path <= SBYTES (service)) error ("Service name too long"); - lispstpcpy (address_un.sun_path, service); - ai.ai_addr = (struct sockaddr *) &address_un; - ai.ai_addrlen = sizeof address_un; + addrinfos = list1 (Fcons (make_number (any_protocol), service)); goto open_socket; } #endif @@ -3268,359 +3952,147 @@ usage: (make-network-process &rest ARGS) */) } #endif -#ifdef HAVE_GETADDRINFO - /* If we have a host, use getaddrinfo to resolve both host and service. - Otherwise, use getservbyname to lookup the service. */ if (!NILP (host)) { - /* SERVICE can either be a string or int. Convert to a C string for later use by getaddrinfo. */ if (EQ (service, Qt)) - portstring = "0"; + { + portstring = "0"; + portstringlen = 1; + } else if (INTEGERP (service)) { - sprintf (portbuf, "%"pI"d", XINT (service)); portstring = portbuf; + portstringlen = sprintf (portbuf, "%"pI"d", XINT (service)); } else { CHECK_STRING (service); portstring = SSDATA (service); + portstringlen = SBYTES (service); } + } - immediate_quit = 1; - QUIT; - memset (&hints, 0, sizeof (hints)); - hints.ai_flags = 0; - hints.ai_family = family; - hints.ai_socktype = socktype; - hints.ai_protocol = 0; - -#ifdef HAVE_RES_INIT - res_init (); -#endif - - ret = getaddrinfo (SSDATA (host), portstring, &hints, &res); +#ifdef HAVE_GETADDRINFO_A + if (!NILP (host) && !NILP (Fplist_get (contact, QCnowait))) + { + ptrdiff_t hostlen = SBYTES (host); + struct req + { + struct gaicb gaicb; + struct addrinfo hints; + char str[FLEXIBLE_ARRAY_MEMBER]; + } *req = xmalloc (FLEXSIZEOF (struct req, str, + hostlen + 1 + portstringlen + 1)); + dns_request = &req->gaicb; + dns_request->ar_name = req->str; + dns_request->ar_service = req->str + hostlen + 1; + dns_request->ar_request = &req->hints; + dns_request->ar_result = NULL; + memset (&req->hints, 0, sizeof req->hints); + req->hints.ai_family = family; + req->hints.ai_socktype = socktype; + strcpy (req->str, SSDATA (host)); + strcpy (req->str + hostlen + 1, portstring); + + int ret = getaddrinfo_a (GAI_NOWAIT, &dns_request, 1, NULL); if (ret) -#ifdef HAVE_GAI_STRERROR - error ("%s/%s %s", SSDATA (host), portstring, gai_strerror (ret)); -#else - error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret); -#endif - immediate_quit = 0; + error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret); goto open_socket; } -#endif /* HAVE_GETADDRINFO */ +#endif /* HAVE_GETADDRINFO_A */ - /* We end up here if getaddrinfo is not defined, or in case no hostname - has been specified (e.g. for a local server process). */ - - if (EQ (service, Qt)) - port = 0; - else if (INTEGERP (service)) - port = htons ((unsigned short) XINT (service)); - else - { - struct servent *svc_info; - CHECK_STRING (service); - svc_info = getservbyname (SSDATA (service), - (socktype == SOCK_DGRAM ? "udp" : "tcp")); - if (svc_info == 0) - error ("Unknown service: %s", SDATA (service)); - port = svc_info->s_port; - } - - memset (&address_in, 0, sizeof address_in); - address_in.sin_family = family; - address_in.sin_addr.s_addr = INADDR_ANY; - address_in.sin_port = port; + /* If we have a host, use getaddrinfo to resolve both host and service. + Otherwise, use getservbyname to lookup the service. */ -#ifndef HAVE_GETADDRINFO if (!NILP (host)) { - struct hostent *host_info_ptr; - - /* gethostbyname may fail with TRY_AGAIN, but we don't honor that, - as it may `hang' Emacs for a very long time. */ - immediate_quit = 1; - QUIT; - -#ifdef HAVE_RES_INIT - res_init (); -#endif - - host_info_ptr = gethostbyname (SDATA (host)); - immediate_quit = 0; - - if (host_info_ptr) - { - memcpy (&address_in.sin_addr, host_info_ptr->h_addr, - host_info_ptr->h_length); - family = host_info_ptr->h_addrtype; - address_in.sin_family = family; - } - else - /* Attempt to interpret host as numeric inet address. */ - { - unsigned long numeric_addr; - numeric_addr = inet_addr (SSDATA (host)); - if (numeric_addr == -1) - error ("Unknown host \"%s\"", SDATA (host)); - - memcpy (&address_in.sin_addr, &numeric_addr, - sizeof (address_in.sin_addr)); - } - - } -#endif /* not HAVE_GETADDRINFO */ - - ai.ai_family = family; - ai.ai_addr = (struct sockaddr *) &address_in; - ai.ai_addrlen = sizeof address_in; - - open_socket: - - /* Do this in case we never enter the for-loop below. */ - count1 = SPECPDL_INDEX (); - s = -1; - - for (lres = res; lres; lres = lres->ai_next) - { - ptrdiff_t optn; - int optbits; - -#ifdef WINDOWSNT - retry_connect: -#endif - - s = socket (lres->ai_family, lres->ai_socktype | SOCK_CLOEXEC, - lres->ai_protocol); - if (s < 0) - { - xerrno = errno; - continue; - } - -#ifdef DATAGRAM_SOCKETS - if (!is_server && socktype == SOCK_DGRAM) - break; -#endif /* DATAGRAM_SOCKETS */ - -#ifdef NON_BLOCKING_CONNECT - if (is_non_blocking_client) - { - ret = fcntl (s, F_SETFL, O_NONBLOCK); - if (ret < 0) - { - xerrno = errno; - emacs_close (s); - s = -1; - continue; - } - } -#endif - - /* Make us close S if quit. */ - record_unwind_protect_int (close_file_unwind, s); - - /* Parse network options in the arg list. - We simply ignore anything which isn't a known option (including other keywords). - An error is signaled if setting a known option fails. */ - for (optn = optbits = 0; optn < nargs - 1; optn += 2) - optbits |= set_socket_option (s, args[optn], args[optn + 1]); - - if (is_server) - { - /* Configure as a server socket. */ - - /* SO_REUSEADDR = 1 is default for server sockets; must specify - explicit :reuseaddr key to override this. */ -#ifdef HAVE_LOCAL_SOCKETS - if (family != AF_LOCAL) -#endif - if (!(optbits & (1 << OPIX_REUSEADDR))) - { - int optval = 1; - if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval)) - report_file_error ("Cannot set reuse option on server socket", Qnil); - } - - if (bind (s, lres->ai_addr, lres->ai_addrlen)) - report_file_error ("Cannot bind server socket", Qnil); - -#ifdef HAVE_GETSOCKNAME - if (EQ (service, Qt)) - { - struct sockaddr_in sa1; - socklen_t len1 = sizeof (sa1); - if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) - { - ((struct sockaddr_in *)(lres->ai_addr))->sin_port = sa1.sin_port; - service = make_number (ntohs (sa1.sin_port)); - contact = Fplist_put (contact, QCservice, service); - } - } -#endif - - if (socktype != SOCK_DGRAM && listen (s, backlog)) - report_file_error ("Cannot listen on server socket", Qnil); - - break; - } + struct addrinfo *res, *lres; + int ret; immediate_quit = 1; QUIT; - ret = connect (s, lres->ai_addr, lres->ai_addrlen); - xerrno = errno; + struct addrinfo hints; + memset (&hints, 0, sizeof hints); + hints.ai_family = family; + hints.ai_socktype = socktype; - if (ret == 0 || xerrno == EISCONN) + ret = getaddrinfo (SSDATA (host), portstring, &hints, &res); + if (ret) +#ifdef HAVE_GAI_STRERROR { - /* The unwind-protect will be discarded afterwards. - Likewise for immediate_quit. */ - break; + synchronize_system_messages_locale (); + char const *str = gai_strerror (ret); + if (! NILP (Vlocale_coding_system)) + str = SSDATA (code_convert_string_norecord + (build_string (str), Vlocale_coding_system, 0)); + error ("%s/%s %s", SSDATA (host), portstring, str); } - -#ifdef NON_BLOCKING_CONNECT -#ifdef EINPROGRESS - if (is_non_blocking_client && xerrno == EINPROGRESS) - break; #else -#ifdef EWOULDBLOCK - if (is_non_blocking_client && xerrno == EWOULDBLOCK) - break; -#endif -#endif + error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret); #endif + immediate_quit = 0; -#ifndef WINDOWSNT - if (xerrno == EINTR) - { - /* Unlike most other syscalls connect() cannot be called - again. (That would return EALREADY.) The proper way to - wait for completion is pselect(). */ - int sc; - socklen_t len; - fd_set fdset; - retry_select: - FD_ZERO (&fdset); - FD_SET (s, &fdset); - QUIT; - sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL); - if (sc == -1) - { - if (errno == EINTR) - goto retry_select; - else - report_file_error ("Failed select", Qnil); - } - eassert (sc > 0); - - len = sizeof xerrno; - eassert (FD_ISSET (s, &fdset)); - if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) < 0) - report_file_error ("Failed getsockopt", Qnil); - if (xerrno) - report_file_errno ("Failed connect", Qnil, xerrno); - break; - } -#endif /* !WINDOWSNT */ + for (lres = res; lres; lres = lres->ai_next) + addrinfos = Fcons (conv_addrinfo_to_lisp (lres), addrinfos); - immediate_quit = 0; + addrinfos = Fnreverse (addrinfos); - /* Discard the unwind protect closing S. */ - specpdl_ptr = specpdl + count1; - emacs_close (s); - s = -1; + freeaddrinfo (res); -#ifdef WINDOWSNT - if (xerrno == EINTR) - goto retry_connect; -#endif + goto open_socket; } - if (s >= 0) + /* No hostname has been specified (e.g., a local server process). */ + + if (EQ (service, Qt)) + port = 0; + else if (INTEGERP (service)) + port = XINT (service); + else { -#ifdef DATAGRAM_SOCKETS - if (socktype == SOCK_DGRAM) + CHECK_STRING (service); + + port = -1; + if (SBYTES (service) != 0) { - if (datagram_address[s].sa) - emacs_abort (); - datagram_address[s].sa = xmalloc (lres->ai_addrlen); - datagram_address[s].len = lres->ai_addrlen; - if (is_server) + /* Allow the service to be a string containing the port number, + because that's allowed if you have getaddrbyname. */ + char *service_end; + long int lport = strtol (SSDATA (service), &service_end, 10); + if (service_end == SSDATA (service) + SBYTES (service)) + port = lport; + else { - Lisp_Object remote; - memset (datagram_address[s].sa, 0, lres->ai_addrlen); - if (remote = Fplist_get (contact, QCremote), !NILP (remote)) - { - int rfamily, rlen; - rlen = get_lisp_to_sockaddr_size (remote, &rfamily); - if (rlen != 0 && rfamily == lres->ai_family - && rlen == lres->ai_addrlen) - conv_lisp_to_sockaddr (rfamily, remote, - datagram_address[s].sa, rlen); - } + struct servent *svc_info + = getservbyname (SSDATA (service), + socktype == SOCK_DGRAM ? "udp" : "tcp"); + if (svc_info) + port = ntohs (svc_info->s_port); } - else - memcpy (datagram_address[s].sa, lres->ai_addr, lres->ai_addrlen); - } -#endif - contact = Fplist_put (contact, colon_address, - conv_sockaddr_to_lisp (lres->ai_addr, lres->ai_addrlen)); -#ifdef HAVE_GETSOCKNAME - if (!is_server) - { - struct sockaddr_in sa1; - socklen_t len1 = sizeof (sa1); - if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) - contact = Fplist_put (contact, QClocal, - conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1)); } -#endif - } - - immediate_quit = 0; - -#ifdef HAVE_GETADDRINFO - if (res != &ai) - { - block_input (); - freeaddrinfo (res); - unblock_input (); } -#endif - if (s < 0) + if (! (0 <= port && port < 1 << 16)) { - /* If non-blocking got this far - and failed - assume non-blocking is - not supported after all. This is probably a wrong assumption, but - the normal blocking calls to open-network-stream handles this error - better. */ - if (is_non_blocking_client) - return Qnil; - - report_file_errno ((is_server - ? "make server process failed" - : "make client process failed"), - contact, xerrno); + AUTO_STRING (unknown_service, "Unknown service: %s"); + xsignal1 (Qerror, CALLN (Fformat, unknown_service, service)); } - inch = s; - outch = s; + open_socket: if (!NILP (buffer)) buffer = Fget_buffer_create (buffer); - proc = make_process (name); - chan_process[inch] = proc; - - fcntl (inch, F_SETFL, O_NONBLOCK); + /* Unwind bind_polling_period. */ + unbind_to (count, Qnil); + proc = make_process (name); + record_unwind_protect (remove_process, proc); p = XPROCESS (proc); - pset_childp (p, contact); pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist))); pset_type (p, Qnetwork); @@ -3633,136 +4105,54 @@ usage: (make-network-process &rest ARGS) */) p->kill_without_query = 1; if ((tem = Fplist_get (contact, QCstop), !NILP (tem))) pset_command (p, Qt); - p->pid = 0; - - p->open_fd[SUBPROCESS_STDIN] = inch; - p->infd = inch; - p->outfd = outch; - - /* Discard the unwind protect for closing S, if any. */ - specpdl_ptr = specpdl + count1; - - /* Unwind bind_polling_period and request_sigio. */ - unbind_to (count, Qnil); + eassert (p->pid == 0); + p->backlog = 5; + eassert (! p->is_non_blocking_client); + eassert (! p->is_server); + p->port = port; + p->socktype = socktype; +#ifdef HAVE_GETADDRINFO_A + eassert (! p->dns_request); +#endif +#ifdef HAVE_GNUTLS + tem = Fplist_get (contact, QCtls_parameters); + CHECK_LIST (tem); + p->gnutls_boot_parameters = tem; +#endif - if (is_server && socktype != SOCK_DGRAM) - pset_status (p, Qlisten); + set_network_socket_coding_system (proc, host, service, name); - /* Make the process marker point into the process buffer (if any). */ - if (BUFFERP (buffer)) - set_marker_both (p->mark, buffer, - BUF_ZV (XBUFFER (buffer)), - BUF_ZV_BYTE (XBUFFER (buffer))); + /* :server BOOL */ + tem = Fplist_get (contact, QCserver); + if (!NILP (tem)) + { + /* Don't support network sockets when non-blocking mode is + not available, since a blocked Emacs is not useful. */ + p->is_server = true; + if (TYPE_RANGED_INTEGERP (int, tem)) + p->backlog = XINT (tem); + } -#ifdef NON_BLOCKING_CONNECT - if (is_non_blocking_client) + /* :nowait BOOL */ + if (!p->is_server && socktype != SOCK_DGRAM + && !NILP (Fplist_get (contact, QCnowait))) + p->is_non_blocking_client = true; + + bool postpone_connection = false; +#ifdef HAVE_GETADDRINFO_A + /* With async address resolution, the list of addresses is empty, so + postpone connecting to the server. */ + if (!p->is_server && NILP (addrinfos)) { - /* We may get here if connect did succeed immediately. However, - in that case, we still need to signal this like a non-blocking - connection. */ - pset_status (p, Qconnect); - if (!FD_ISSET (inch, &connect_wait_mask)) - { - FD_SET (inch, &connect_wait_mask); - FD_SET (inch, &write_mask); - num_pending_connects++; - } + p->dns_request = dns_request; + p->status = list1 (Qconnect); + postpone_connection = true; } - else #endif - /* A server may have a client filter setting of Qt, but it must - still listen for incoming connects unless it is stopped. */ - if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) - || (EQ (p->status, Qlisten) && NILP (p->command))) - { - FD_SET (inch, &input_wait_mask); - FD_SET (inch, &non_keyboard_wait_mask); - } - - if (inch > max_process_desc) - max_process_desc = inch; - - tem = Fplist_member (contact, QCcoding); - if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) - tem = Qnil; /* No error message (too late!). */ - - { - /* Setup coding systems for communicating with the network stream. */ - /* Qt denotes we have not yet called Ffind_operation_coding_system. */ - Lisp_Object coding_systems = Qt; - Lisp_Object val; - - if (!NILP (tem)) - { - val = XCAR (XCDR (tem)); - if (CONSP (val)) - val = XCAR (val); - } - else if (!NILP (Vcoding_system_for_read)) - val = Vcoding_system_for_read; - else if ((!NILP (buffer) && NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters))) - || (NILP (buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters)))) - /* We dare not decode end-of-line format by setting VAL to - Qraw_text, because the existing Emacs Lisp libraries - assume that they receive bare code including a sequence of - CR LF. */ - val = Qnil; - else - { - if (NILP (host) || NILP (service)) - coding_systems = Qnil; - else - coding_systems = CALLN (Ffind_operation_coding_system, - Qopen_network_stream, name, buffer, - host, service); - if (CONSP (coding_systems)) - val = XCAR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCAR (Vdefault_process_coding_system); - else - val = Qnil; - } - pset_decode_coding_system (p, val); - - if (!NILP (tem)) - { - val = XCAR (XCDR (tem)); - if (CONSP (val)) - val = XCDR (val); - } - else if (!NILP (Vcoding_system_for_write)) - val = Vcoding_system_for_write; - else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - val = Qnil; - else - { - if (EQ (coding_systems, Qt)) - { - if (NILP (host) || NILP (service)) - coding_systems = Qnil; - else - coding_systems = CALLN (Ffind_operation_coding_system, - Qopen_network_stream, name, buffer, - host, service); - } - if (CONSP (coding_systems)) - val = XCDR (coding_systems); - else if (CONSP (Vdefault_process_coding_system)) - val = XCDR (Vdefault_process_coding_system); - else - val = Qnil; - } - pset_encode_coding_system (p, val); - } - setup_process_coding_systems (proc); - - pset_decoding_buf (p, empty_unibyte_string); - p->decoding_carryover = 0; - pset_encoding_buf (p, empty_unibyte_string); - - p->inherit_coding_system_flag - = !(!NILP (tem) || NILP (buffer) || !inherit_process_coding_system); + if (! postpone_connection) + connect_network_socket (proc, addrinfos, use_external_socket_p); + specpdl_ptr = specpdl + count; return proc; } @@ -4140,28 +4530,11 @@ deactivate_process (Lisp_Object proc) } #endif chan_process[inchannel] = Qnil; - FD_CLR (inchannel, &input_wait_mask); - FD_CLR (inchannel, &non_keyboard_wait_mask); -#ifdef NON_BLOCKING_CONNECT - if (FD_ISSET (inchannel, &connect_wait_mask)) - { - FD_CLR (inchannel, &connect_wait_mask); - FD_CLR (inchannel, &write_mask); - if (--num_pending_connects < 0) - emacs_abort (); - } -#endif - if (inchannel == max_process_desc) - { - /* We just closed the highest-numbered process input descriptor, - so recompute the highest-numbered one now. */ - int i = inchannel; - do - i--; - while (0 <= i && NILP (chan_process[i])); - - max_process_desc = i; - } + delete_read_fd (inchannel); + if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0) + delete_write_fd (inchannel); + if (inchannel == max_desc) + recompute_max_desc (); } } @@ -4184,13 +4557,23 @@ from PROCESS only, suspending reading output from other processes. If JUST-THIS-ONE is an integer, don't run any timers either. Return non-nil if we received any output from PROCESS (or, if PROCESS is nil, from any process) before the timeout expired. */) - (register Lisp_Object process, Lisp_Object seconds, Lisp_Object millisec, Lisp_Object just_this_one) + (Lisp_Object process, Lisp_Object seconds, Lisp_Object millisec, + Lisp_Object just_this_one) { intmax_t secs; int nsecs; if (! NILP (process)) - CHECK_PROCESS (process); + { + CHECK_PROCESS (process); + struct Lisp_Process *proc = XPROCESS (process); + + /* Can't wait for a process that is dedicated to a different + thread. */ + if (!EQ (proc->thread, Qnil) && !EQ (proc->thread, Fcurrent_thread ())) + error ("Attempt to accept output from process %s locked to thread %s", + SDATA (proc->name), SDATA (XTHREAD (proc->thread)->name)); + } else just_this_one = Qnil; @@ -4395,8 +4778,8 @@ server_accept_connection (Lisp_Object server, int channel) pset_buffer (p, buffer); pset_sentinel (p, ps->sentinel); pset_filter (p, ps->filter); - pset_command (p, Qnil); - p->pid = 0; + eassert (NILP (p->command)); + eassert (p->pid == 0); /* Discard the unwind protect for closing S. */ specpdl_ptr = specpdl + count; @@ -4408,13 +4791,9 @@ server_accept_connection (Lisp_Object server, int channel) /* Client processes for accepted connections are not stopped initially. */ if (!EQ (p->filter, Qt)) - { - FD_SET (s, &input_wait_mask); - FD_SET (s, &non_keyboard_wait_mask); - } - - if (s > max_process_desc) - max_process_desc = s; + add_process_read_fd (s); + if (s > max_desc) + max_desc = s; /* Setup coding system for new process based on server process. This seems to be the proper thing to do, as the coding system @@ -4426,7 +4805,7 @@ server_accept_connection (Lisp_Object server, int channel) setup_process_coding_systems (proc); pset_decoding_buf (p, empty_unibyte_string); - p->decoding_carryover = 0; + eassert (p->decoding_carryover == 0); pset_encoding_buf (p, empty_unibyte_string); p->inherit_coding_system_flag @@ -4446,20 +4825,91 @@ server_accept_connection (Lisp_Object server, int channel) exec_sentinel (proc, concat3 (open_from, host_string, nl)); } -/* This variable is different from waiting_for_input in keyboard.c. - It is used to communicate to a lisp process-filter/sentinel (via the - function Fwaiting_for_user_input_p below) whether Emacs was waiting - for user-input when that process-filter was called. - waiting_for_input cannot be used as that is by definition 0 when - lisp code is being evalled. - This is also used in record_asynch_buffer_change. - For that purpose, this must be 0 - when not inside wait_reading_process_output. */ -static int waiting_for_user_input_p; +#ifdef HAVE_GETADDRINFO_A +static Lisp_Object +check_for_dns (Lisp_Object proc) +{ + struct Lisp_Process *p = XPROCESS (proc); + Lisp_Object addrinfos = Qnil; + + /* Sanity check. */ + if (! p->dns_request) + return Qnil; + + int ret = gai_error (p->dns_request); + if (ret == EAI_INPROGRESS) + return Qt; + + /* We got a response. */ + if (ret == 0) + { + struct addrinfo *res; + + for (res = p->dns_request->ar_result; res; res = res->ai_next) + addrinfos = Fcons (conv_addrinfo_to_lisp (res), addrinfos); + + addrinfos = Fnreverse (addrinfos); + } + /* The DNS lookup failed. */ + else if (connecting_status (p->status)) + { + deactivate_process (proc); + pset_status (p, (list2 + (Qfailed, + concat3 (build_string ("Name lookup of "), + build_string (p->dns_request->ar_name), + build_string (" failed"))))); + } + + free_dns_request (proc); + + /* This process should not already be connected (or killed). */ + if (! connecting_status (p->status)) + return Qnil; + + return addrinfos; +} + +#endif /* HAVE_GETADDRINFO_A */ + +static void +wait_for_socket_fds (Lisp_Object process, char const *name) +{ + while (XPROCESS (process)->infd < 0 + && connecting_status (XPROCESS (process)->status)) + { + add_to_log ("Waiting for socket from %s...", build_string (name)); + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } +} + +static void +wait_while_connecting (Lisp_Object process) +{ + while (connecting_status (XPROCESS (process)->status)) + { + add_to_log ("Waiting for connection..."); + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } +} + +static void +wait_for_tls_negotiation (Lisp_Object process) +{ +#ifdef HAVE_GNUTLS + while (XPROCESS (process)->gnutls_p + && XPROCESS (process)->gnutls_initstage != GNUTLS_STAGE_READY) + { + add_to_log ("Waiting for TLS..."); + wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); + } +#endif +} static void wait_reading_process_output_unwind (int data) { + clear_waiting_thread_info (); waiting_for_user_input_p = data; } @@ -4486,8 +4936,8 @@ wait_reading_process_output_1 (void) READ_KBD is: 0 to ignore keyboard input, or 1 to return when input is available, or - -1 meaning caller will actually read the input, so don't throw to - the quit handler, or + -1 meaning caller will actually read the input, so don't throw to + the quit handler DO_DISPLAY means redisplay should be done to show subprocess output that arrives. @@ -4524,11 +4974,18 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, struct timespec got_output_end_time = invalid_timespec (); enum { MINIMUM = -1, TIMEOUT, INFINITY } wait; int got_some_output = -1; +#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS + bool retry_for_async; +#endif ptrdiff_t count = SPECPDL_INDEX (); /* Close to the current time if known, an invalid timespec otherwise. */ struct timespec now = invalid_timespec (); + eassert (wait_proc == NULL + || EQ (wait_proc->thread, Qnil) + || XTHREAD (wait_proc->thread) == current_thread); + FD_ZERO (&Available); FD_ZERO (&Writeok); @@ -4571,6 +5028,60 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; +#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS + { + Lisp_Object process_list_head, aproc; + struct Lisp_Process *p; + + retry_for_async = false; + FOR_EACH_PROCESS(process_list_head, aproc) + { + p = XPROCESS (aproc); + + if (! wait_proc || p == wait_proc) + { +#ifdef HAVE_GETADDRINFO_A + /* Check for pending DNS requests. */ + if (p->dns_request) + { + Lisp_Object addrinfos = check_for_dns (aproc); + if (!NILP (addrinfos) && !EQ (addrinfos, Qt)) + connect_network_socket (aproc, addrinfos, Qnil); + else + retry_for_async = true; + } +#endif +#ifdef HAVE_GNUTLS + /* Continue TLS negotiation. */ + if (p->gnutls_initstage == GNUTLS_STAGE_HANDSHAKE_TRIED + && p->is_non_blocking_client) + { + gnutls_try_handshake (p); + p->gnutls_handshakes_tried++; + + if (p->gnutls_initstage == GNUTLS_STAGE_READY) + { + gnutls_verify_boot (aproc, Qnil); + finish_after_tls_connection (aproc); + } + else + { + retry_for_async = true; + if (p->gnutls_handshakes_tried + > GNUTLS_EMACS_HANDSHAKES_LIMIT) + { + deactivate_process (aproc); + pset_status (p, list2 (Qfailed, + build_string ("TLS negotiation failed"))); + } + } + } +#endif + } + } + } +#endif /* GETADDRINFO_A or GNUTLS */ + /* Compute time from now till when time limit is up. */ /* Exit if already run out. */ if (wait == TIMEOUT) @@ -4647,18 +5158,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (kbd_on_hold_p ()) FD_ZERO (&Atemp); else - Atemp = input_wait_mask; - Ctemp = write_mask; + compute_input_wait_mask (&Atemp); + compute_write_mask (&Ctemp); timeout = make_timespec (0, 0); - if ((pselect (max (max_process_desc, max_input_desc) + 1, - &Atemp, -#ifdef NON_BLOCKING_CONNECT - (num_pending_connects > 0 ? &Ctemp : NULL), -#else - NULL, -#endif - NULL, &timeout, NULL) + if ((thread_select (pselect, max_desc + 1, + &Atemp, + (num_pending_connects > 0 ? &Ctemp : NULL), + NULL, &timeout, NULL) <= 0)) { /* It's okay for us to do this and then continue with @@ -4675,7 +5182,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, update_status (wait_proc); if (wait_proc && ! EQ (wait_proc->status, Qrun) - && ! EQ (wait_proc->status, Qconnect)) + && ! connecting_status (wait_proc->status)) { bool read_some_bytes = false; @@ -4723,17 +5230,17 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else if (!NILP (wait_for_cell)) { - Available = non_process_wait_mask; + compute_non_process_wait_mask (&Available); check_delay = 0; check_write = 0; } else { if (! read_kbd) - Available = non_keyboard_wait_mask; + compute_non_keyboard_wait_mask (&Available); else - Available = input_wait_mask; - Writeok = write_mask; + compute_input_wait_mask (&Available); + compute_write_mask (&Writeok); check_delay = wait_proc ? 0 : process_output_delay_count; check_write = true; } @@ -4775,7 +5282,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, int adaptive_nsecs = timeout.tv_nsec; if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX) adaptive_nsecs = READ_OUTPUT_DELAY_MAX; - for (channel = 0; check_delay > 0 && channel <= max_process_desc; channel++) + for (channel = 0; check_delay > 0 && channel <= max_desc; channel++) { proc = chan_process[channel]; if (NILP (proc)) @@ -4825,17 +5332,32 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (timeout.tv_sec > 0 || timeout.tv_nsec > 0) now = invalid_timespec (); -#if defined (HAVE_NS) - nfds = ns_select -#elif defined (HAVE_GLIB) - nfds = xg_select -#else - nfds = pselect +#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS + if (retry_for_async + && (timeout.tv_sec > 0 || timeout.tv_nsec > ASYNC_RETRY_NSEC)) + { + timeout.tv_sec = 0; + timeout.tv_nsec = ASYNC_RETRY_NSEC; + } #endif - (max (max_process_desc, max_input_desc) + 1, - &Available, - (check_write ? &Writeok : 0), - NULL, &timeout, NULL); + +/* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */ +#if defined HAVE_GLIB && !defined HAVE_NS + nfds = xg_select (max_desc + 1, + &Available, (check_write ? &Writeok : 0), + NULL, &timeout, NULL); +#else /* !HAVE_GLIB */ + nfds = thread_select ( +# ifdef HAVE_NS + ns_select +# else + pselect +# endif + , max_desc + 1, + &Available, + (check_write ? &Writeok : 0), + NULL, &timeout, NULL); +#endif /* !HAVE_GLIB */ #ifdef HAVE_GNUTLS /* GnuTLS buffers data internally. In lowat mode it leaves @@ -5019,22 +5541,22 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (no_avail || nfds == 0) continue; - for (channel = 0; channel <= max_input_desc; ++channel) + for (channel = 0; channel <= max_desc; ++channel) { struct fd_callback_data *d = &fd_callback_info[channel]; if (d->func - && ((d->condition & FOR_READ + && ((d->flags & FOR_READ && FD_ISSET (channel, &Available)) - || (d->condition & FOR_WRITE - && FD_ISSET (channel, &write_mask)))) + || ((d->flags & FOR_WRITE) + && FD_ISSET (channel, &Writeok)))) d->func (channel, d->data); } - for (channel = 0; channel <= max_process_desc; channel++) + for (channel = 0; channel <= max_desc; channel++) { if (FD_ISSET (channel, &Available) - && FD_ISSET (channel, &non_keyboard_wait_mask) - && !FD_ISSET (channel, &non_process_wait_mask)) + && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD)) + == PROCESS_FD)) { int nread; @@ -5099,8 +5621,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, /* Clear the descriptor now, so we only raise the signal once. */ - FD_CLR (channel, &input_wait_mask); - FD_CLR (channel, &non_keyboard_wait_mask); + delete_read_fd (channel); if (p->pid == -2) { @@ -5138,16 +5659,13 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, list2 (Qexit, make_number (256))); } } -#ifdef NON_BLOCKING_CONNECT if (FD_ISSET (channel, &Writeok) - && FD_ISSET (channel, &connect_wait_mask)) + && (fd_callback_info[channel].flags + & NON_BLOCKING_CONNECT_FD) != 0) { struct Lisp_Process *p; - FD_CLR (channel, &connect_wait_mask); - FD_CLR (channel, &write_mask); - if (--num_pending_connects < 0) - emacs_abort (); + delete_write_fd (channel); proc = chan_process[channel]; if (NILP (proc)) @@ -5155,15 +5673,16 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, p = XPROCESS (proc); -#ifdef GNU_LINUX - /* getsockopt(,,SO_ERROR,,) is said to hang on some systems. - So only use it on systems where it is known to work. */ +#ifndef WINDOWSNT { socklen_t xlen = sizeof (xerrno); if (getsockopt (channel, SOL_SOCKET, SO_ERROR, &xerrno, &xlen)) xerrno = errno; } #else + /* On MS-Windows, getsockopt clears the error for the + entire process, which may not be the right thing; see + w32.c. Use getpeername instead. */ { struct sockaddr pname; socklen_t pnamelen = sizeof (pname); @@ -5182,26 +5701,41 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, #endif if (xerrno) { - p->tick = ++process_tick; - pset_status (p, list2 (Qfailed, make_number (xerrno))); + Lisp_Object addrinfos + = connecting_status (p->status) ? XCDR (p->status) : Qnil; + if (!NILP (addrinfos)) + XSETCDR (p->status, XCDR (addrinfos)); + else + { + p->tick = ++process_tick; + pset_status (p, list2 (Qfailed, make_number (xerrno))); + } deactivate_process (proc); + if (!NILP (addrinfos)) + connect_network_socket (proc, addrinfos, Qnil); } else { - pset_status (p, Qrun); - /* Execute the sentinel here. If we had relied on - status_notify to do it later, it will read input - from the process before calling the sentinel. */ - exec_sentinel (proc, build_string ("open\n")); - if (0 <= p->infd && !EQ (p->filter, Qt) - && !EQ (p->command, Qt)) +#ifdef HAVE_GNUTLS + /* If we have an incompletely set up TLS connection, + then defer the sentinel signaling until + later. */ + if (NILP (p->gnutls_boot_parameters) + && !p->gnutls_p) +#endif { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); + pset_status (p, Qrun); + /* Execute the sentinel here. If we had relied on + status_notify to do it later, it will read input + from the process before calling the sentinel. */ + exec_sentinel (proc, build_string ("open\n")); } + + if (0 <= p->infd && !EQ (p->filter, Qt) + && !EQ (p->command, Qt)) + add_process_read_fd (p->infd); } } -#endif /* NON_BLOCKING_CONNECT */ } /* End for each file descriptor. */ } /* End while exit conditions not met. */ @@ -5649,6 +6183,12 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, ssize_t rv; struct coding_system *coding; + if (NETCONN_P (proc)) + { + wait_while_connecting (proc); + wait_for_tls_negotiation (proc); + } + if (p->raw_status_new) update_status (p); if (! EQ (p->status, Qrun)) @@ -5862,7 +6402,10 @@ nil, indicating the current buffer's process. Called from program, takes three arguments, PROCESS, START and END. If the region is more than 500 characters long, it is sent in several bunches. This may happen even for shorter regions. -Output from processes can arrive in between bunches. */) +Output from processes can arrive in between bunches. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object start, Lisp_Object end) { Lisp_Object proc = get_process (process); @@ -5876,6 +6419,9 @@ Output from processes can arrive in between bunches. */) if (XINT (start) < GPT && XINT (end) > GPT) move_gap_both (XINT (start), start_byte); + if (NETCONN_P (proc)) + wait_while_connecting (proc); + send_process (proc, (char *) BYTE_POS_ADDR (start_byte), end_byte - start_byte, Fcurrent_buffer ()); @@ -5889,12 +6435,14 @@ PROCESS may be a process, a buffer, the name of a process or buffer, or nil, indicating the current buffer's process. If STRING is more than 500 characters long, it is sent in several bunches. This may happen even for shorter strings. -Output from processes can arrive in between bunches. */) +Output from processes can arrive in between bunches. + +If PROCESS is a non-blocking network process that hasn't been fully +set up yet, this function will block until socket setup has completed. */) (Lisp_Object process, Lisp_Object string) { - Lisp_Object proc; CHECK_STRING (string); - proc = get_process (process); + Lisp_Object proc = get_process (process); send_process (proc, SSDATA (string), SBYTES (string), string); return Qnil; @@ -5936,12 +6484,8 @@ process group. */) { /* Initialize in case ioctl doesn't exist or gives an error, in a way that will cause returning t. */ - pid_t gid; - Lisp_Object proc; - struct Lisp_Process *p; - - proc = get_process (process); - p = XPROCESS (proc); + Lisp_Object proc = get_process (process); + struct Lisp_Process *p = XPROCESS (proc); if (!EQ (p->type, Qreal)) error ("Process %s is not a subprocess", @@ -5950,7 +6494,7 @@ process group. */) error ("Process %s is not active", SDATA (p->name)); - gid = emacs_get_tty_pgrp (p); + pid_t gid = emacs_get_tty_pgrp (p); if (gid == p->pid) return Qnil; @@ -6021,7 +6565,7 @@ process_send_signal (Lisp_Object process, int signo, Lisp_Object current_group, break; case SIGTSTP: -#if defined (VSWTCH) && !defined (PREFER_VSUSP) +#ifdef VSWTCH sig_char = &t.c_cc[VSWTCH]; #else sig_char = &t.c_cc[VSUSP]; @@ -6160,10 +6704,7 @@ of incoming traffic. */) p = XPROCESS (process); if (NILP (p->command) && p->infd >= 0) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); pset_command (p, Qt); return process; } @@ -6192,8 +6733,7 @@ traffic. */) && p->infd >= 0 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); + add_process_read_fd (p->infd); #ifdef WINDOWSNT if (fd_info[ p->infd ].flags & FILE_SERIAL) PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR); @@ -6309,10 +6849,15 @@ process has been transmitted to the serial port. */) struct coding_system *coding = NULL; int outfd; - if (DATAGRAM_CONN_P (process)) + proc = get_process (process); + + if (NETCONN_P (proc)) + wait_while_connecting (proc); + + if (DATAGRAM_CONN_P (proc)) return process; - proc = get_process (process); + outfd = XPROCESS (proc)->outfd; if (outfd >= 0) coding = proc_encode_coding_system[outfd]; @@ -6495,10 +7040,7 @@ handle_child_signal (int sig) /* clear_desc_flag avoids a compiler bug in Microsoft C. */ if (clear_desc_flag) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); } } } @@ -6637,7 +7179,7 @@ status_notify (struct Lisp_Process *deleting_process, /* If process is still active, read any output that remains. */ while (! EQ (p->filter, Qt) - && ! EQ (p->status, Qconnect) + && ! connecting_status (p->status) && ! EQ (p->status, Qlisten) /* Network or serial process not stopped: */ && ! EQ (p->command, Qt) @@ -6757,22 +7299,24 @@ DEFUN ("set-process-coding-system", Fset_process_coding_system, Sset_process_coding_system, 1, 3, 0, doc: /* Set coding systems of PROCESS to DECODING and ENCODING. DECODING will be used to decode subprocess output and ENCODING to -encode subprocess input. */) - (register Lisp_Object process, Lisp_Object decoding, Lisp_Object encoding) +encode subprocess input. */) + (Lisp_Object process, Lisp_Object decoding, Lisp_Object encoding) { - register struct Lisp_Process *p; - CHECK_PROCESS (process); - p = XPROCESS (process); - if (p->infd < 0) - error ("Input file descriptor of %s closed", SDATA (p->name)); - if (p->outfd < 0) - error ("Output file descriptor of %s closed", SDATA (p->name)); + + struct Lisp_Process *p = XPROCESS (process); + Fcheck_coding_system (decoding); Fcheck_coding_system (encoding); encoding = coding_inherit_eol_type (encoding, Qnil); pset_decode_coding_system (p, decoding); pset_encode_coding_system (p, encoding); + + /* If the sockets haven't been set up yet, the final setup part of + this will be called asynchronously. */ + if (p->infd < 0 || p->outfd < 0) + return Qnil; + setup_process_coding_systems (process); return Qnil; @@ -6797,13 +7341,18 @@ all character code conversion except for end-of-line conversion is suppressed. */) (Lisp_Object process, Lisp_Object flag) { - register struct Lisp_Process *p; - CHECK_PROCESS (process); - p = XPROCESS (process); + + struct Lisp_Process *p = XPROCESS (process); if (NILP (flag)) pset_decode_coding_system (p, raw_text_coding_system (p->decode_coding_system)); + + /* If the sockets haven't been set up yet, the final setup part of + this will be called asynchronously. */ + if (p->infd < 0 || p->outfd < 0) + return Qnil; + setup_process_coding_systems (process); return Qnil; @@ -6814,14 +7363,11 @@ DEFUN ("process-filter-multibyte-p", Fprocess_filter_multibyte_p, doc: /* Return t if a multibyte string is given to PROCESS's filter.*/) (Lisp_Object process) { - register struct Lisp_Process *p; - struct coding_system *coding; - CHECK_PROCESS (process); - p = XPROCESS (process); + struct Lisp_Process *p = XPROCESS (process); if (p->infd < 0) return Qnil; - coding = proc_decode_coding_system[p->infd]; + struct coding_system *coding = proc_decode_coding_system[p->infd]; return (CODING_FOR_UNIBYTE (coding) ? Qnil : Qt); } @@ -6854,9 +7400,10 @@ keyboard_bit_set (fd_set *mask) { int fd; - for (fd = 0; fd <= max_input_desc; fd++) - if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask) - && !FD_ISSET (fd, &non_keyboard_wait_mask)) + for (fd = 0; fd <= max_desc; fd++) + if (FD_ISSET (fd, mask) + && ((fd_callback_info[fd].flags & (FOR_READ | KEYBOARD_FD)) + == (FOR_READ | KEYBOARD_FD))) return 1; return 0; @@ -7093,14 +7640,8 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, void add_timer_wait_descriptor (int fd) { - FD_SET (fd, &input_wait_mask); - FD_SET (fd, &non_keyboard_wait_mask); - FD_SET (fd, &non_process_wait_mask); - fd_callback_info[fd].func = timerfd_callback; - fd_callback_info[fd].data = NULL; - fd_callback_info[fd].condition |= FOR_READ; - if (fd > max_input_desc) - max_input_desc = fd; + add_read_fd (fd, timerfd_callback, NULL); + fd_callback_info[fd].flags &= ~KEYBOARD_FD; } #endif /* HAVE_TIMERFD */ @@ -7124,10 +7665,11 @@ void add_keyboard_wait_descriptor (int desc) { #ifdef subprocesses /* Actually means "not MSDOS". */ - FD_SET (desc, &input_wait_mask); - FD_SET (desc, &non_process_wait_mask); - if (desc > max_input_desc) - max_input_desc = desc; + eassert (desc >= 0 && desc < FD_SETSIZE); + fd_callback_info[desc].flags &= ~PROCESS_FD; + fd_callback_info[desc].flags |= (FOR_READ | KEYBOARD_FD); + if (desc > max_desc) + max_desc = desc; #endif } @@ -7137,9 +7679,12 @@ void delete_keyboard_wait_descriptor (int desc) { #ifdef subprocesses - FD_CLR (desc, &input_wait_mask); - FD_CLR (desc, &non_process_wait_mask); - delete_input_desc (desc); + eassert (desc >= 0 && desc < FD_SETSIZE); + + fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD); + + if (desc == max_desc) + recompute_max_desc (); #endif } @@ -7371,14 +7916,25 @@ catch_child_signal (void) } #endif /* subprocesses */ +/* Limit the number of open files to the value it had at startup. */ + +void +restore_nofile_limit (void) +{ +#ifdef HAVE_SETRLIMIT + if (FD_SETSIZE < nofile_limit.rlim_cur) + setrlimit (RLIMIT_NOFILE, &nofile_limit); +#endif +} + /* This is not called "init_process" because that is the name of a Mach system call, so it would cause problems on Darwin systems. */ void -init_process_emacs (void) +init_process_emacs (int sockfd) { #ifdef subprocesses - register int i; + int i; inhibit_sentinels = 0; @@ -7396,17 +7952,24 @@ init_process_emacs (void) catch_child_signal (); } - FD_ZERO (&input_wait_mask); - FD_ZERO (&non_keyboard_wait_mask); - FD_ZERO (&non_process_wait_mask); - FD_ZERO (&write_mask); - max_process_desc = max_input_desc = -1; +#ifdef HAVE_SETRLIMIT + /* Don't allocate more than FD_SETSIZE file descriptors for Emacs itself. */ + if (getrlimit (RLIMIT_NOFILE, &nofile_limit) != 0) + nofile_limit.rlim_cur = 0; + else if (FD_SETSIZE < nofile_limit.rlim_cur) + { + struct rlimit rlim = nofile_limit; + rlim.rlim_cur = FD_SETSIZE; + if (setrlimit (RLIMIT_NOFILE, &rlim) != 0) + nofile_limit.rlim_cur = 0; + } +#endif + + external_sock_fd = sockfd; + max_desc = -1; memset (fd_callback_info, 0, sizeof (fd_callback_info)); -#ifdef NON_BLOCKING_CONNECT - FD_ZERO (&connect_wait_mask); num_pending_connects = 0; -#endif process_output_delay_count = 0; process_output_skip = 0; @@ -7501,6 +8064,9 @@ syms_of_process (void) DEFSYM (QCserver, ":server"); DEFSYM (QCnowait, ":nowait"); DEFSYM (QCsentinel, ":sentinel"); + DEFSYM (QCuse_external_socket, ":use-external-socket"); + DEFSYM (QCtls_parameters, ":tls-parameters"); + DEFSYM (Qnsm_verify_connection, "nsm-verify-connection"); DEFSYM (QClog, ":log"); DEFSYM (QCnoquery, ":noquery"); DEFSYM (QCstop, ":stop"); @@ -7602,6 +8168,8 @@ The variable takes effect when `start-process' is called. */); defsubr (&Sprocess_filter); defsubr (&Sset_process_sentinel); defsubr (&Sprocess_sentinel); + defsubr (&Sset_process_thread); + defsubr (&Sprocess_thread); defsubr (&Sset_process_window_size); defsubr (&Sset_process_inherit_coding_system_flag); defsubr (&Sset_process_query_on_exit_flag); @@ -7650,9 +8218,7 @@ The variable takes effect when `start-process' is called. */); #define ADD_SUBFEATURE(key, val) \ subfeatures = pure_cons (pure_cons (key, pure_cons (val, Qnil)), subfeatures) -#ifdef NON_BLOCKING_CONNECT ADD_SUBFEATURE (QCnowait, Qt); -#endif #ifdef DATAGRAM_SOCKETS ADD_SUBFEATURE (QCtype, Qdatagram); #endif diff --git a/src/process.h b/src/process.h index 2e743a3dc38..5ef327aebdc 100644 --- a/src/process.h +++ b/src/process.h @@ -83,7 +83,10 @@ struct Lisp_Process Lisp_Object mark; /* Symbol indicating status of process. - This may be a symbol: run, open, or closed. + This may be a symbol: run, open, closed, listen, or failed. + Or it may be a pair (connect . ADDRINFOS) where ADDRINFOS is + a list of remaining (PROTOCOL . ADDRINFO) pairs to try. + Or it may be (failed ERR) where ERR is an integer, string or symbol. Or it may be a list, whose car is stop, exit or signal and whose cdr is a pair (EXIT_CODE . COREDUMP_FLAG) or (SIGNAL_NUMBER . COREDUMP_FLAG). */ @@ -106,18 +109,23 @@ struct Lisp_Process #ifdef HAVE_GNUTLS Lisp_Object gnutls_cred_type; + Lisp_Object gnutls_boot_parameters; #endif /* Pipe process attached to the standard error of this process. */ Lisp_Object stderrproc; + /* The thread a process is linked to, or nil for any thread. */ + Lisp_Object thread; + /* After this point, there are no Lisp_Objects any more. */ /* alloc.c assumes that `pid' is the first such non-Lisp slot. */ - /* Number of this process. - allocate_process assumes this is the first non-Lisp_Object field. - A value 0 is used for pseudo-processes such as network or serial - connections. */ + /* Process ID. A positive value is a child process ID. + Zero is for pseudo-processes such as network or serial connections, + or for processes that have not been fully created yet. + -1 is for a process that was not created successfully. + -2 is for a pty with no process, e.g., for GDB. */ pid_t pid; /* Descriptor by which we read from this process. */ int infd; @@ -161,7 +169,23 @@ struct Lisp_Process flag indicates that `raw_status' contains a new status that still needs to be synced to `status'. */ bool_bf raw_status_new : 1; + /* Whether this is a nonblocking socket. */ + bool_bf is_non_blocking_client : 1; + /* Whether this is a server or a client socket. */ + bool_bf is_server : 1; int raw_status; + /* The length of the socket backlog. */ + int backlog; + /* The port number. */ + int port; + /* The socket type. */ + int socktype; + +#ifdef HAVE_GETADDRINFO_A + /* Whether the socket is waiting for response from an asynchronous + DNS call. */ + struct gaicb *dns_request; +#endif #ifdef HAVE_GNUTLS gnutls_initstage_t gnutls_initstage; @@ -174,9 +198,29 @@ struct Lisp_Process int gnutls_log_level; int gnutls_handshakes_tried; bool_bf gnutls_p : 1; + bool_bf gnutls_complete_negotiation_p : 1; #endif }; +INLINE bool +PROCESSP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_PROCESS); +} + +INLINE void +CHECK_PROCESS (Lisp_Object x) +{ + CHECK_TYPE (PROCESSP (x), Qprocessp, x); +} + +INLINE struct Lisp_Process * +XPROCESS (Lisp_Object a) +{ + eassert (PROCESSP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + /* Every field in the preceding structure except for the first two must be a Lisp_Object, for GC's sake. */ @@ -191,6 +235,12 @@ pset_childp (struct Lisp_Process *p, Lisp_Object val) p->childp = val; } +INLINE void +pset_status (struct Lisp_Process *p, Lisp_Object val) +{ + p->status = val; +} + #ifdef HAVE_GNUTLS INLINE void pset_gnutls_cred_type (struct Lisp_Process *p, Lisp_Object val) @@ -225,7 +275,7 @@ extern Lisp_Object system_process_attributes (Lisp_Object); extern void record_deleted_pid (pid_t, Lisp_Object); struct sockaddr; -extern Lisp_Object conv_sockaddr_to_lisp (struct sockaddr *, int); +extern Lisp_Object conv_sockaddr_to_lisp (struct sockaddr *, ptrdiff_t); extern void hold_keyboard_input (void); extern void unhold_keyboard_input (void); extern bool kbd_on_hold_p (void); @@ -237,6 +287,7 @@ extern void delete_read_fd (int fd); extern void add_write_fd (int fd, fd_callback func, void *data); extern void delete_write_fd (int fd); extern void catch_child_signal (void); +extern void restore_nofile_limit (void); #ifdef WINDOWSNT extern Lisp_Object network_interface_list (void); @@ -245,6 +296,8 @@ extern Lisp_Object network_interface_info (Lisp_Object); extern Lisp_Object remove_slash_colon (Lisp_Object); +extern void update_processes_for_thread_death (Lisp_Object); + INLINE_HEADER_END #endif /* EMACS_PROCESS_H */ diff --git a/src/profiler.c b/src/profiler.c index 31bd77f00e3..07e21aeab10 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -201,7 +201,12 @@ static bool profiler_timer_ok; /* Status of sampling profiler. */ static enum profiler_cpu_running - { NOT_RUNNING, TIMER_SETTIME_RUNNING, SETITIMER_RUNNING } + { NOT_RUNNING, +#ifdef HAVE_ITIMERSPEC + TIMER_SETTIME_RUNNING, +#endif + SETITIMER_RUNNING + } profiler_cpu_running; /* Hash-table log of CPU profiler. */ @@ -224,7 +229,7 @@ static EMACS_INT current_sampling_interval; static void handle_profiler_signal (int signal) { - if (EQ (backtrace_top_function (), Qautomatic_gc)) + if (EQ (backtrace_top_function (), QAutomatic_GC)) /* Special case the time-count inside GC because the hash-table code is not prepared to be used while the GC is running. More specifically it uses ASIZE at many places where it does @@ -418,7 +423,7 @@ Before returning, a new log is allocated for future samples. */) cpu_log = (profiler_cpu_running ? make_log (profiler_log_size, profiler_max_stack_depth) : Qnil); - Fputhash (Fmake_vector (make_number (1), Qautomatic_gc), + Fputhash (Fmake_vector (make_number (1), QAutomatic_GC), make_number (cpu_gc_count), result); cpu_gc_count = 0; diff --git a/src/puresize.h b/src/puresize.h index fb9d934cad5..da827ed3997 100644 --- a/src/puresize.h +++ b/src/puresize.h @@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN #endif #ifndef BASE_PURESIZE -#define BASE_PURESIZE (1800000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA) +#define BASE_PURESIZE (1900000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA) #endif /* Increase BASE_PURESIZE by a ratio depending on the machine's word size. */ diff --git a/src/ralloc.c b/src/ralloc.c index a94f81b5bfe..2faa42e8296 100644 --- a/src/ralloc.c +++ b/src/ralloc.c @@ -22,31 +22,15 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ rather than all of them. This means allowing for a possible hole between the first bloc and the end of malloc storage. */ -#ifdef emacs - #include <config.h> -#include "lisp.h" /* Needed for VALBITS. */ -#include "blockinput.h" - -#include <unistd.h> - -#ifdef DOUG_LEA_MALLOC -#define M_TOP_PAD -2 -extern int mallopt (int, int); -#else /* not DOUG_LEA_MALLOC */ -#if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC -extern size_t __malloc_extra_blocks; -#endif /* not SYSTEM_MALLOC and not HYBRID_MALLOC */ -#endif /* not DOUG_LEA_MALLOC */ - -#else /* not emacs */ - #include <stddef.h> -#include <malloc.h> - -#endif /* not emacs */ +#ifdef emacs +# include "lisp.h" +# include "blockinput.h" +# include <unistd.h> +#endif #include "getpagesize.h" @@ -95,7 +79,10 @@ static int extra_bytes; /* The hook `malloc' uses for the function which gets more space from the system. */ -#if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC +#ifdef HAVE_MALLOC_H +# include <malloc.h> +#endif +#ifndef DOUG_LEA_MALLOC extern void *(*__morecore) (ptrdiff_t); #endif diff --git a/src/regex.c b/src/regex.c index 56b18e6b5bb..f1686cf700c 100644 --- a/src/regex.c +++ b/src/regex.c @@ -50,6 +50,7 @@ #include <config.h> #include <stddef.h> +#include <stdlib.h> #ifdef emacs /* We need this for `regex.h', and perhaps for the Emacs include files. */ @@ -217,7 +218,7 @@ xmalloc (size_t size) void *val = malloc (size); if (!val && size) { - write (2, "virtual memory exhausted\n", 25); + write (STDERR_FILENO, "virtual memory exhausted\n", 25); exit (1); } return val; @@ -235,7 +236,7 @@ xrealloc (void *block, size_t size) val = realloc (block, size); if (!val && size) { - write (2, "virtual memory exhausted\n", 25); + write (STDERR_FILENO, "virtual memory exhausted\n", 25); exit (1); } return val; @@ -326,7 +327,7 @@ enum syntaxcode { Swhitespace = 0, Sword = 1, Ssymbol = 2 }; ? (((c) >= 'a' && (c) <= 'z') \ || ((c) >= 'A' && (c) <= 'Z') \ || ((c) >= '0' && (c) <= '9')) \ - : (alphabeticp (c) || decimalnump (c))) + : alphanumericp (c)) # define ISALPHA(c) (IS_REAL_ASCII (c) \ ? (((c) >= 'a' && (c) <= 'z') \ @@ -445,25 +446,12 @@ init_syntax_once (void) #else /* not REGEX_MALLOC */ -/* Emacs already defines alloca, sometimes. */ -# ifndef alloca - -/* Make alloca work the best possible way. */ -# ifdef __GNUC__ -# define alloca __builtin_alloca -# else /* not __GNUC__ */ -# ifdef HAVE_ALLOCA_H -# include <alloca.h> -# endif /* HAVE_ALLOCA_H */ -# endif /* not __GNUC__ */ - -# endif /* not alloca */ - # ifdef emacs # define REGEX_USE_SAFE_ALLOCA USE_SAFE_ALLOCA # define REGEX_SAFE_FREE() SAFE_FREE () # define REGEX_ALLOCATE SAFE_ALLOCA # else +# include <alloca.h> # define REGEX_ALLOCATE alloca # endif @@ -515,8 +503,6 @@ init_syntax_once (void) #define BYTEWIDTH 8 /* In bits. */ -#define STREQ(s1, s2) ((strcmp (s1, s2) == 0)) - #ifndef emacs # undef max # undef min @@ -671,9 +657,7 @@ typedef enum notsyntaxspec #ifdef emacs - ,before_dot, /* Succeeds if before point. */ - at_dot, /* Succeeds if at point. */ - after_dot, /* Succeeds if after point. */ + , at_dot, /* Succeeds if at point. */ /* Matches any character whose category-set contains the specified category. The operator is followed by a byte which contains a @@ -785,44 +769,6 @@ extract_number_and_incr (re_char **source) and end. */ #define CHARSET_RANGE_TABLE_END(range_table, count) \ ((range_table) + (count) * 2 * 3) - -/* Test if C is in RANGE_TABLE. A flag NOT is negated if C is in. - COUNT is number of ranges in RANGE_TABLE. */ -#define CHARSET_LOOKUP_RANGE_TABLE_RAW(not, c, range_table, count) \ - do \ - { \ - re_wchar_t range_start, range_end; \ - re_char *rtp; \ - re_char *range_table_end \ - = CHARSET_RANGE_TABLE_END ((range_table), (count)); \ - \ - for (rtp = (range_table); rtp < range_table_end; rtp += 2 * 3) \ - { \ - EXTRACT_CHARACTER (range_start, rtp); \ - EXTRACT_CHARACTER (range_end, rtp + 3); \ - \ - if (range_start <= (c) && (c) <= range_end) \ - { \ - (not) = !(not); \ - break; \ - } \ - } \ - } \ - while (0) - -/* Test if C is in range table of CHARSET. The flag NOT is negated if - C is listed in it. */ -#define CHARSET_LOOKUP_RANGE_TABLE(not, c, charset) \ - do \ - { \ - /* Number of ranges in range table. */ \ - int count; \ - re_char *range_table = CHARSET_RANGE_TABLE (charset); \ - \ - EXTRACT_NUMBER_AND_INCR (count, range_table); \ - CHARSET_LOOKUP_RANGE_TABLE_RAW ((not), (c), range_table, count); \ - } \ - while (0) /* If DEBUG is defined, Regex prints many voluminous messages about what it is doing (if the variable `debug' is nonzero). If linked with the @@ -1093,18 +1039,10 @@ print_partial_compiled_pattern (re_char *start, re_char *end) break; # ifdef emacs - case before_dot: - fprintf (stderr, "/before_dot"); - break; - case at_dot: fprintf (stderr, "/at_dot"); break; - case after_dot: - fprintf (stderr, "/after_dot"); - break; - case categoryspec: fprintf (stderr, "/categoryspec"); mcnt = *p++; @@ -1158,7 +1096,9 @@ print_compiled_pattern (struct re_pattern_buffer *bufp) printf ("no_sub: %d\t", bufp->no_sub); printf ("not_bol: %d\t", bufp->not_bol); printf ("not_eol: %d\t", bufp->not_eol); +#ifndef emacs printf ("syntax: %lx\n", bufp->syntax); +#endif fflush (stdout); /* Perhaps we should print the translate table? */ } @@ -1199,13 +1139,8 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1, #endif /* not DEBUG */ -/* Use this to suppress gcc's `...may be used before initialized' warnings. */ -#ifdef lint -# define IF_LINT(Code) Code -#else -# define IF_LINT(Code) /* empty */ -#endif - +#ifndef emacs + /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can also be assigned to arbitrarily: each pattern buffer stores its own syntax, so it can be changed between regex compilations. */ @@ -1231,15 +1166,7 @@ re_set_syntax (reg_syntax_t syntax) } WEAK_ALIAS (__re_set_syntax, re_set_syntax) -/* Regexp to use to replace spaces, or NULL meaning don't. */ -static const_re_char *whitespace_regexp; - -void -re_set_whitespace_regexp (const char *regexp) -{ - whitespace_regexp = (const_re_char *) regexp; -} -WEAK_ALIAS (__re_set_syntax, re_set_syntax) +#endif /* This table gives an error message for each of the error codes listed in regex.h. Obviously the order here has to be same as there. @@ -1621,7 +1548,12 @@ do { \ /* Subroutine declarations and macros for regex_compile. */ static reg_errcode_t regex_compile (re_char *pattern, size_t size, +#ifdef emacs + bool posix_backtracking, + const char *whitespace_regexp, +#else reg_syntax_t syntax, +#endif struct re_pattern_buffer *bufp); static void store_op1 (re_opcode_t op, unsigned char *loc, int arg); static void store_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2); @@ -1712,28 +1644,6 @@ static int analyze_first (re_char *p, re_char *pend, reset the pointers that pointed into the old block to point to the correct places in the new one. If extending the buffer results in it being larger than MAX_BUF_SIZE, then flag memory exhausted. */ -#if __BOUNDED_POINTERS__ -# define SET_HIGH_BOUND(P) (__ptrhigh (P) = __ptrlow (P) + bufp->allocated) -# define MOVE_BUFFER_POINTER(P) \ - (__ptrlow (P) = new_buffer + (__ptrlow (P) - old_buffer), \ - SET_HIGH_BOUND (P), \ - __ptrvalue (P) = new_buffer + (__ptrvalue (P) - old_buffer)) -# define ELSE_EXTEND_BUFFER_HIGH_BOUND \ - else \ - { \ - SET_HIGH_BOUND (b); \ - SET_HIGH_BOUND (begalt); \ - if (fixup_alt_jump) \ - SET_HIGH_BOUND (fixup_alt_jump); \ - if (laststart) \ - SET_HIGH_BOUND (laststart); \ - if (pending_exact) \ - SET_HIGH_BOUND (pending_exact); \ - } -#else -# define MOVE_BUFFER_POINTER(P) ((P) = new_buffer + ((P) - old_buffer)) -# define ELSE_EXTEND_BUFFER_HIGH_BOUND -#endif #define EXTEND_BUFFER() \ do { \ unsigned char *old_buffer = bufp->buffer; \ @@ -1742,23 +1652,24 @@ static int analyze_first (re_char *p, re_char *pend, bufp->allocated <<= 1; \ if (bufp->allocated > MAX_BUF_SIZE) \ bufp->allocated = MAX_BUF_SIZE; \ + ptrdiff_t b_off = b - old_buffer; \ + ptrdiff_t begalt_off = begalt - old_buffer; \ + bool fixup_alt_jump_set = !!fixup_alt_jump; \ + bool laststart_set = !!laststart; \ + bool pending_exact_set = !!pending_exact; \ + ptrdiff_t fixup_alt_jump_off, laststart_off, pending_exact_off; \ + if (fixup_alt_jump_set) fixup_alt_jump_off = fixup_alt_jump - old_buffer; \ + if (laststart_set) laststart_off = laststart - old_buffer; \ + if (pending_exact_set) pending_exact_off = pending_exact - old_buffer; \ RETALLOC (bufp->buffer, bufp->allocated, unsigned char); \ if (bufp->buffer == NULL) \ return REG_ESPACE; \ - /* If the buffer moved, move all the pointers into it. */ \ - if (old_buffer != bufp->buffer) \ - { \ - unsigned char *new_buffer = bufp->buffer; \ - MOVE_BUFFER_POINTER (b); \ - MOVE_BUFFER_POINTER (begalt); \ - if (fixup_alt_jump) \ - MOVE_BUFFER_POINTER (fixup_alt_jump); \ - if (laststart) \ - MOVE_BUFFER_POINTER (laststart); \ - if (pending_exact) \ - MOVE_BUFFER_POINTER (pending_exact); \ - } \ - ELSE_EXTEND_BUFFER_HIGH_BOUND \ + unsigned char *new_buffer = bufp->buffer; \ + b = new_buffer + b_off; \ + begalt = new_buffer + begalt_off; \ + if (fixup_alt_jump_set) fixup_alt_jump = new_buffer + fixup_alt_jump_off; \ + if (laststart_set) laststart = new_buffer + laststart_off; \ + if (pending_exact_set) pending_exact = new_buffer + pending_exact_off; \ } while (0) @@ -2016,29 +1927,96 @@ struct range_table_work_area #if ! WIDE_CHAR_SUPPORT -/* Map a string to the char class it names (if any). */ +/* Parse a character class, i.e. string such as "[:name:]". *strp + points to the string to be parsed and limit is length, in bytes, of + that string. + + If *strp point to a string that begins with "[:name:]", where name is + a non-empty sequence of lower case letters, *strp will be advanced past the + closing square bracket and RECC_* constant which maps to the name will be + returned. If name is not a valid character class name zero, or RECC_ERROR, + is returned. + + Otherwise, if *strp doesn’t begin with "[:name:]", -1 is returned. + + The function can be used on ASCII and multibyte (UTF-8-encoded) strings. + */ re_wctype_t -re_wctype (const_re_char *str) +re_wctype_parse (const unsigned char **strp, unsigned limit) { - const char *string = (const char *) str; - if (STREQ (string, "alnum")) return RECC_ALNUM; - else if (STREQ (string, "alpha")) return RECC_ALPHA; - else if (STREQ (string, "word")) return RECC_WORD; - else if (STREQ (string, "ascii")) return RECC_ASCII; - else if (STREQ (string, "nonascii")) return RECC_NONASCII; - else if (STREQ (string, "graph")) return RECC_GRAPH; - else if (STREQ (string, "lower")) return RECC_LOWER; - else if (STREQ (string, "print")) return RECC_PRINT; - else if (STREQ (string, "punct")) return RECC_PUNCT; - else if (STREQ (string, "space")) return RECC_SPACE; - else if (STREQ (string, "upper")) return RECC_UPPER; - else if (STREQ (string, "unibyte")) return RECC_UNIBYTE; - else if (STREQ (string, "multibyte")) return RECC_MULTIBYTE; - else if (STREQ (string, "digit")) return RECC_DIGIT; - else if (STREQ (string, "xdigit")) return RECC_XDIGIT; - else if (STREQ (string, "cntrl")) return RECC_CNTRL; - else if (STREQ (string, "blank")) return RECC_BLANK; - else return 0; + const char *beg = (const char *)*strp, *it; + + if (limit < 4 || beg[0] != '[' || beg[1] != ':') + return -1; + + beg += 2; /* skip opening ‘[:’ */ + limit -= 3; /* opening ‘[:’ and half of closing ‘:]’; --limit handles rest */ + for (it = beg; it[0] != ':' || it[1] != ']'; ++it) + if (!--limit) + return -1; + + *strp = (const unsigned char *)(it + 2); + + /* Sort tests in the length=five case by frequency the classes to minimize + number of times we fail the comparison. The frequencies of character class + names used in Emacs sources as of 2016-07-27: + + $ find \( -name \*.c -o -name \*.el \) -exec grep -h '\[:[a-z]*:]' {} + | + sed 's/]/]\n/g' |grep -o '\[:[a-z]*:]' |sort |uniq -c |sort -nr + 213 [:alnum:] + 104 [:alpha:] + 62 [:space:] + 39 [:digit:] + 36 [:blank:] + 26 [:word:] + 26 [:upper:] + 21 [:lower:] + 10 [:xdigit:] + 10 [:punct:] + 10 [:ascii:] + 4 [:nonascii:] + 4 [:graph:] + 2 [:print:] + 2 [:cntrl:] + 1 [:ff:] + + If you update this list, consider also updating chain of or’ed conditions + in execute_charset function. + */ + + switch (it - beg) { + case 4: + if (!memcmp (beg, "word", 4)) return RECC_WORD; + break; + case 5: + if (!memcmp (beg, "alnum", 5)) return RECC_ALNUM; + if (!memcmp (beg, "alpha", 5)) return RECC_ALPHA; + if (!memcmp (beg, "space", 5)) return RECC_SPACE; + if (!memcmp (beg, "digit", 5)) return RECC_DIGIT; + if (!memcmp (beg, "blank", 5)) return RECC_BLANK; + if (!memcmp (beg, "upper", 5)) return RECC_UPPER; + if (!memcmp (beg, "lower", 5)) return RECC_LOWER; + if (!memcmp (beg, "punct", 5)) return RECC_PUNCT; + if (!memcmp (beg, "ascii", 5)) return RECC_ASCII; + if (!memcmp (beg, "graph", 5)) return RECC_GRAPH; + if (!memcmp (beg, "print", 5)) return RECC_PRINT; + if (!memcmp (beg, "cntrl", 5)) return RECC_CNTRL; + break; + case 6: + if (!memcmp (beg, "xdigit", 6)) return RECC_XDIGIT; + break; + case 7: + if (!memcmp (beg, "unibyte", 7)) return RECC_UNIBYTE; + break; + case 8: + if (!memcmp (beg, "nonascii", 8)) return RECC_NONASCII; + break; + case 9: + if (!memcmp (beg, "multibyte", 9)) return RECC_MULTIBYTE; + break; + } + + return RECC_ERROR; } /* True if CH is in the char class CC. */ @@ -2384,6 +2362,9 @@ static boolean group_in_compile_stack (compile_stack_type compile_stack, /* `regex_compile' compiles PATTERN (of length SIZE) according to SYNTAX. Returns one of error codes defined in `regex.h', or zero for success. + If WHITESPACE_REGEXP is given (only #ifdef emacs), it is used instead of + a space character in PATTERN. + Assumes the `allocated' (and perhaps `buffer') and `translate' fields are set in BUFP on entry. @@ -2416,7 +2397,15 @@ do { \ } while (0) static reg_errcode_t -regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, +regex_compile (const_re_char *pattern, size_t size, +#ifdef emacs +# define syntax RE_SYNTAX_EMACS + bool posix_backtracking, + const char *whitespace_regexp, +#else + reg_syntax_t syntax, +# define posix_backtracking (!(syntax & RE_NO_POSIX_BACKTRACKING)) +#endif struct re_pattern_buffer *bufp) { /* We fetch characters from PATTERN here. */ @@ -2469,14 +2458,16 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, /* If the object matched can contain multibyte characters. */ const boolean multibyte = RE_MULTIBYTE_P (bufp); +#ifdef emacs /* Nonzero if we have pushed down into a subpattern. */ int in_subpattern = 0; /* These hold the values of p, pattern, and pend from the main pattern when we have pushed into a subpattern. */ - re_char *main_p IF_LINT (= NULL); - re_char *main_pattern IF_LINT (= NULL); - re_char *main_pend IF_LINT (= NULL); + re_char *main_p; + re_char *main_pattern; + re_char *main_pend; +#endif #ifdef DEBUG debug++; @@ -2503,7 +2494,9 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, range_table_work.allocated = 0; /* Initialize the pattern buffer. */ +#ifndef emacs bufp->syntax = syntax; +#endif bufp->fastmap_accurate = 0; bufp->not_bol = bufp->not_eol = 0; bufp->used_syntax = 0; @@ -2545,6 +2538,7 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, { if (p == pend) { +#ifdef emacs /* If this is the end of an included regexp, pop back to the main regexp and try again. */ if (in_subpattern) @@ -2555,6 +2549,7 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, pend = main_pend; continue; } +#endif /* If this is the end of the main regexp, we are done. */ break; } @@ -2563,6 +2558,7 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, switch (c) { +#ifdef emacs case ' ': { re_char *p1 = p; @@ -2591,10 +2587,11 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, main_p = p1; main_pend = pend; main_pattern = pattern; - p = pattern = whitespace_regexp; - pend = p + strlen ((const char *) p); + p = pattern = (re_char *) whitespace_regexp; + pend = p + strlen (whitespace_regexp); break; } +#endif case '^': { @@ -2823,10 +2820,69 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, { boolean escaped_char = false; const unsigned char *p2 = p; + re_wctype_t cc; re_wchar_t ch; if (p == pend) FREE_STACK_RETURN (REG_EBRACK); + /* See if we're at the beginning of a possible character + class. */ + if (syntax & RE_CHAR_CLASSES && + (cc = re_wctype_parse(&p, pend - p)) != -1) + { + if (cc == 0) + FREE_STACK_RETURN (REG_ECTYPE); + + if (p == pend) + FREE_STACK_RETURN (REG_EBRACK); + +#ifndef emacs + for (ch = 0; ch < (1 << BYTEWIDTH); ++ch) + if (re_iswctype (btowc (ch), cc)) + { + c = TRANSLATE (ch); + if (c < (1 << BYTEWIDTH)) + SET_LIST_BIT (c); + } +#else /* emacs */ + /* Most character classes in a multibyte match just set + a flag. Exceptions are is_blank, is_digit, is_cntrl, and + is_xdigit, since they can only match ASCII characters. + We don't need to handle them for multibyte. */ + + /* Setup the gl_state object to its buffer-defined value. + This hardcodes the buffer-global syntax-table for ASCII + chars, while the other chars will obey syntax-table + properties. It's not ideal, but it's the way it's been + done until now. */ + SETUP_BUFFER_SYNTAX_TABLE (); + + for (c = 0; c < 0x80; ++c) + if (re_iswctype (c, cc)) + { + SET_LIST_BIT (c); + c1 = TRANSLATE (c); + if (c1 == c) + continue; + if (ASCII_CHAR_P (c1)) + SET_LIST_BIT (c1); + else if ((c1 = RE_CHAR_TO_UNIBYTE (c1)) >= 0) + SET_LIST_BIT (c1); + } + SET_RANGE_TABLE_WORK_AREA_BIT + (range_table_work, re_wctype_to_bit (cc)); +#endif /* emacs */ + /* In most cases the matching rule for char classes only + uses the syntax table for multibyte chars, so that the + content of the syntax-table is not hardcoded in the + range_table. SPACE and WORD are the two exceptions. */ + if ((1 << cc) & ((1 << RECC_SPACE) | (1 << RECC_WORD))) + bufp->used_syntax = 1; + + /* Repeat the loop. */ + continue; + } + /* Don't translate yet. The range TRANSLATE(X..Y) cannot always be determined from TRANSLATE(X) and TRANSLATE(Y) So the translation is done later in a loop. Example: @@ -2850,119 +2906,6 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, break; } - /* See if we're at the beginning of a possible character - class. */ - - if (!escaped_char && - syntax & RE_CHAR_CLASSES && c == '[' && *p == ':') - { - /* Leave room for the null. */ - unsigned char str[CHAR_CLASS_MAX_LENGTH + 1]; - const unsigned char *class_beg; - - PATFETCH (c); - c1 = 0; - class_beg = p; - - /* If pattern is `[[:'. */ - if (p == pend) FREE_STACK_RETURN (REG_EBRACK); - - for (;;) - { - PATFETCH (c); - if ((c == ':' && *p == ']') || p == pend) - break; - if (c1 < CHAR_CLASS_MAX_LENGTH) - str[c1++] = c; - else - /* This is in any case an invalid class name. */ - str[0] = '\0'; - } - str[c1] = '\0'; - - /* If isn't a word bracketed by `[:' and `:]': - undo the ending character, the letters, and - leave the leading `:' and `[' (but set bits for - them). */ - if (c == ':' && *p == ']') - { - re_wctype_t cc = re_wctype (str); - - if (cc == 0) - FREE_STACK_RETURN (REG_ECTYPE); - - /* Throw away the ] at the end of the character - class. */ - PATFETCH (c); - - if (p == pend) FREE_STACK_RETURN (REG_EBRACK); - -#ifndef emacs - for (ch = 0; ch < (1 << BYTEWIDTH); ++ch) - if (re_iswctype (btowc (ch), cc)) - { - c = TRANSLATE (ch); - if (c < (1 << BYTEWIDTH)) - SET_LIST_BIT (c); - } -#else /* emacs */ - /* Most character classes in a multibyte match - just set a flag. Exceptions are is_blank, - is_digit, is_cntrl, and is_xdigit, since - they can only match ASCII characters. We - don't need to handle them for multibyte. - They are distinguished by a negative wctype. */ - - /* Setup the gl_state object to its buffer-defined - value. This hardcodes the buffer-global - syntax-table for ASCII chars, while the other chars - will obey syntax-table properties. It's not ideal, - but it's the way it's been done until now. */ - SETUP_BUFFER_SYNTAX_TABLE (); - - for (ch = 0; ch < 256; ++ch) - { - c = RE_CHAR_TO_MULTIBYTE (ch); - if (! CHAR_BYTE8_P (c) - && re_iswctype (c, cc)) - { - SET_LIST_BIT (ch); - c1 = TRANSLATE (c); - if (c1 == c) - continue; - if (ASCII_CHAR_P (c1)) - SET_LIST_BIT (c1); - else if ((c1 = RE_CHAR_TO_UNIBYTE (c1)) >= 0) - SET_LIST_BIT (c1); - } - } - SET_RANGE_TABLE_WORK_AREA_BIT - (range_table_work, re_wctype_to_bit (cc)); -#endif /* emacs */ - /* In most cases the matching rule for char classes - only uses the syntax table for multibyte chars, - so that the content of the syntax-table is not - hardcoded in the range_table. SPACE and WORD are - the two exceptions. */ - if ((1 << cc) & ((1 << RECC_SPACE) | (1 << RECC_WORD))) - bufp->used_syntax = 1; - - /* Repeat the loop. */ - continue; - } - else - { - /* Go back to right after the "[:". */ - p = class_beg; - SET_LIST_BIT ('['); - - /* Because the `:' may start the range, we - can't simply set bit and repeat the loop. - Instead, just set it to C and handle below. */ - c = ':'; - } - } - if (p < pend && p[0] == '-' && p[1] != ']') { @@ -3469,8 +3412,6 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, goto normal_char; #ifdef emacs - /* There is no way to specify the before_dot and after_dot - operators. rms says this is ok. --karl */ case '=': laststart = b; BUF_PUSH (at_dot); @@ -3677,7 +3618,7 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, /* If we don't want backtracking, force success the first time we reach the end of the compiled pattern. */ - if (syntax & RE_NO_POSIX_BACKTRACKING) + if (!posix_backtracking) BUF_PUSH (succeed); /* We have succeeded; set the length of the buffer. */ @@ -3712,6 +3653,12 @@ regex_compile (const_re_char *pattern, size_t size, reg_syntax_t syntax, #endif /* not MATCH_MAY_ALLOCATE */ FREE_STACK_RETURN (REG_NOERROR); + +#ifdef emacs +# undef syntax +#else +# undef posix_backtracking +#endif } /* regex_compile */ /* Subroutines for `regex_compile'. */ @@ -4047,9 +3994,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, /* All cases after this match the empty string. These end with `continue'. */ - case before_dot: case at_dot: - case after_dot: #endif /* !emacs */ case no_op: case begline: @@ -4670,6 +4615,73 @@ skip_noops (const_re_char *p, const_re_char *pend) return p; } +/* Test if C matches charset op. *PP points to the charset or charset_not + opcode. When the function finishes, *PP will be advanced past that opcode. + C is character to test (possibly after translations) and CORIG is original + character (i.e. without any translations). UNIBYTE denotes whether c is + unibyte or multibyte character. */ +static bool +execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte) +{ + re_char *p = *pp, *rtp = NULL; + bool not = (re_opcode_t) *p == charset_not; + + if (CHARSET_RANGE_TABLE_EXISTS_P (p)) + { + int count; + rtp = CHARSET_RANGE_TABLE (p); + EXTRACT_NUMBER_AND_INCR (count, rtp); + *pp = CHARSET_RANGE_TABLE_END ((rtp), (count)); + } + else + *pp += 2 + CHARSET_BITMAP_SIZE (p); + + if (unibyte && c < (1 << BYTEWIDTH)) + { /* Lookup bitmap. */ + /* Cast to `unsigned' instead of `unsigned char' in + case the bit list is a full 32 bytes long. */ + if (c < (unsigned) (CHARSET_BITMAP_SIZE (p) * BYTEWIDTH) + && p[2 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) + return !not; + } +#ifdef emacs + else if (rtp) + { + int class_bits = CHARSET_RANGE_TABLE_BITS (p); + re_wchar_t range_start, range_end; + + /* Sort tests by the most commonly used classes with some adjustment to which + tests are easiest to perform. Take a look at comment in re_wctype_parse + for table with frequencies of character class names. */ + + if ((class_bits & BIT_MULTIBYTE) || + (class_bits & BIT_ALNUM && ISALNUM (c)) || + (class_bits & BIT_ALPHA && ISALPHA (c)) || + (class_bits & BIT_SPACE && ISSPACE (c)) || + (class_bits & BIT_WORD && ISWORD (c)) || + ((class_bits & BIT_UPPER) && + (ISUPPER (c) || (corig != c && + c == downcase (corig) && ISLOWER (c)))) || + ((class_bits & BIT_LOWER) && + (ISLOWER (c) || (corig != c && + c == upcase (corig) && ISUPPER(c)))) || + (class_bits & BIT_PUNCT && ISPUNCT (c)) || + (class_bits & BIT_GRAPH && ISGRAPH (c)) || + (class_bits & BIT_PRINT && ISPRINT (c))) + return !not; + + for (p = *pp; rtp < p; rtp += 2 * 3) + { + EXTRACT_CHARACTER (range_start, rtp); + EXTRACT_CHARACTER (range_end, rtp + 3); + if (range_start <= c && c <= range_end) + return !not; + } + } +#endif /* emacs */ + return not; +} + /* Non-zero if "p1 matches something" implies "p2 fails". */ static int mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, @@ -4727,22 +4739,7 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, else if ((re_opcode_t) *p1 == charset || (re_opcode_t) *p1 == charset_not) { - int not = (re_opcode_t) *p1 == charset_not; - - /* Test if C is listed in charset (or charset_not) - at `p1'. */ - if (! multibyte || IS_REAL_ASCII (c)) - { - if (c < CHARSET_BITMAP_SIZE (p1) * BYTEWIDTH - && p1[2 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) - not = !not; - } - else if (CHARSET_RANGE_TABLE_EXISTS_P (p1)) - CHARSET_LOOKUP_RANGE_TABLE (not, c, p1); - - /* `not' is equal to 1 if c would match, which means - that we can't change to pop_failure_jump. */ - if (!not) + if (!execute_charset (&p1, c, c, !multibyte || IS_REAL_ASCII (c))) { DEBUG_PRINT (" No match => fast loop.\n"); return 1; @@ -4888,12 +4885,6 @@ re_match (struct re_pattern_buffer *bufp, const char *string, WEAK_ALIAS (__re_match, re_match) #endif /* not emacs */ -#ifdef emacs -/* In Emacs, this is the string or buffer in which we are matching. - See the declaration in regex.h for details. */ -Lisp_Object re_match_object; -#endif - /* re_match_2 matches the compiled pattern in BUFP against the the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1 and SIZE2, respectively). We start matching at POS, and stop @@ -5142,8 +5133,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, if (p == pend) { - ptrdiff_t dcnt; - /* End of pattern means we might have succeeded. */ DEBUG_PRINT ("end of pattern ... "); @@ -5151,19 +5140,22 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, longest match, try backtracking. */ if (d != end_match_2) { - /* 1 if this match ends in the same string (string1 or string2) - as the best previous match. */ - boolean same_str_p = (FIRST_STRING_P (match_end) - == FIRST_STRING_P (d)); - /* 1 if this match is the best seen so far. */ - boolean best_match_p; - - /* AIX compiler got confused when this was combined - with the previous declaration. */ - if (same_str_p) - best_match_p = d > match_end; - else - best_match_p = !FIRST_STRING_P (d); + /* True if this match is the best seen so far. */ + bool best_match_p; + + { + /* True if this match ends in the same string (string1 + or string2) as the best previous match. */ + bool same_str_p = (FIRST_STRING_P (match_end) + == FIRST_STRING_P (d)); + + /* AIX compiler got confused when this was combined + with the previous declaration. */ + if (same_str_p) + best_match_p = d > match_end; + else + best_match_p = !FIRST_STRING_P (d); + } DEBUG_PRINT ("backtracking.\n"); @@ -5292,7 +5284,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, nfailure_points_pushed - nfailure_points_popped); DEBUG_PRINT ("%u registers pushed.\n", num_regs_pushed); - dcnt = POINTER_TO_OFFSET (d) - pos; + ptrdiff_t dcnt = POINTER_TO_OFFSET (d) - pos; DEBUG_PRINT ("Returning %td from re_match_2.\n", dcnt); @@ -5423,6 +5415,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { int buf_charlen; re_wchar_t buf_ch; + reg_syntax_t syntax; DEBUG_PRINT ("EXECUTING anychar.\n"); @@ -5431,10 +5424,14 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, target_multibyte); buf_ch = TRANSLATE (buf_ch); - if ((!(bufp->syntax & RE_DOT_NEWLINE) - && buf_ch == '\n') - || ((bufp->syntax & RE_DOT_NOT_NULL) - && buf_ch == '\000')) +#ifdef emacs + syntax = RE_SYNTAX_EMACS; +#else + syntax = bufp->syntax; +#endif + + if ((!(syntax & RE_DOT_NEWLINE) && buf_ch == '\n') + || ((syntax & RE_DOT_NOT_NULL) && buf_ch == '\000')) goto fail; DEBUG_PRINT (" Matched \"%d\".\n", *d); @@ -5447,32 +5444,13 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, case charset_not: { register unsigned int c, corig; - boolean not = (re_opcode_t) *(p - 1) == charset_not; int len; - /* Start of actual range_table, or end of bitmap if there is no - range table. */ - re_char *range_table IF_LINT (= NULL); - - /* Nonzero if there is a range table. */ - int range_table_exists; - - /* Number of ranges of range table. This is not included - in the initial byte-length of the command. */ - int count = 0; - /* Whether matching against a unibyte character. */ boolean unibyte_char = false; - DEBUG_PRINT ("EXECUTING charset%s.\n", not ? "_not" : ""); - - range_table_exists = CHARSET_RANGE_TABLE_EXISTS_P (&p[-1]); - - if (range_table_exists) - { - range_table = CHARSET_RANGE_TABLE (&p[-1]); /* Past the bitmap. */ - EXTRACT_NUMBER_AND_INCR (count, range_table); - } + DEBUG_PRINT ("EXECUTING charset%s.\n", + (re_opcode_t) *(p - 1) == charset_not ? "_not" : ""); PREFETCH (); corig = c = RE_STRING_CHAR_AND_LENGTH (d, len, target_multibyte); @@ -5506,47 +5484,9 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, unibyte_char = true; } - if (unibyte_char && c < (1 << BYTEWIDTH)) - { /* Lookup bitmap. */ - /* Cast to `unsigned' instead of `unsigned char' in - case the bit list is a full 32 bytes long. */ - if (c < (unsigned) (CHARSET_BITMAP_SIZE (&p[-1]) * BYTEWIDTH) - && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) - not = !not; - } -#ifdef emacs - else if (range_table_exists) - { - int class_bits = CHARSET_RANGE_TABLE_BITS (&p[-1]); - - if ( (class_bits & BIT_LOWER - && (ISLOWER (c) - || (corig != c - && c == upcase (corig) && ISUPPER(c)))) - | (class_bits & BIT_MULTIBYTE) - | (class_bits & BIT_PUNCT && ISPUNCT (c)) - | (class_bits & BIT_SPACE && ISSPACE (c)) - | (class_bits & BIT_UPPER - && (ISUPPER (c) - || (corig != c - && c == downcase (corig) && ISLOWER (c)))) - | (class_bits & BIT_WORD && ISWORD (c)) - | (class_bits & BIT_ALPHA && ISALPHA (c)) - | (class_bits & BIT_ALNUM && ISALNUM (c)) - | (class_bits & BIT_GRAPH && ISGRAPH (c)) - | (class_bits & BIT_PRINT && ISPRINT (c))) - not = !not; - else - CHARSET_LOOKUP_RANGE_TABLE_RAW (not, c, range_table, count); - } -#endif /* emacs */ - - if (range_table_exists) - p = CHARSET_RANGE_TABLE_END (range_table, count); - else - p += CHARSET_BITMAP_SIZE (&p[-1]) + 1; - - if (!not) goto fail; + p -= 1; + if (!execute_charset (&p, c, corig, unibyte_char)) + goto fail; d += len; } @@ -6181,24 +6121,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, break; #ifdef emacs - case before_dot: - DEBUG_PRINT ("EXECUTING before_dot.\n"); - if (PTR_BYTE_POS (d) >= PT_BYTE) - goto fail; - break; - case at_dot: DEBUG_PRINT ("EXECUTING at_dot.\n"); if (PTR_BYTE_POS (d) != PT_BYTE) goto fail; break; - case after_dot: - DEBUG_PRINT ("EXECUTING after_dot.\n"); - if (PTR_BYTE_POS (d) <= PT_BYTE) - goto fail; - break; - case categoryspec: case notcategoryspec: { @@ -6330,6 +6258,9 @@ bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len, const char * re_compile_pattern (const char *pattern, size_t length, +#ifdef emacs + bool posix_backtracking, const char *whitespace_regexp, +#endif struct re_pattern_buffer *bufp) { reg_errcode_t ret; @@ -6343,7 +6274,14 @@ re_compile_pattern (const char *pattern, size_t length, setting no_sub. */ bufp->no_sub = 0; - ret = regex_compile ((re_char*) pattern, length, re_syntax_options, bufp); + ret = regex_compile ((re_char*) pattern, length, +#ifdef emacs + posix_backtracking, + whitespace_regexp, +#else + re_syntax_options, +#endif + bufp); if (!ret) return NULL; diff --git a/src/regex.h b/src/regex.h index 51f4424ce94..4219943033e 100644 --- a/src/regex.h +++ b/src/regex.h @@ -20,14 +20,20 @@ #ifndef _REGEX_H #define _REGEX_H 1 +#if defined emacs && (defined _REGEX_RE_COMP || defined _LIBC) +/* We’re not defining re_set_syntax and using a different prototype of + re_compile_pattern when building Emacs so fail compilation early with + a (somewhat helpful) error message when conflict is detected. */ +# error "_REGEX_RE_COMP nor _LIBC can be defined if emacs is defined." +#endif + +#include <sys/types.h> + /* Allow the use in C++ code. */ #ifdef __cplusplus extern "C" { #endif -/* POSIX says that <sys/types.h> must be included (by the caller) before - <regex.h>. */ - #if !defined _POSIX_C_SOURCE && !defined _POSIX_SOURCE && defined VMS /* VMS doesn't have `size_t' in <sys/types.h>, even though POSIX says it should be there. */ @@ -164,7 +170,7 @@ typedef unsigned long reg_syntax_t; some interfaces). When a regexp is compiled, the syntax used is stored in the pattern buffer, so changing this does not affect already-compiled regexps. */ -extern reg_syntax_t re_syntax_options; +/* extern reg_syntax_t re_syntax_options; */ #ifdef emacs # include "lisp.h" @@ -173,8 +179,10 @@ extern reg_syntax_t re_syntax_options; If the value is a Lisp string object, we are matching text in that string; if it's nil, we are matching text in the current buffer; if - it's t, we are matching text in a C string. */ -extern Lisp_Object re_match_object; + it's t, we are matching text in a C string. + + This is defined as a macro in thread.h, which see. */ +/* extern Lisp_Object re_match_object; */ #endif /* Roughly the maximum number of failure points on the stack. */ @@ -351,9 +359,10 @@ struct re_pattern_buffer /* Number of bytes actually used in `buffer'. */ size_t used; +#ifndef emacs /* Syntax setting with which the pattern was compiled. */ reg_syntax_t syntax; - +#endif /* Pointer to a fastmap, if any, otherwise zero. re_search uses the fastmap, if there is one, to skip over impossible starting points for matches. */ @@ -420,11 +429,10 @@ struct re_pattern_buffer typedef struct re_pattern_buffer regex_t; -/* Type for byte offsets within the string. POSIX mandates this to be an int, - but the Open Group has signaled its intention to change the requirement to - be that regoff_t be at least as wide as ptrdiff_t and ssize_t. Current - gnulib sources also use ssize_t, and we need this for supporting buffers and - strings > 2GB on 64-bit hosts. */ +/* POSIX 1003.1-2008 requires that regoff_t be at least as wide as + ptrdiff_t and ssize_t. We don't know of any hosts where ptrdiff_t + is wider than ssize_t, so ssize_t is safe. ptrdiff_t is not + necessarily visible here, so use ssize_t. */ typedef ssize_t regoff_t; @@ -457,14 +465,22 @@ typedef struct /* Declarations for routines. */ +#ifndef emacs + /* Sets the current default syntax to SYNTAX, and return the old syntax. You can also simply assign to the `re_syntax_options' variable. */ extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax); +#endif + /* Compile the regular expression PATTERN, with length LENGTH and syntax given by the global `re_syntax_options', into the buffer BUFFER. Return NULL if successful, and an error string if not. */ extern const char *re_compile_pattern (const char *__pattern, size_t __length, +#ifdef emacs + bool posix_backtracking, + const char *whitespace_regexp, +#endif struct re_pattern_buffer *__buffer); @@ -589,25 +605,13 @@ extern void regfree (regex_t *__preg); /* Solaris 2.5 has a bug: <wchar.h> must be included before <wctype.h>. */ # include <wchar.h> # include <wctype.h> -#endif -#if WIDE_CHAR_SUPPORT -/* The GNU C library provides support for user-defined character classes - and the functions from ISO C amendment 1. */ -# ifdef CHARCLASS_NAME_MAX -# define CHAR_CLASS_MAX_LENGTH CHARCLASS_NAME_MAX -# else -/* This shouldn't happen but some implementation might still have this - problem. Use a reasonable default value. */ -# define CHAR_CLASS_MAX_LENGTH 256 -# endif typedef wctype_t re_wctype_t; typedef wchar_t re_wchar_t; # define re_wctype wctype # define re_iswctype iswctype # define re_wctype_to_bit(cc) 0 #else -# define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */ # ifndef emacs # define btowc(c) c # endif @@ -625,12 +629,10 @@ typedef enum { RECC_ERROR = 0, } re_wctype_t; extern char re_iswctype (int ch, re_wctype_t cc); -extern re_wctype_t re_wctype (const unsigned char* str); +extern re_wctype_t re_wctype_parse (const unsigned char **strp, unsigned limit); typedef int re_wchar_t; -extern void re_set_whitespace_regexp (const char *regexp); - #endif /* not WIDE_CHAR_SUPPORT */ #endif /* regex.h */ diff --git a/src/search.c b/src/search.c index 9f55d728362..e499109555c 100644 --- a/src/search.c +++ b/src/search.c @@ -30,7 +30,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "blockinput.h" #include "intervals.h" -#include <sys/types.h> #include "regex.h" #define REGEXP_CACHE_SIZE 20 @@ -40,7 +39,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ struct regexp_cache { struct regexp_cache *next; - Lisp_Object regexp, whitespace_regexp; + Lisp_Object regexp, f_whitespace_regexp; /* Syntax table for which the regexp applies. We need this because of character classes. If this is t, then the compiled pattern is valid for any syntax-table. */ @@ -75,12 +74,12 @@ static struct regexp_cache *searchbuf_head; to call re_set_registers after compiling a new pattern or after setting the match registers, so that the regex functions will be able to free or re-allocate it properly. */ -static struct re_registers search_regs; +/* static struct re_registers search_regs; */ /* The buffer in which the last search was performed, or Qt if the last search was done in a string; Qnil if no searching has been done yet. */ -static Lisp_Object last_thing_searched; +/* static Lisp_Object last_thing_searched; */ static void set_search_regs (ptrdiff_t, ptrdiff_t); static void save_search_regs (void); @@ -113,8 +112,8 @@ static void compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, Lisp_Object translate, bool posix) { + const char *whitespace_regexp; char *val; - reg_syntax_t old; cp->regexp = Qnil; cp->buf.translate = (! NILP (translate) ? translate : make_number (0)); @@ -122,33 +121,26 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, cp->buf.multibyte = STRING_MULTIBYTE (pattern); cp->buf.charset_unibyte = charset_unibyte; if (STRINGP (Vsearch_spaces_regexp)) - cp->whitespace_regexp = Vsearch_spaces_regexp; + cp->f_whitespace_regexp = Vsearch_spaces_regexp; else - cp->whitespace_regexp = Qnil; + cp->f_whitespace_regexp = Qnil; /* rms: I think BLOCK_INPUT is not needed here any more, because regex.c defines malloc to call xmalloc. Using BLOCK_INPUT here means the debugger won't run if an error occurs. So let's turn it off. */ /* BLOCK_INPUT; */ - old = re_set_syntax (RE_SYNTAX_EMACS - | (posix ? 0 : RE_NO_POSIX_BACKTRACKING)); - if (STRINGP (Vsearch_spaces_regexp)) - re_set_whitespace_regexp (SSDATA (Vsearch_spaces_regexp)); - else - re_set_whitespace_regexp (NULL); + whitespace_regexp = STRINGP (Vsearch_spaces_regexp) ? + SSDATA (Vsearch_spaces_regexp) : NULL; - val = (char *) re_compile_pattern (SSDATA (pattern), - SBYTES (pattern), &cp->buf); + val = (char *) re_compile_pattern (SSDATA (pattern), SBYTES (pattern), + posix, whitespace_regexp, &cp->buf); /* If the compiled pattern hard codes some of the contents of the syntax-table, it can only be reused with *this* syntax table. */ cp->syntax_table = cp->buf.used_syntax ? BVAR (current_buffer, syntax_table) : Qt; - re_set_whitespace_regexp (NULL); - - re_set_syntax (old); /* unblock_input (); */ if (val) xsignal1 (Qinvalid_regexp, build_string (val)); @@ -224,7 +216,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, && cp->posix == posix && (EQ (cp->syntax_table, Qt) || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table))) - && !NILP (Fequal (cp->whitespace_regexp, Vsearch_spaces_regexp)) + && !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp)) && cp->buf.charset_unibyte == charset_unibyte) break; @@ -2789,7 +2781,8 @@ since only regular expressions have distinguished subexpressions. */) if (case_action == all_caps) Fupcase_region (make_number (search_regs.start[sub]), - make_number (newpoint)); + make_number (newpoint), + Qnil); else if (case_action == cap_initial) Fupcase_initials_region (make_number (search_regs.start[sub]), make_number (newpoint)); @@ -3095,9 +3088,9 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) /* If true the match data have been saved in saved_search_regs during the execution of a sentinel or filter. */ -static bool search_regs_saved; -static struct re_registers saved_search_regs; -static Lisp_Object saved_last_thing_searched; +/* static bool search_regs_saved; */ +/* static struct re_registers saved_search_regs; */ +/* static Lisp_Object saved_last_thing_searched; */ /* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data if asynchronous code (filter or sentinel) is running. */ @@ -3407,10 +3400,10 @@ syms_of_search (void) searchbufs[i].buf.buffer = xmalloc (100); searchbufs[i].buf.fastmap = searchbufs[i].fastmap; searchbufs[i].regexp = Qnil; - searchbufs[i].whitespace_regexp = Qnil; + searchbufs[i].f_whitespace_regexp = Qnil; searchbufs[i].syntax_table = Qnil; staticpro (&searchbufs[i].regexp); - staticpro (&searchbufs[i].whitespace_regexp); + staticpro (&searchbufs[i].f_whitespace_regexp); staticpro (&searchbufs[i].syntax_table); searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]); } diff --git a/src/sheap.c b/src/sheap.c index fc53c5822d7..72b74fa355f 100644 --- a/src/sheap.c +++ b/src/sheap.c @@ -19,87 +19,62 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> + +#include "sheap.h" + #include <stdio.h> #include "lisp.h" #include <unistd.h> #include <stdlib.h> /* for exit */ -#ifdef ENABLE_CHECKING -#define STATIC_HEAP_SIZE (28 * 1024 * 1024) -#else -#define STATIC_HEAP_SIZE (19 * 1024 * 1024) -#endif - -int debug_sheap = 0; - -#define BLOCKSIZE 4096 +static int debug_sheap; char bss_sbrk_buffer[STATIC_HEAP_SIZE]; -/* The following is needed in gmalloc.c */ -void *bss_sbrk_buffer_end = bss_sbrk_buffer + STATIC_HEAP_SIZE; -char *bss_sbrk_ptr; char *max_bss_sbrk_ptr; -int bss_sbrk_did_unexec; +bool bss_sbrk_did_unexec; void * bss_sbrk (ptrdiff_t request_size) { + static char *bss_sbrk_ptr; + if (!bss_sbrk_ptr) { max_bss_sbrk_ptr = bss_sbrk_ptr = bss_sbrk_buffer; #ifdef CYGWIN - sbrk (BLOCKSIZE); /* force space for fork to work */ + /* Force space for fork to work. */ + sbrk (4096); #endif } - if (!(int) request_size) - { - return (bss_sbrk_ptr); - } - else if (bss_sbrk_ptr + (int) request_size < bss_sbrk_buffer) + int used = bss_sbrk_ptr - bss_sbrk_buffer; + + if (request_size < -used) { - printf - ("attempt to free too much: avail %d used %d failed request %d\n", - STATIC_HEAP_SIZE, bss_sbrk_ptr - bss_sbrk_buffer, - (int) request_size); + printf (("attempt to free too much: " + "avail %d used %d failed request %"pD"d\n"), + STATIC_HEAP_SIZE, used, request_size); exit (-1); return 0; } - else if (bss_sbrk_ptr + (int) request_size > - bss_sbrk_buffer + STATIC_HEAP_SIZE) + else if (STATIC_HEAP_SIZE - used < request_size) { - printf ("static heap exhausted: avail %d used %d failed request %d\n", - STATIC_HEAP_SIZE, - bss_sbrk_ptr - bss_sbrk_buffer, (int) request_size); + printf ("static heap exhausted: avail %d used %d failed request %"pD"d\n", + STATIC_HEAP_SIZE, used, request_size); exit (-1); return 0; } - else if ((int) request_size < 0) - { - bss_sbrk_ptr += (int) request_size; - if (debug_sheap) - printf ("freed size %d\n", request_size); - return bss_sbrk_ptr; - } - else + + void *ret = bss_sbrk_ptr; + bss_sbrk_ptr += request_size; + if (max_bss_sbrk_ptr < bss_sbrk_ptr) + max_bss_sbrk_ptr = bss_sbrk_ptr; + if (debug_sheap) { - char *ret = bss_sbrk_ptr; - if (debug_sheap) - printf ("allocated 0x%08x size %d\n", ret, request_size); - bss_sbrk_ptr += (int) request_size; - if (bss_sbrk_ptr > max_bss_sbrk_ptr) - max_bss_sbrk_ptr = bss_sbrk_ptr; - return ret; + if (request_size < 0) + printf ("freed size %"pD"d\n", request_size); + else + printf ("allocated %p size %"pD"d\n", ret, request_size); } -} - -void -report_sheap_usage (int die_if_pure_storage_exceeded) -{ - char buf[200]; - sprintf (buf, "Maximum static heap usage: %d of %d bytes", - max_bss_sbrk_ptr - bss_sbrk_buffer, STATIC_HEAP_SIZE); - /* Don't log messages, cause at this point, we're not allowed to create - buffers. */ - message1_nolog (buf); + return ret; } diff --git a/src/sheap.h b/src/sheap.h new file mode 100644 index 00000000000..c229a1b06ed --- /dev/null +++ b/src/sheap.h @@ -0,0 +1,31 @@ +/* Static heap allocation for GNU Emacs. + +Copyright 2016 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <stddef.h> +#include "lisp.h" + +/* Size of the static heap. Guess a value that is probably too large, + by up to a factor of four or so. Typically the unused part is not + paged in and so does not cost much. */ +enum { STATIC_HEAP_SIZE = sizeof (Lisp_Object) << 22 }; + +extern char bss_sbrk_buffer[STATIC_HEAP_SIZE]; +extern char *max_bss_sbrk_ptr; +extern bool bss_sbrk_did_unexec; +extern void *bss_sbrk (ptrdiff_t); diff --git a/src/sound.c b/src/sound.c index b9a794b6a42..f5f570190ca 100644 --- a/src/sound.c +++ b/src/sound.c @@ -310,12 +310,13 @@ sound_perror (const char *msg) } #endif if (saved_errno != 0) - error ("%s: %s", msg, strerror (saved_errno)); + error ("%s: %s", msg, emacs_strerror (saved_errno)); else error ("%s", msg); } +#ifndef WINDOWSNT /* Display a warning message. */ static void @@ -323,6 +324,7 @@ sound_warning (const char *msg) { message1 (msg); } +#endif /* !WINDOWSNT */ /* Parse sound specification SOUND, and fill ATTRS with what is diff --git a/src/syntax.c b/src/syntax.c index 6e133ad9c27..7c15e774f05 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -20,8 +20,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> -#include <sys/types.h> - #include "lisp.h" #include "character.h" #include "buffer.h" @@ -81,6 +79,11 @@ SYNTAX_FLAGS_COMEND_SECOND (int flags) return (flags >> 19) & 1; } static bool +SYNTAX_FLAGS_COMSTARTEND_FIRST (int flags) +{ + return (flags & 0x50000) != 0; +} +static bool SYNTAX_FLAGS_PREFIX (int flags) { return (flags >> 20) & 1; @@ -153,6 +156,10 @@ struct lisp_parse_state ptrdiff_t comstr_start; /* Position of last comment/string starter. */ Lisp_Object levelstarts; /* Char numbers of starts-of-expression of levels (starting from outermost). */ + int prev_syntax; /* Syntax of previous position scanned, when + that position (potentially) holds the first char + of a 2-char construct, i.e. comment delimiter + or Sescape, etc. Smax otherwise. */ }; /* These variables are a cache for finding the start of a defun. @@ -176,7 +183,8 @@ static Lisp_Object skip_syntaxes (bool, Lisp_Object, Lisp_Object); static Lisp_Object scan_lists (EMACS_INT, EMACS_INT, EMACS_INT, bool); static void scan_sexps_forward (struct lisp_parse_state *, ptrdiff_t, ptrdiff_t, ptrdiff_t, EMACS_INT, - bool, Lisp_Object, int); + bool, int); +static void internalize_parse_state (Lisp_Object, struct lisp_parse_state *); static bool in_classes (int, Lisp_Object); static void parse_sexp_propertize (ptrdiff_t charpos); @@ -698,7 +706,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, ptrdiff_t comment_end = from; ptrdiff_t comment_end_byte = from_byte; ptrdiff_t comstart_pos = 0; - ptrdiff_t comstart_byte IF_LINT (= 0); + ptrdiff_t comstart_byte; /* Place where the containing defun starts, or 0 if we didn't come across it yet. */ ptrdiff_t defun_start = 0; @@ -911,10 +919,11 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, } do { + internalize_parse_state (Qnil, &state); scan_sexps_forward (&state, defun_start, defun_start_byte, comment_end, TYPE_MINIMUM (EMACS_INT), - 0, Qnil, 0); + 0, 0); defun_start = comment_end; if (!adjusted) { @@ -1622,7 +1631,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, int c; char fastmap[0400]; /* Store the ranges of non-ASCII characters. */ - int *char_ranges IF_LINT (= NULL); + int *char_ranges UNINIT; int n_char_ranges = 0; bool negate = 0; ptrdiff_t i, i_byte; @@ -1680,44 +1689,22 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, /* At first setup fastmap. */ while (i_byte < size_byte) { - c = str[i_byte++]; - - if (handle_iso_classes && c == '[' - && i_byte < size_byte - && str[i_byte] == ':') + if (handle_iso_classes) { - const unsigned char *class_beg = str + i_byte + 1; - const unsigned char *class_end = class_beg; - const unsigned char *class_limit = str + size_byte - 2; - /* Leave room for the null. */ - unsigned char class_name[CHAR_CLASS_MAX_LENGTH + 1]; - re_wctype_t cc; - - if (class_limit - class_beg > CHAR_CLASS_MAX_LENGTH) - class_limit = class_beg + CHAR_CLASS_MAX_LENGTH; - - while (class_end < class_limit - && *class_end >= 'a' && *class_end <= 'z') - class_end++; - - if (class_end == class_beg - || *class_end != ':' || class_end[1] != ']') - goto not_a_class_name; - - memcpy (class_name, class_beg, class_end - class_beg); - class_name[class_end - class_beg] = 0; - - cc = re_wctype (class_name); + const unsigned char *ch = str + i_byte; + re_wctype_t cc = re_wctype_parse (&ch, size_byte - i_byte); if (cc == 0) error ("Invalid ISO C character class"); - - iso_classes = Fcons (make_number (cc), iso_classes); - - i_byte = class_end + 2 - str; - continue; + if (cc != -1) + { + iso_classes = Fcons (make_number (cc), iso_classes); + i_byte = ch - str; + continue; + } } - not_a_class_name: + c = str[i_byte++]; + if (c == '\\') { if (i_byte == size_byte) @@ -1797,54 +1784,32 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, while (i_byte < size_byte) { int leading_code = str[i_byte]; - c = STRING_CHAR_AND_LENGTH (str + i_byte, len); - i_byte += len; - if (handle_iso_classes && c == '[' - && i_byte < size_byte - && STRING_CHAR (str + i_byte) == ':') + if (handle_iso_classes) { - const unsigned char *class_beg = str + i_byte + 1; - const unsigned char *class_end = class_beg; - const unsigned char *class_limit = str + size_byte - 2; - /* Leave room for the null. */ - unsigned char class_name[CHAR_CLASS_MAX_LENGTH + 1]; - re_wctype_t cc; - - if (class_limit - class_beg > CHAR_CLASS_MAX_LENGTH) - class_limit = class_beg + CHAR_CLASS_MAX_LENGTH; - - while (class_end < class_limit - && *class_end >= 'a' && *class_end <= 'z') - class_end++; - - if (class_end == class_beg - || *class_end != ':' || class_end[1] != ']') - goto not_a_class_name_multibyte; - - memcpy (class_name, class_beg, class_end - class_beg); - class_name[class_end - class_beg] = 0; - - cc = re_wctype (class_name); + const unsigned char *ch = str + i_byte; + re_wctype_t cc = re_wctype_parse (&ch, size_byte - i_byte); if (cc == 0) error ("Invalid ISO C character class"); - - iso_classes = Fcons (make_number (cc), iso_classes); - - i_byte = class_end + 2 - str; - continue; + if (cc != -1) + { + iso_classes = Fcons (make_number (cc), iso_classes); + i_byte = ch - str; + continue; + } } - not_a_class_name_multibyte: - if (c == '\\') + if (leading_code== '\\') { - if (i_byte == size_byte) + if (++i_byte == size_byte) break; leading_code = str[i_byte]; - c = STRING_CHAR_AND_LENGTH (str + i_byte, len); - i_byte += len; } + c = STRING_CHAR_AND_LENGTH (str + i_byte, len); + i_byte += len; + + /* Treat `-' as range character only if another character follows. */ if (i_byte + 1 < size_byte @@ -2299,11 +2264,15 @@ in_classes (int c, Lisp_Object iso_classes) PREV_SYNTAX is the SYNTAX_WITH_FLAGS of the previous character (or 0 If the search cannot start in the middle of a two-character). - If successful, return true and store the charpos of the comment's end - into *CHARPOS_PTR and the corresponding bytepos into *BYTEPOS_PTR. - Else, return false and store the charpos STOP into *CHARPOS_PTR, the - corresponding bytepos into *BYTEPOS_PTR and the current nesting - (as defined for state.incomment) in *INCOMMENT_PTR. + If successful, return true and store the charpos of the comment's + end into *CHARPOS_PTR and the corresponding bytepos into + *BYTEPOS_PTR. Else, return false and store the charpos STOP into + *CHARPOS_PTR, the corresponding bytepos into *BYTEPOS_PTR and the + current nesting (as defined for state->incomment) in + *INCOMMENT_PTR. Should the last character scanned in an incomplete + comment be a possible first character of a two character construct, + we store its SYNTAX_WITH_FLAGS into *last_syntax_ptr. Otherwise, + we store Smax into *last_syntax_ptr. The comment end is the last character of the comment rather than the character just after the comment. @@ -2315,7 +2284,7 @@ static bool forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, EMACS_INT nesting, int style, int prev_syntax, ptrdiff_t *charpos_ptr, ptrdiff_t *bytepos_ptr, - EMACS_INT *incomment_ptr) + EMACS_INT *incomment_ptr, int *last_syntax_ptr) { register int c, c1; register enum syntaxcode code; @@ -2326,7 +2295,8 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, /* Enter the loop in the middle so that we find a 2-char comment ender if we start in the middle of it. */ syntax = prev_syntax; - if (syntax != 0) goto forw_incomment; + code = syntax & 0xff; + if (syntax != 0 && from < stop) goto forw_incomment; while (1) { @@ -2335,6 +2305,12 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, *incomment_ptr = nesting; *charpos_ptr = from; *bytepos_ptr = from_byte; + *last_syntax_ptr = + (code == Sescape || code == Scharquote + || SYNTAX_FLAGS_COMEND_FIRST (syntax) + || (nesting > 0 + && SYNTAX_FLAGS_COMSTART_FIRST (syntax))) + ? syntax : Smax ; return 0; } c = FETCH_CHAR_AS_MULTIBYTE (from_byte); @@ -2375,7 +2351,9 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, SYNTAX_FLAGS_COMMENT_NESTED (other_syntax)) ? nesting > 0 : nesting < 0)) { - if (--nesting <= 0) + syntax = Smax; /* So that "|#" (lisp) can not return + the syntax of "#" in *last_syntax_ptr. */ + if (--nesting <= 0) /* We have encountered a comment end of the same style as the comment sequence which began this comment section. */ break; @@ -2397,6 +2375,7 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, /* We have encountered a nested comment of the same style as the comment sequence which began this comment section. */ { + syntax = Smax; /* So that "#|#" isn't also a comment ender. */ INC_BOTH (from, from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); nesting++; @@ -2404,6 +2383,8 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, } *charpos_ptr = from; *bytepos_ptr = from_byte; + *last_syntax_ptr = Smax; /* Any syntactic power the last byte had is + used up. */ return 1; } @@ -2425,6 +2406,7 @@ between them, return t; otherwise return nil. */) EMACS_INT count1; ptrdiff_t out_charpos, out_bytepos; EMACS_INT dummy; + int dummy2; CHECK_NUMBER (count); count1 = XINT (count); @@ -2488,7 +2470,7 @@ between them, return t; otherwise return nil. */) } /* We're at the start of a comment. */ found = forw_comment (from, from_byte, stop, comnested, comstyle, 0, - &out_charpos, &out_bytepos, &dummy); + &out_charpos, &out_bytepos, &dummy, &dummy2); from = out_charpos; from_byte = out_bytepos; if (!found) { @@ -2648,6 +2630,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) ptrdiff_t from_byte; ptrdiff_t out_bytepos, out_charpos; EMACS_INT dummy; + int dummy2; bool multibyte_symbol_p = sexpflag && multibyte_syntax_as_symbol; if (depth > 0) min_depth = 0; @@ -2744,7 +2727,8 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) UPDATE_SYNTAX_TABLE_FORWARD (from); found = forw_comment (from, from_byte, stop, comnested, comstyle, 0, - &out_charpos, &out_bytepos, &dummy); + &out_charpos, &out_bytepos, &dummy, + &dummy2); from = out_charpos, from_byte = out_bytepos; if (!found) { @@ -3109,7 +3093,7 @@ the prefix syntax flag (p). */) } /* Parse forward from FROM / FROM_BYTE to END, - assuming that FROM has state OLDSTATE (nil means FROM is start of function), + assuming that FROM has state STATE, and return a description of the state of the parse at END. If STOPBEFORE, stop at the start of an atom. If COMMENTSTOP is 1, stop at the start of a comment. @@ -3117,12 +3101,11 @@ the prefix syntax flag (p). */) after the beginning of a string, or after the end of a string. */ static void -scan_sexps_forward (struct lisp_parse_state *stateptr, +scan_sexps_forward (struct lisp_parse_state *state, ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t end, EMACS_INT targetdepth, bool stopbefore, - Lisp_Object oldstate, int commentstop) + int commentstop) { - struct lisp_parse_state state; enum syntaxcode code; int c1; bool comnested; @@ -3138,7 +3121,8 @@ scan_sexps_forward (struct lisp_parse_state *stateptr, Lisp_Object tem; ptrdiff_t prev_from; /* Keep one character before FROM. */ ptrdiff_t prev_from_byte; - int prev_from_syntax; + int prev_from_syntax, prev_prev_from_syntax; + int syntax; bool boundary_stop = commentstop == -1; bool nofence; bool found; @@ -3155,6 +3139,7 @@ scan_sexps_forward (struct lisp_parse_state *stateptr, do { prev_from = from; \ prev_from_byte = from_byte; \ temp = FETCH_CHAR_AS_MULTIBYTE (prev_from_byte); \ + prev_prev_from_syntax = prev_from_syntax; \ prev_from_syntax = SYNTAX_WITH_FLAGS (temp); \ INC_BOTH (from, from_byte); \ if (from < end) \ @@ -3164,88 +3149,38 @@ do { prev_from = from; \ immediate_quit = 1; QUIT; - if (NILP (oldstate)) - { - depth = 0; - state.instring = -1; - state.incomment = 0; - state.comstyle = 0; /* comment style a by default. */ - state.comstr_start = -1; /* no comment/string seen. */ - } - else - { - tem = Fcar (oldstate); - if (!NILP (tem)) - depth = XINT (tem); - else - depth = 0; + depth = state->depth; + start_quoted = state->quoted; + prev_prev_from_syntax = Smax; + prev_from_syntax = state->prev_syntax; - oldstate = Fcdr (oldstate); - oldstate = Fcdr (oldstate); - oldstate = Fcdr (oldstate); - tem = Fcar (oldstate); - /* Check whether we are inside string_fence-style string: */ - state.instring = (!NILP (tem) - ? (CHARACTERP (tem) ? XFASTINT (tem) : ST_STRING_STYLE) - : -1); - - oldstate = Fcdr (oldstate); - tem = Fcar (oldstate); - state.incomment = (!NILP (tem) - ? (INTEGERP (tem) ? XINT (tem) : -1) - : 0); - - oldstate = Fcdr (oldstate); - tem = Fcar (oldstate); - start_quoted = !NILP (tem); - - /* if the eighth element of the list is nil, we are in comment - style a. If it is non-nil, we are in comment style b */ - oldstate = Fcdr (oldstate); - oldstate = Fcdr (oldstate); - tem = Fcar (oldstate); - state.comstyle = (NILP (tem) - ? 0 - : (RANGED_INTEGERP (0, tem, ST_COMMENT_STYLE) - ? XINT (tem) - : ST_COMMENT_STYLE)); - - oldstate = Fcdr (oldstate); - tem = Fcar (oldstate); - state.comstr_start = - RANGED_INTEGERP (PTRDIFF_MIN, tem, PTRDIFF_MAX) ? XINT (tem) : -1; - oldstate = Fcdr (oldstate); - tem = Fcar (oldstate); - while (!NILP (tem)) /* >= second enclosing sexps. */ - { - Lisp_Object temhd = Fcar (tem); - if (RANGED_INTEGERP (PTRDIFF_MIN, temhd, PTRDIFF_MAX)) - curlevel->last = XINT (temhd); - if (++curlevel == endlevel) - curlevel--; /* error ("Nesting too deep for parser"); */ - curlevel->prev = -1; - curlevel->last = -1; - tem = Fcdr (tem); - } + tem = state->levelstarts; + while (!NILP (tem)) /* >= second enclosing sexps. */ + { + Lisp_Object temhd = Fcar (tem); + if (RANGED_INTEGERP (PTRDIFF_MIN, temhd, PTRDIFF_MAX)) + curlevel->last = XINT (temhd); + if (++curlevel == endlevel) + curlevel--; /* error ("Nesting too deep for parser"); */ + curlevel->prev = -1; + curlevel->last = -1; + tem = Fcdr (tem); } - state.quoted = 0; - mindepth = depth; - curlevel->prev = -1; curlevel->last = -1; - SETUP_SYNTAX_TABLE (prev_from, 1); - temp = FETCH_CHAR (prev_from_byte); - prev_from_syntax = SYNTAX_WITH_FLAGS (temp); - UPDATE_SYNTAX_TABLE_FORWARD (from); + state->quoted = 0; + mindepth = depth; + + SETUP_SYNTAX_TABLE (from, 1); /* Enter the loop at a place appropriate for initial state. */ - if (state.incomment) + if (state->incomment) goto startincomment; - if (state.instring >= 0) + if (state->instring >= 0) { - nofence = state.instring != ST_STRING_STYLE; + nofence = state->instring != ST_STRING_STYLE; if (start_quoted) goto startquotedinstring; goto startinstring; @@ -3255,47 +3190,47 @@ do { prev_from = from; \ while (from < end) { - int syntax; - INC_FROM; - code = prev_from_syntax & 0xff; - - if (from < end - && SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax) + if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax) && (c1 = FETCH_CHAR (from_byte), syntax = SYNTAX_WITH_FLAGS (c1), SYNTAX_FLAGS_COMSTART_SECOND (syntax))) - /* Duplicate code to avoid a complex if-expression - which causes trouble for the SGI compiler. */ { /* Record the comment style we have entered so that only the comment-end sequence of the same style actually terminates the comment section. */ - state.comstyle + state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax); comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) | SYNTAX_FLAGS_COMMENT_NESTED (syntax)); - state.incomment = comnested ? 1 : -1; - state.comstr_start = prev_from; + state->incomment = comnested ? 1 : -1; + state->comstr_start = prev_from; INC_FROM; + prev_from_syntax = Smax; /* the syntax has already been + "used up". */ code = Scomment; } - else if (code == Scomment_fence) - { - /* Record the comment style we have entered so that only - the comment-end sequence of the same style actually - terminates the comment section. */ - state.comstyle = ST_COMMENT_STYLE; - state.incomment = -1; - state.comstr_start = prev_from; - code = Scomment; - } - else if (code == Scomment) - { - state.comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax, 0); - state.incomment = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) ? - 1 : -1); - state.comstr_start = prev_from; - } + else + { + INC_FROM; + code = prev_from_syntax & 0xff; + if (code == Scomment_fence) + { + /* Record the comment style we have entered so that only + the comment-end sequence of the same style actually + terminates the comment section. */ + state->comstyle = ST_COMMENT_STYLE; + state->incomment = -1; + state->comstr_start = prev_from; + code = Scomment; + } + else if (code == Scomment) + { + state->comstyle = SYNTAX_FLAGS_COMMENT_STYLE (prev_from_syntax, 0); + state->incomment = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) ? + 1 : -1); + state->comstr_start = prev_from; + } + } if (SYNTAX_FLAGS_PREFIX (prev_from_syntax)) continue; @@ -3318,7 +3253,24 @@ do { prev_from = from; \ while (from < end) { int symchar = FETCH_CHAR_AS_MULTIBYTE (from_byte); - switch (SYNTAX (symchar)) + + if (SYNTAX_FLAGS_COMSTART_FIRST (prev_from_syntax) + && (syntax = SYNTAX_WITH_FLAGS (symchar), + SYNTAX_FLAGS_COMSTART_SECOND (syntax))) + { + state->comstyle + = SYNTAX_FLAGS_COMMENT_STYLE (syntax, prev_from_syntax); + comnested = (SYNTAX_FLAGS_COMMENT_NESTED (prev_from_syntax) + | SYNTAX_FLAGS_COMMENT_NESTED (syntax)); + state->incomment = comnested ? 1 : -1; + state->comstr_start = prev_from; + INC_FROM; + prev_from_syntax = Smax; + code = Scomment; + goto atcomment; + } + + switch (SYNTAX (symchar)) { case Scharquote: case Sescape: @@ -3340,26 +3292,29 @@ do { prev_from = from; \ case Scomment_fence: /* Can't happen because it's handled above. */ case Scomment: - if (commentstop || boundary_stop) goto done; + atcomment: + if (commentstop || boundary_stop) goto done; startincomment: /* The (from == BEGV) test was to enter the loop in the middle so that we find a 2-char comment ender even if we start in the middle of it. We don't want to do that if we're just at the beginning of the comment (think of (*) ... (*)). */ found = forw_comment (from, from_byte, end, - state.incomment, state.comstyle, - (from == BEGV || from < state.comstr_start + 3) - ? 0 : prev_from_syntax, - &out_charpos, &out_bytepos, &state.incomment); + state->incomment, state->comstyle, + from == BEGV ? 0 : prev_from_syntax, + &out_charpos, &out_bytepos, &state->incomment, + &prev_from_syntax); from = out_charpos; from_byte = out_bytepos; - /* Beware! prev_from and friends are invalid now. - Luckily, the `done' doesn't use them and the INC_FROM - sets them to a sane value without looking at them. */ + /* Beware! prev_from and friends (except prev_from_syntax) + are invalid now. Luckily, the `done' doesn't use them + and the INC_FROM sets them to a sane value without + looking at them. */ if (!found) goto done; INC_FROM; - state.incomment = 0; - state.comstyle = 0; /* reset the comment style */ - if (boundary_stop) goto done; + state->incomment = 0; + state->comstyle = 0; /* reset the comment style */ + prev_from_syntax = Smax; /* For the comment closer */ + if (boundary_stop) goto done; break; case Sopen: @@ -3386,16 +3341,16 @@ do { prev_from = from; \ case Sstring: case Sstring_fence: - state.comstr_start = from - 1; + state->comstr_start = from - 1; if (stopbefore) goto stop; /* this arg means stop at sexp start */ curlevel->last = prev_from; - state.instring = (code == Sstring + state->instring = (code == Sstring ? (FETCH_CHAR_AS_MULTIBYTE (prev_from_byte)) : ST_STRING_STYLE); if (boundary_stop) goto done; startinstring: { - nofence = state.instring != ST_STRING_STYLE; + nofence = state->instring != ST_STRING_STYLE; while (1) { @@ -3409,7 +3364,7 @@ do { prev_from = from; \ /* Check C_CODE here so that if the char has a syntax-table property which says it is NOT a string character, it does not end the string. */ - if (nofence && c == state.instring && c_code == Sstring) + if (nofence && c == state->instring && c_code == Sstring) break; switch (c_code) @@ -3432,7 +3387,7 @@ do { prev_from = from; \ } } string_end: - state.instring = -1; + state->instring = -1; curlevel->prev = curlevel->last; INC_FROM; if (boundary_stop) goto done; @@ -3451,25 +3406,96 @@ do { prev_from = from; \ stop: /* Here if stopping before start of sexp. */ from = prev_from; /* We have just fetched the char that starts it; */ from_byte = prev_from_byte; + prev_from_syntax = prev_prev_from_syntax; goto done; /* but return the position before it. */ endquoted: - state.quoted = 1; + state->quoted = 1; done: - state.depth = depth; - state.mindepth = mindepth; - state.thislevelstart = curlevel->prev; - state.prevlevelstart + state->depth = depth; + state->mindepth = mindepth; + state->thislevelstart = curlevel->prev; + state->prevlevelstart = (curlevel == levelstart) ? -1 : (curlevel - 1)->last; - state.location = from; - state.location_byte = from_byte; - state.levelstarts = Qnil; + state->location = from; + state->location_byte = from_byte; + state->levelstarts = Qnil; while (curlevel > levelstart) - state.levelstarts = Fcons (make_number ((--curlevel)->last), - state.levelstarts); + state->levelstarts = Fcons (make_number ((--curlevel)->last), + state->levelstarts); + state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax) + || state->quoted) ? prev_from_syntax : Smax; immediate_quit = 0; +} + +/* Convert a (lisp) parse state to the internal form used in + scan_sexps_forward. */ +static void +internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state) +{ + Lisp_Object tem; + + if (NILP (external)) + { + state->depth = 0; + state->instring = -1; + state->incomment = 0; + state->quoted = 0; + state->comstyle = 0; /* comment style a by default. */ + state->comstr_start = -1; /* no comment/string seen. */ + state->levelstarts = Qnil; + state->prev_syntax = Smax; + } + else + { + tem = Fcar (external); + if (!NILP (tem)) + state->depth = XINT (tem); + else + state->depth = 0; - *stateptr = state; + external = Fcdr (external); + external = Fcdr (external); + external = Fcdr (external); + tem = Fcar (external); + /* Check whether we are inside string_fence-style string: */ + state->instring = (!NILP (tem) + ? (CHARACTERP (tem) ? XFASTINT (tem) : ST_STRING_STYLE) + : -1); + + external = Fcdr (external); + tem = Fcar (external); + state->incomment = (!NILP (tem) + ? (INTEGERP (tem) ? XINT (tem) : -1) + : 0); + + external = Fcdr (external); + tem = Fcar (external); + state->quoted = !NILP (tem); + + /* if the eighth element of the list is nil, we are in comment + style a. If it is non-nil, we are in comment style b */ + external = Fcdr (external); + external = Fcdr (external); + tem = Fcar (external); + state->comstyle = (NILP (tem) + ? 0 + : (RANGED_INTEGERP (0, tem, ST_COMMENT_STYLE) + ? XINT (tem) + : ST_COMMENT_STYLE)); + + external = Fcdr (external); + tem = Fcar (external); + state->comstr_start = + RANGED_INTEGERP (PTRDIFF_MIN, tem, PTRDIFF_MAX) ? XINT (tem) : -1; + external = Fcdr (external); + tem = Fcar (external); + state->levelstarts = tem; + + external = Fcdr (external); + tem = Fcar (external); + state->prev_syntax = NILP (tem) ? Smax : XINT (tem); + } } DEFUN ("parse-partial-sexp", Fparse_partial_sexp, Sparse_partial_sexp, 2, 6, 0, @@ -3478,6 +3504,7 @@ Parsing stops at TO or when certain criteria are met; point is set to where parsing stops. If fifth arg OLDSTATE is omitted or nil, parsing assumes that FROM is the beginning of a function. + Value is a list of elements describing final state of parsing: 0. depth in parens. 1. character address of start of innermost containing list; nil if none. @@ -3491,16 +3518,22 @@ Value is a list of elements describing final state of parsing: 6. the minimum paren-depth encountered during this scan. 7. style of comment, if any. 8. character address of start of comment or string; nil if not in one. - 9. Intermediate data for continuation of parsing (subject to change). + 9. List of positions of currently open parens, outermost first. +10. When the last position scanned holds the first character of a + (potential) two character construct, the syntax of that position, + otherwise nil. That construct can be a two character comment + delimiter or an Escaped or Char-quoted character. +11..... Possible further internal information used by `parse-partial-sexp'. + If third arg TARGETDEPTH is non-nil, parsing stops if the depth in parentheses becomes equal to TARGETDEPTH. -Fourth arg STOPBEFORE non-nil means stop when come to +Fourth arg STOPBEFORE non-nil means stop when we come to any character that starts a sexp. Fifth arg OLDSTATE is a list like what this function returns. It is used to initialize the state of the parse. Elements number 1, 2, 6 are ignored. -Sixth arg COMMENTSTOP non-nil means stop at the start of a comment. - If it is symbol `syntax-table', stop after the start of a comment or a +Sixth arg COMMENTSTOP non-nil means stop after the start of a comment. + If it is the symbol `syntax-table', stop after the start of a comment or a string, or after end of a comment or a string. */) (Lisp_Object from, Lisp_Object to, Lisp_Object targetdepth, Lisp_Object stopbefore, Lisp_Object oldstate, Lisp_Object commentstop) @@ -3517,15 +3550,17 @@ Sixth arg COMMENTSTOP non-nil means stop at the start of a comment. target = TYPE_MINIMUM (EMACS_INT); /* We won't reach this depth. */ validate_region (&from, &to); + internalize_parse_state (oldstate, &state); scan_sexps_forward (&state, XINT (from), CHAR_TO_BYTE (XINT (from)), XINT (to), - target, !NILP (stopbefore), oldstate, + target, !NILP (stopbefore), (NILP (commentstop) ? 0 : (EQ (commentstop, Qsyntax_table) ? -1 : 1))); SET_PT_BOTH (state.location, state.location_byte); - return Fcons (make_number (state.depth), + return + Fcons (make_number (state.depth), Fcons (state.prevlevelstart < 0 ? Qnil : make_number (state.prevlevelstart), Fcons (state.thislevelstart < 0 @@ -3543,11 +3578,15 @@ Sixth arg COMMENTSTOP non-nil means stop at the start of a comment. ? Qsyntax_table : make_number (state.comstyle)) : Qnil), - Fcons (((state.incomment - || (state.instring >= 0)) - ? make_number (state.comstr_start) - : Qnil), - Fcons (state.levelstarts, Qnil)))))))))); + Fcons (((state.incomment + || (state.instring >= 0)) + ? make_number (state.comstr_start) + : Qnil), + Fcons (state.levelstarts, + Fcons (state.prev_syntax == Smax + ? Qnil + : make_number (state.prev_syntax), + Qnil))))))))))); } void diff --git a/src/sysdep.c b/src/sysdep.c index 3f941c2000c..1227afc8db7 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -19,14 +19,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> -/* If HYBRID_GET_CURRENT_DIR_NAME is defined in conf_post.h, then we - need the following before including unistd.h, in order to pick up - the right prototype for gget_current_dir_name. */ -#ifdef HYBRID_GET_CURRENT_DIR_NAME -#undef get_current_dir_name -#define get_current_dir_name gget_current_dir_name -#endif - #include <execinfo.h> #include "sysstdio.h" #ifdef HAVE_PWD_H @@ -34,12 +26,14 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <grp.h> #endif /* HAVE_PWD_H */ #include <limits.h> +#include <stdlib.h> #include <unistd.h> #include <c-ctype.h> #include <utimens.h> #include "lisp.h" +#include "sheap.h" #include "sysselect.h" #include "blockinput.h" @@ -57,14 +51,19 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ # include <math.h> #endif +#ifdef HAVE_SOCKETS +#include <sys/socket.h> +#include <netdb.h> +#endif /* HAVE_SOCKETS */ + #ifdef WINDOWSNT #define read sys_read #define write sys_write #ifndef STDERR_FILENO #define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE)) #endif -#include <windows.h> -#endif /* not WINDOWSNT */ +#include "w32.h" +#endif /* WINDOWSNT */ #include <sys/types.h> #include <sys/stat.h> @@ -102,7 +101,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "gnutls.h" /* MS-Windows loads GnuTLS at run time, if available; we don't want to do that during startup just to call gnutls_rnd. */ -#if 0x020c00 <= GNUTLS_VERSION_NUMBER && !defined WINDOWSNT +#if defined HAVE_GNUTLS && !defined WINDOWSNT # include <gnutls/crypto.h> #else # define emacs_gnutls_global_init() Qnil @@ -114,7 +113,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* In process.h which conflicts with the local copy. */ #define _P_WAIT 0 int _cdecl _spawnlp (int, const char *, const char *, ...); -int _cdecl _getpid (void); /* The following is needed for O_CLOEXEC, F_SETFD, FD_CLOEXEC, and several prototypes of functions called below. */ #include <sys/socket.h> @@ -137,14 +135,97 @@ static const int baud_convert[] = 1800, 2400, 4800, 9600, 19200, 38400 }; -#if !defined HAVE_GET_CURRENT_DIR_NAME || defined BROKEN_GET_CURRENT_DIR_NAME \ - || (defined HYBRID_GET_CURRENT_DIR_NAME) -/* Return the current working directory. Returns NULL on errors. - Any other returned value must be freed with free. This is used - only when get_current_dir_name is not defined on the system. */ +#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE +# include <sys/personality.h> + +/* Disable address randomization in the current process. Return true + if addresses were randomized but this has been disabled, false + otherwise. */ +bool +disable_address_randomization (void) +{ + int pers = personality (0xffffffff); + if (pers < 0) + return false; + int desired_pers = pers | ADDR_NO_RANDOMIZE; + + /* Call 'personality' twice, to detect buggy platforms like WSL + where 'personality' always returns 0. */ + return (pers != desired_pers + && personality (desired_pers) == pers + && personality (0xffffffff) == desired_pers); +} +#endif + +/* Execute the program in FILE, with argument vector ARGV and environ + ENVP. Return an error number if unsuccessful. This is like execve + except it reenables ASLR in the executed program if necessary, and + on error it returns an error number rather than -1. */ +int +emacs_exec_file (char const *file, char *const *argv, char *const *envp) +{ +#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE + int pers = getenv ("EMACS_HEAP_EXEC") ? personality (0xffffffff) : -1; + bool change_personality = 0 <= pers && pers & ADDR_NO_RANDOMIZE; + if (change_personality) + personality (pers & ~ADDR_NO_RANDOMIZE); +#endif + + execve (file, argv, envp); + int err = errno; + +#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE + if (change_personality) + personality (pers); +#endif + + return err; +} + +/* If FD is not already open, arrange for it to be open with FLAGS. */ +static void +force_open (int fd, int flags) +{ + if (dup2 (fd, fd) < 0 && errno == EBADF) + { + int n = open (NULL_DEVICE, flags); + if (n < 0 || (fd != n && (dup2 (n, fd) < 0 || emacs_close (n) != 0))) + { + emacs_perror (NULL_DEVICE); + exit (EXIT_FAILURE); + } + } +} + +/* Make sure stdin, stdout, and stderr are open to something, so that + their file descriptors are not hijacked by later system calls. */ +void +init_standard_fds (void) +{ + /* Open stdin for *writing*, and stdout and stderr for *reading*. + That way, any attempt to do normal I/O will result in an error, + just as if the files were closed, and the file descriptors will + not be reused by later opens. */ + force_open (STDIN_FILENO, O_WRONLY); + force_open (STDOUT_FILENO, O_RDONLY); + force_open (STDERR_FILENO, O_RDONLY); +} + +/* Return the current working directory. The result should be freed + with 'free'. Return NULL on errors. */ char * -get_current_dir_name (void) +emacs_get_current_dir_name (void) { +# if HAVE_GET_CURRENT_DIR_NAME && !BROKEN_GET_CURRENT_DIR_NAME +# ifdef HYBRID_MALLOC + bool use_libc = bss_sbrk_did_unexec; +# else + bool use_libc = true; +# endif + if (use_libc) + return get_current_dir_name (); +# endif + char *buf; char *pwd = getenv ("PWD"); struct stat dotstat, pwdstat; @@ -192,7 +273,6 @@ get_current_dir_name (void) } return buf; } -#endif /* Discard pending input on all input descriptors. */ @@ -479,15 +559,16 @@ void sys_subshell (void) { #ifdef DOS_NT /* Demacs 1.1.2 91/10/20 Manabu Higashida */ - int st; #ifdef MSDOS + int st; char oldwd[MAXPATHLEN+1]; /* Fixed length is safe on MSDOS. */ #else char oldwd[MAX_UTF8_PATH]; -#endif +#endif /* MSDOS */ +#else /* !DOS_NT */ + int status; #endif pid_t pid; - int status; struct save_signal saved_handlers[5]; char *str = SSDATA (encode_current_directory ()); @@ -689,6 +770,23 @@ unblock_child_signal (sigset_t const *oldset) pthread_sigmask (SIG_SETMASK, oldset, 0); } +/* Block SIGINT. */ +void +block_interrupt_signal (sigset_t *oldset) +{ + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGINT); + pthread_sigmask (SIG_BLOCK, &blocked, oldset); +} + +/* Restore previously saved signal mask. */ +void +restore_signal_mask (sigset_t const *oldset) +{ + pthread_sigmask (SIG_SETMASK, oldset, 0); +} + #endif /* !MSDOS */ /* Saving and restoring the process group of Emacs's terminal. */ @@ -910,7 +1008,9 @@ void init_sys_modes (struct tty_display_info *tty_out) { struct emacs_tty tty; +#ifndef DOS_NT Lisp_Object terminal; +#endif Vtty_erase_char = Qnil; @@ -1409,6 +1509,12 @@ setup_pty (int fd) void init_system_name (void) { + if (!build_details) + { + /* Set system-name to nil so that the build is deterministic. */ + Vsystem_name = Qnil; + return; + } char *hostname_alloc = NULL; char *hostname; #ifndef HAVE_GETHOSTNAME @@ -1506,18 +1612,21 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler) } #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD -static pthread_t main_thread; +pthread_t main_thread_id; #endif /* SIG has arrived at the current process. Deliver it to the main - thread, which should handle it with HANDLER. + thread, which should handle it with HANDLER. (Delivering the + signal to some other thread might not work if the other thread is + about to exit.) If we are on the main thread, handle the signal SIG with HANDLER. Otherwise, redirect the signal to the main thread, blocking it from this thread. POSIX says any thread can receive a signal that is associated with a process, process group, or asynchronous event. - On GNU/Linux that is not true, but for other systems (FreeBSD at - least) it is. */ + On GNU/Linux the main thread typically gets a process signal unless + it's blocked, but other systems (FreeBSD at least) can deliver the + signal to other threads. */ void deliver_process_signal (int sig, signal_handler_t handler) { @@ -1527,13 +1636,13 @@ deliver_process_signal (int sig, signal_handler_t handler) bool on_main_thread = true; #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD - if (! pthread_equal (pthread_self (), main_thread)) + if (! pthread_equal (pthread_self (), main_thread_id)) { sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, sig); pthread_sigmask (SIG_BLOCK, &blocked, 0); - pthread_kill (main_thread, sig); + pthread_kill (main_thread_id, sig); on_main_thread = false; } #endif @@ -1559,12 +1668,12 @@ deliver_thread_signal (int sig, signal_handler_t handler) int old_errno = errno; #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD - if (! pthread_equal (pthread_self (), main_thread)) + if (! pthread_equal (pthread_self (), main_thread_id)) { thread_backtrace_npointers = backtrace (thread_backtrace_buffer, BACKTRACE_LIMIT_MAX); sigaction (sig, &process_fatal_action, 0); - pthread_kill (main_thread, sig); + pthread_kill (main_thread_id, sig); /* Avoid further damage while the main thread is exiting. */ while (1) @@ -1632,6 +1741,9 @@ static unsigned char sigsegv_stack[SIGSTKSZ]; static bool stack_overflow (siginfo_t *siginfo) { + if (!attempt_stack_overflow_recovery) + return false; + /* In theory, a more-accurate heuristic can be obtained by using GNU/Linux pthread_getattr_np along with POSIX pthread_attr_getstack and pthread_attr_getguardsize to find the location and size of the @@ -1684,7 +1796,7 @@ handle_sigsegv (int sig, siginfo_t *siginfo, void *arg) bool fatal = gc_in_progress; #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD - if (!fatal && !pthread_equal (pthread_self (), main_thread)) + if (!fatal && !pthread_equal (pthread_self (), main_thread_id)) fatal = true; #endif @@ -1776,7 +1888,7 @@ init_signals (bool dumping) sigemptyset (&empty_mask); #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD - main_thread = pthread_self (); + main_thread_id = pthread_self (); #endif #if !HAVE_DECL_SYS_SIGLIST && !defined _sys_siglist @@ -2150,8 +2262,8 @@ get_random (void) int i; for (i = 0; i < (FIXNUM_BITS + RAND_BITS - 1) / RAND_BITS; i++) val = (random () ^ (val << RAND_BITS) - ^ (val >> (BITS_PER_EMACS_INT - RAND_BITS))); - val ^= val >> (BITS_PER_EMACS_INT - FIXNUM_BITS); + ^ (val >> (EMACS_INT_WIDTH - RAND_BITS))); + val ^= val >> (EMACS_INT_WIDTH - FIXNUM_BITS); return val & INTMASK; } @@ -2299,7 +2411,6 @@ emacs_fopen (char const *file, char const *mode) switch (*m++) { case '+': omode = O_RDWR; break; - case 'b': bflag = O_BINARY; break; case 't': bflag = O_TEXT; break; default: /* Ignore. */ break; } @@ -2468,7 +2579,7 @@ void emacs_perror (char const *message) { int err = errno; - char const *error_string = strerror (err); + char const *error_string = emacs_strerror (err); char const *command = (initial_argv && initial_argv[0] ? initial_argv[0] : "emacs"); /* Write it out all at once, if it's short; this is less likely to @@ -3021,7 +3132,7 @@ system_process_attributes (Lisp_Object pid) struct timespec tnow, tstart, tboot, telapsed, us_time; double pcpu, pmem; Lisp_Object attrs = Qnil; - Lisp_Object cmd_str, decoded_cmd; + Lisp_Object decoded_cmd; ptrdiff_t count; CHECK_NUMBER_OR_FLOAT (pid); @@ -3078,7 +3189,7 @@ system_process_attributes (Lisp_Object pid) else q = NULL; /* Command name is encoded in locale-coding-system; decode it. */ - cmd_str = make_unibyte_string (cmd, cmdsize); + AUTO_STRING_WITH_LEN (cmd_str, cmd, cmdsize); decoded_cmd = code_convert_string_norecord (cmd_str, Vlocale_coding_system, 0); attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs); @@ -3211,7 +3322,7 @@ system_process_attributes (Lisp_Object pid) sprintf (cmdline, "[%.*s]", cmdsize, cmd); } /* Command line is encoded in locale-coding-system; decode it. */ - cmd_str = make_unibyte_string (q, nread); + AUTO_STRING_WITH_LEN (cmd_str, q, nread); decoded_cmd = code_convert_string_norecord (cmd_str, Vlocale_coding_system, 0); unbind_to (count, Qnil); @@ -3290,7 +3401,7 @@ system_process_attributes (Lisp_Object pid) nread = 0; else { - record_unwind_protect (close_file_unwind, fd); + record_unwind_protect_int (close_file_unwind, fd); nread = emacs_read (fd, &pinfo, sizeof pinfo); } @@ -3346,13 +3457,13 @@ system_process_attributes (Lisp_Object pid) make_float (100.0 / 0x8000 * pinfo.pr_pctmem)), attrs); - decoded_cmd = (code_convert_string_norecord - (build_unibyte_string (pinfo.pr_fname), - Vlocale_coding_system, 0)); + AUTO_STRING (fname, pinfo.pr_fname); + decoded_cmd = code_convert_string_norecord (fname, + Vlocale_coding_system, 0); attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs); - decoded_cmd = (code_convert_string_norecord - (build_unibyte_string (pinfo.pr_psargs), - Vlocale_coding_system, 0)); + AUTO_STRING (psargs, pinfo.pr_psargs); + decoded_cmd = code_convert_string_norecord (psargs, + Vlocale_coding_system, 0); attrs = Fcons (Fcons (Qargs, decoded_cmd), attrs); } unbind_to (count, Qnil); @@ -3417,9 +3528,8 @@ system_process_attributes (Lisp_Object pid) if (gr) attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs); - decoded_comm = (code_convert_string_norecord - (build_unibyte_string (proc.ki_comm), - Vlocale_coding_system, 0)); + AUTO_STRING (comm, proc.ki_comm); + decoded_comm = code_convert_string_norecord (comm, Vlocale_coding_system, 0); attrs = Fcons (Fcons (Qcomm, decoded_comm), attrs); { @@ -3530,10 +3640,9 @@ system_process_attributes (Lisp_Object pid) args[i] = ' '; } - decoded_comm = - (code_convert_string_norecord - (build_unibyte_string (args), - Vlocale_coding_system, 0)); + AUTO_STRING (comm, args); + decoded_comm = code_convert_string_norecord (comm, + Vlocale_coding_system, 0); attrs = Fcons (Fcons (Qargs, decoded_comm), attrs); } @@ -3541,6 +3650,146 @@ system_process_attributes (Lisp_Object pid) return attrs; } +#elif defined DARWIN_OS + +static struct timespec +timeval_to_timespec (struct timeval t) +{ + return make_timespec (t.tv_sec, t.tv_usec * 1000); +} + +static Lisp_Object +make_lisp_timeval (struct timeval t) +{ + return make_lisp_time (timeval_to_timespec (t)); +} + +Lisp_Object +system_process_attributes (Lisp_Object pid) +{ + int proc_id; + int pagesize = getpagesize (); + unsigned long npages; + int fscale; + struct passwd *pw; + struct group *gr; + char *ttyname; + size_t len; + char args[MAXPATHLEN]; + struct timeval starttime; + struct timespec t, now; + struct rusage *rusage; + dev_t tdev; + uid_t uid; + gid_t gid; + + int mib[4] = {CTL_KERN, KERN_PROC, KERN_PROC_PID}; + struct kinfo_proc proc; + size_t proclen = sizeof proc; + + Lisp_Object attrs = Qnil; + Lisp_Object decoded_comm; + + CHECK_NUMBER_OR_FLOAT (pid); + CONS_TO_INTEGER (pid, int, proc_id); + mib[3] = proc_id; + + if (sysctl (mib, 4, &proc, &proclen, NULL, 0) != 0) + return attrs; + + uid = proc.kp_eproc.e_ucred.cr_uid; + attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs); + + block_input (); + pw = getpwuid (uid); + unblock_input (); + if (pw) + attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs); + + gid = proc.kp_eproc.e_pcred.p_svgid; + attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs); + + block_input (); + gr = getgrgid (gid); + unblock_input (); + if (gr) + attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs); + + decoded_comm = (code_convert_string_norecord + (build_unibyte_string (proc.kp_proc.p_comm), + Vlocale_coding_system, 0)); + + attrs = Fcons (Fcons (Qcomm, decoded_comm), attrs); + { + char state[2] = {'\0', '\0'}; + switch (proc.kp_proc.p_stat) + { + case SRUN: + state[0] = 'R'; + break; + + case SSLEEP: + state[0] = 'S'; + break; + + case SZOMB: + state[0] = 'Z'; + break; + + case SSTOP: + state[0] = 'T'; + break; + + case SIDL: + state[0] = 'I'; + break; + } + attrs = Fcons (Fcons (Qstate, build_string (state)), attrs); + } + + attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (proc.kp_eproc.e_ppid)), + attrs); + attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (proc.kp_eproc.e_pgid)), + attrs); + + tdev = proc.kp_eproc.e_tdev; + block_input (); + ttyname = tdev == NODEV ? NULL : devname (tdev, S_IFCHR); + unblock_input (); + if (ttyname) + attrs = Fcons (Fcons (Qtty, build_string (ttyname)), attrs); + + attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (proc.kp_eproc.e_tpgid)), + attrs); + + rusage = proc.kp_proc.p_ru; + if (rusage) + { + attrs = Fcons (Fcons (Qminflt, make_fixnum_or_float (rusage->ru_minflt)), + attrs); + attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (rusage->ru_majflt)), + attrs); + + attrs = Fcons (Fcons (Qutime, make_lisp_timeval (rusage->ru_utime)), + attrs); + attrs = Fcons (Fcons (Qstime, make_lisp_timeval (rusage->ru_stime)), + attrs); + t = timespec_add (timeval_to_timespec (rusage->ru_utime), + timeval_to_timespec (rusage->ru_stime)); + attrs = Fcons (Fcons (Qtime, make_lisp_time (t)), attrs); + } + + starttime = proc.kp_proc.p_starttime; + attrs = Fcons (Fcons (Qnice, make_number (proc.kp_proc.p_nice)), attrs); + attrs = Fcons (Fcons (Qstart, make_lisp_timeval (starttime)), attrs); + + now = current_timespec (); + t = timespec_sub (now, timeval_to_timespec (starttime)); + attrs = Fcons (Fcons (Qetime, make_lisp_time (t)), attrs); + + return attrs; +} + /* The WINDOWSNT implementation is in w32.c. The MSDOS implementation is in dosfns.c. */ #elif !defined (WINDOWSNT) && !defined (MSDOS) @@ -3697,7 +3946,7 @@ str_collate (Lisp_Object s1, Lisp_Object s2, locale_t loc = newlocale (LC_COLLATE_MASK | LC_CTYPE_MASK, SSDATA (locale), 0); if (!loc) - error ("Invalid locale %s: %s", SSDATA (locale), strerror (errno)); + error ("Invalid locale %s: %s", SSDATA (locale), emacs_strerror (errno)); if (! NILP (ignore_case)) for (int i = 1; i < 3; i++) @@ -3728,10 +3977,10 @@ str_collate (Lisp_Object s1, Lisp_Object s2, } # ifndef HAVE_NEWLOCALE if (err) - error ("Invalid locale or string for collation: %s", strerror (err)); + error ("Invalid locale or string for collation: %s", emacs_strerror (err)); # else if (err) - error ("Invalid string for collation: %s", strerror (err)); + error ("Invalid string for collation: %s", emacs_strerror (err)); # endif SAFE_FREE (); @@ -3749,7 +3998,7 @@ str_collate (Lisp_Object s1, Lisp_Object s2, int res, err = errno; errno = 0; - res = w32_compare_strings (SDATA (s1), SDATA (s2), loc, !NILP (ignore_case)); + res = w32_compare_strings (SSDATA (s1), SSDATA (s2), loc, !NILP (ignore_case)); if (errno) error ("Invalid string for collation: %s", strerror (errno)); diff --git a/src/syssignal.h b/src/syssignal.h index 3de83c71759..215aafe314b 100644 --- a/src/syssignal.h +++ b/src/syssignal.h @@ -25,11 +25,14 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ extern void init_signals (bool); extern void block_child_signal (sigset_t *); extern void unblock_child_signal (sigset_t const *); +extern void block_interrupt_signal (sigset_t *); +extern void restore_signal_mask (sigset_t const *); extern void block_tty_out_signal (sigset_t *); extern void unblock_tty_out_signal (sigset_t const *); #ifdef HAVE_PTHREAD #include <pthread.h> +extern pthread_t main_thread_id; /* If defined, asynchronous signals delivered to a non-main thread are forwarded to the main thread. */ #define FORWARD_SIGNAL_TO_MAIN_THREAD diff --git a/src/systhread.c b/src/systhread.c new file mode 100644 index 00000000000..a2c556fd8e3 --- /dev/null +++ b/src/systhread.c @@ -0,0 +1,417 @@ +/* System thread definitions +Copyright (C) 2012-2016 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> +#include <setjmp.h> +#include "lisp.h" + +#ifndef THREADS_ENABLED + +void +sys_mutex_init (sys_mutex_t *m) +{ + *m = 0; +} + +void +sys_mutex_lock (sys_mutex_t *m) +{ +} + +void +sys_mutex_unlock (sys_mutex_t *m) +{ +} + +void +sys_mutex_destroy (sys_mutex_t *m) +{ +} + +void +sys_cond_init (sys_cond_t *c) +{ + *c = 0; +} + +void +sys_cond_wait (sys_cond_t *c, sys_mutex_t *m) +{ +} + +void +sys_cond_signal (sys_cond_t *c) +{ +} + +void +sys_cond_broadcast (sys_cond_t *c) +{ +} + +void +sys_cond_destroy (sys_cond_t *c) +{ +} + +sys_thread_t +sys_thread_self (void) +{ + return 0; +} + +int +sys_thread_equal (sys_thread_t x, sys_thread_t y) +{ + return x == y; +} + +int +sys_thread_create (sys_thread_t *t, const char *name, + thread_creation_function *func, void *datum) +{ + return 0; +} + +void +sys_thread_yield (void) +{ +} + +#elif defined (HAVE_PTHREAD) + +#include <sched.h> + +#ifdef HAVE_SYS_PRCTL_H +#include <sys/prctl.h> +#endif + +void +sys_mutex_init (sys_mutex_t *mutex) +{ + pthread_mutex_init (mutex, NULL); +} + +void +sys_mutex_lock (sys_mutex_t *mutex) +{ + pthread_mutex_lock (mutex); +} + +void +sys_mutex_unlock (sys_mutex_t *mutex) +{ + pthread_mutex_unlock (mutex); +} + +void +sys_mutex_destroy (sys_mutex_t *mutex) +{ + pthread_mutex_destroy (mutex); +} + +void +sys_cond_init (sys_cond_t *cond) +{ + pthread_cond_init (cond, NULL); +} + +void +sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) +{ + pthread_cond_wait (cond, mutex); +} + +void +sys_cond_signal (sys_cond_t *cond) +{ + pthread_cond_signal (cond); +} + +void +sys_cond_broadcast (sys_cond_t *cond) +{ + pthread_cond_broadcast (cond); +} + +void +sys_cond_destroy (sys_cond_t *cond) +{ + pthread_cond_destroy (cond); +} + +sys_thread_t +sys_thread_self (void) +{ + return pthread_self (); +} + +int +sys_thread_equal (sys_thread_t one, sys_thread_t two) +{ + return pthread_equal (one, two); +} + +int +sys_thread_create (sys_thread_t *thread_ptr, const char *name, + thread_creation_function *func, void *arg) +{ + pthread_attr_t attr; + int result = 0; + + if (pthread_attr_init (&attr)) + return 0; + + if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED)) + { + result = pthread_create (thread_ptr, &attr, func, arg) == 0; +#if defined (HAVE_SYS_PRCTL_H) && defined (HAVE_PRCTL) && defined (PR_SET_NAME) + if (result && name != NULL) + prctl (PR_SET_NAME, name); +#endif + } + + pthread_attr_destroy (&attr); + + return result; +} + +void +sys_thread_yield (void) +{ + sched_yield (); +} + +#elif defined (WINDOWSNT) + +#include <windows.h> + +/* Cannot include <process.h> because of the local header by the same + name, sigh. */ +uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); + +/* Mutexes are implemented as critical sections, because they are + faster than Windows mutex objects (implemented in userspace), and + satisfy the requirements, since we only need to synchronize within a + single process. */ +void +sys_mutex_init (sys_mutex_t *mutex) +{ + InitializeCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_lock (sys_mutex_t *mutex) +{ + /* FIXME: What happens if the owning thread exits without releasing + the mutex? According to MSDN, the result is undefined behavior. */ + EnterCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_unlock (sys_mutex_t *mutex) +{ + LeaveCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_destroy (sys_mutex_t *mutex) +{ + /* FIXME: According to MSDN, deleting a critical session that is + owned by a thread leaves the other threads waiting for the + critical session in an undefined state. Posix docs seem to say + the same about pthread_mutex_destroy. Do we need to protect + against such calamities? */ + DeleteCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_cond_init (sys_cond_t *cond) +{ + cond->initialized = false; + cond->wait_count = 0; + /* Auto-reset event for signal. */ + cond->events[CONDV_SIGNAL] = CreateEvent (NULL, FALSE, FALSE, NULL); + /* Manual-reset event for broadcast. */ + cond->events[CONDV_BROADCAST] = CreateEvent (NULL, TRUE, FALSE, NULL); + if (!cond->events[CONDV_SIGNAL] || !cond->events[CONDV_BROADCAST]) + return; + InitializeCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->initialized = true; +} + +void +sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) +{ + DWORD wait_result; + bool last_thread_waiting; + + if (!cond->initialized) + return; + + /* Increment the wait count avoiding race conditions. */ + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->wait_count++; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + /* Release the mutex and wait for either the signal or the broadcast + event. */ + LeaveCriticalSection ((LPCRITICAL_SECTION)mutex); + wait_result = WaitForMultipleObjects (2, cond->events, FALSE, INFINITE); + + /* Decrement the wait count and see if we are the last thread + waiting on the condition variable. */ + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->wait_count--; + last_thread_waiting = + wait_result == WAIT_OBJECT_0 + CONDV_BROADCAST + && cond->wait_count == 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + /* Broadcast uses a manual-reset event, so when the last thread is + released, we must manually reset that event. */ + if (last_thread_waiting) + ResetEvent (cond->events[CONDV_BROADCAST]); + + /* Per the API, re-acquire the mutex. */ + EnterCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_cond_signal (sys_cond_t *cond) +{ + bool threads_waiting; + + if (!cond->initialized) + return; + + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + threads_waiting = cond->wait_count > 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + if (threads_waiting) + SetEvent (cond->events[CONDV_SIGNAL]); +} + +void +sys_cond_broadcast (sys_cond_t *cond) +{ + bool threads_waiting; + + if (!cond->initialized) + return; + + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + threads_waiting = cond->wait_count > 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + if (threads_waiting) + SetEvent (cond->events[CONDV_BROADCAST]); +} + +void +sys_cond_destroy (sys_cond_t *cond) +{ + if (cond->events[CONDV_SIGNAL]) + CloseHandle (cond->events[CONDV_SIGNAL]); + if (cond->events[CONDV_BROADCAST]) + CloseHandle (cond->events[CONDV_BROADCAST]); + + if (!cond->initialized) + return; + + /* FIXME: What if wait_count is non-zero, i.e. there are still + threads waiting on this condition variable? */ + DeleteCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); +} + +sys_thread_t +sys_thread_self (void) +{ + return (sys_thread_t) GetCurrentThreadId (); +} + +int +sys_thread_equal (sys_thread_t one, sys_thread_t two) +{ + return one == two; +} + +static thread_creation_function *thread_start_address; + +/* _beginthread wants a void function, while we are passed a function + that returns a pointer. So we use a wrapper. */ +static void +w32_beginthread_wrapper (void *arg) +{ + (void)thread_start_address (arg); +} + +int +sys_thread_create (sys_thread_t *thread_ptr, const char *name, + thread_creation_function *func, void *arg) +{ + /* FIXME: Do threads that run Lisp require some minimum amount of + stack? Zero here means each thread will get the same amount as + the main program. On GNU/Linux, it seems like the stack is 2MB + by default, overridden by RLIMIT_STACK at program start time. + Not sure what to do with this. See also the comment in + w32proc.c:new_child. */ + const unsigned stack_size = 0; + uintptr_t thandle; + + thread_start_address = func; + + /* We use _beginthread rather than CreateThread because the former + arranges for the thread handle to be automatically closed when + the thread exits, thus preventing handle leaks and/or the need to + track all the threads and close their handles when they exit. + Also, MSDN seems to imply that code which uses CRT _must_ call + _beginthread, although if that is true, we already violate that + rule in many places... */ + thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg); + if (thandle == (uintptr_t)-1L) + return 0; + + /* Kludge alert! We use the Windows thread ID, an unsigned 32-bit + number, as the sys_thread_t type, because that ID is the only + unique identifier of a thread on Windows. But _beginthread + returns a handle of the thread, and there's no easy way of + getting the thread ID given a handle (GetThreadId is available + only since Vista, so we cannot use it portably). Fortunately, + the value returned by sys_thread_create is not used by its + callers; instead, run_thread, which runs in the context of the + new thread, calls sys_thread_self and uses its return value; + sys_thread_self in this implementation calls GetCurrentThreadId. + Therefore, we return some more or less arbitrary value of the + thread ID from this function. */ + *thread_ptr = thandle & 0xFFFFFFFF; + return 1; +} + +void +sys_thread_yield (void) +{ + Sleep (0); +} + +#else + +#error port me + +#endif diff --git a/src/systhread.h b/src/systhread.h new file mode 100644 index 00000000000..ffe2998c23a --- /dev/null +++ b/src/systhread.h @@ -0,0 +1,112 @@ +/* System thread definitions +Copyright (C) 2012-2016 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef SYSTHREAD_H +#define SYSTHREAD_H + +#ifdef THREADS_ENABLED + +#ifdef HAVE_PTHREAD + +#include <pthread.h> + +/* A system mutex is just a pthread mutex. This is only used for the + GIL. */ +typedef pthread_mutex_t sys_mutex_t; + +typedef pthread_cond_t sys_cond_t; + +/* A system thread. */ +typedef pthread_t sys_thread_t; + +#else /* HAVE_PTHREAD */ + +#ifdef WINDOWSNT + +/* This header is indirectly included in every source file. We don't + want to include windows.h in every source file, so we repeat + declarations of the few necessary data types here (under different + names, to avoid conflicts with files that do include + windows.h). */ + +typedef struct { + struct _CRITICAL_SECTION_DEBUG *DebugInfo; + long LockCount; + long RecursionCount; + void *OwningThread; + void *LockSemaphore; + unsigned long SpinCount; +} w32thread_critsect; + +enum { CONDV_SIGNAL = 0, CONDV_BROADCAST = 1, CONDV_MAX = 2 }; + +typedef struct { + /* Count of threads that are waiting for this condition variable. */ + unsigned wait_count; + /* Critical section to protect changes to the count above. */ + w32thread_critsect wait_count_lock; + /* Handles of events used for signal and broadcast. */ + void *events[CONDV_MAX]; + bool initialized; +} w32thread_cond_t; + +typedef w32thread_critsect sys_mutex_t; + +typedef w32thread_cond_t sys_cond_t; + +typedef unsigned long sys_thread_t; + +#else /* !WINDOWSNT */ + +#error port me + +#endif /* WINDOWSNT */ +#endif /* HAVE_PTHREAD */ + +#else /* THREADS_ENABLED */ + +/* For the no-threads case we can simply use dummy definitions. */ +typedef int sys_mutex_t; +typedef int sys_cond_t; +typedef int sys_thread_t; + +#endif /* THREADS_ENABLED */ + +typedef void *(thread_creation_function) (void *); + +extern void sys_mutex_init (sys_mutex_t *); +extern void sys_mutex_lock (sys_mutex_t *); +extern void sys_mutex_unlock (sys_mutex_t *); +extern void sys_mutex_destroy (sys_mutex_t *); + +extern void sys_cond_init (sys_cond_t *); +extern void sys_cond_wait (sys_cond_t *, sys_mutex_t *); +extern void sys_cond_signal (sys_cond_t *); +extern void sys_cond_broadcast (sys_cond_t *); +extern void sys_cond_destroy (sys_cond_t *); + +extern sys_thread_t sys_thread_self (void); +extern int sys_thread_equal (sys_thread_t, sys_thread_t); + +extern int sys_thread_create (sys_thread_t *, const char *, + thread_creation_function *, + void *); + +extern void sys_thread_yield (void); + +#endif /* SYSTHREAD_H */ diff --git a/src/systty.h b/src/systty.h index fbdc6b18373..a53c874699f 100644 --- a/src/systty.h +++ b/src/systty.h @@ -26,7 +26,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <fcntl.h> #endif /* not DOS_NT */ -#include <stdbool.h> #include <sys/ioctl.h> #ifdef HPUX diff --git a/src/term.c b/src/term.c index 43972109655..d691a7aa101 100644 --- a/src/term.c +++ b/src/term.c @@ -23,6 +23,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <errno.h> #include <fcntl.h> #include <stdio.h> +#include <stdlib.h> #include <sys/file.h> #include <sys/time.h> #include <unistd.h> @@ -58,10 +59,7 @@ static int been_here = -1; /* The name of the default console device. */ #ifdef WINDOWSNT -#define DEV_TTY "CONOUT$" #include "w32term.h" -#else -#define DEV_TTY "/dev/tty" #endif static void tty_set_scroll_region (struct frame *f, int start, int stop); @@ -548,8 +546,8 @@ encode_terminal_code (struct glyph *src, int src_len, { if (src->type == COMPOSITE_GLYPH) { - struct composition *cmp IF_LINT (= NULL); - Lisp_Object gstring IF_LINT (= Qnil); + struct composition *cmp UNINIT; + Lisp_Object gstring UNINIT; int i; nbytes = buf - encode_terminal_src; @@ -596,7 +594,7 @@ encode_terminal_code (struct glyph *src, int src_len, continue; if (char_charset (c, charset_list, NULL)) { - if (CHAR_WIDTH (c) == 0 + if (CHARACTER_WIDTH (c) == 0 && i > 0 && COMPOSITION_GLYPH (cmp, i - 1) == '\t') /* Should be left-padded */ { @@ -614,7 +612,7 @@ encode_terminal_code (struct glyph *src, int src_len, else if (! CHAR_GLYPH_PADDING_P (*src)) { GLYPH g; - int c IF_LINT (= 0); + int c UNINIT; Lisp_Object string; string = Qnil; @@ -1496,6 +1494,8 @@ append_glyph (struct it *it) glyph->pixel_width = 1; glyph->u.ch = it->char_to_display; glyph->face_id = it->face_id; + glyph->avoid_cursor_p = it->avoid_cursor_p; + glyph->multibyte_p = it->multibyte_p; glyph->padding_p = i > 0; glyph->charpos = CHARPOS (it->position); glyph->object = it->object; @@ -1627,7 +1627,7 @@ produce_glyphs (struct it *it) if (char_charset (it->char_to_display, charset_list, NULL)) { - it->pixel_width = CHAR_WIDTH (it->char_to_display); + it->pixel_width = CHARACTER_WIDTH (it->char_to_display); it->nglyphs = it->pixel_width; if (it->glyph_row) append_glyph (it); @@ -1692,8 +1692,10 @@ append_composite_glyph (struct it *it) glyph->slice.cmp.to = it->cmp_it.to - 1; } + glyph->avoid_cursor_p = it->avoid_cursor_p; + glyph->multibyte_p = it->multibyte_p; glyph->face_id = it->face_id; - glyph->padding_p = 0; + glyph->padding_p = false; glyph->charpos = CHARPOS (it->position); glyph->object = it->object; if (it->bidi_p) @@ -1776,8 +1778,10 @@ append_glyphless_glyph (struct it *it, int face_id, const char *str) return; glyph->type = CHAR_GLYPH; glyph->pixel_width = 1; + glyph->avoid_cursor_p = it->avoid_cursor_p; + glyph->multibyte_p = it->multibyte_p; glyph->face_id = face_id; - glyph->padding_p = 0; + glyph->padding_p = false; glyph->charpos = CHARPOS (it->position); glyph->object = it->object; if (it->bidi_p) @@ -1818,7 +1822,7 @@ static void produce_glyphless_glyph (struct it *it, Lisp_Object acronym) { int len, face_id = merge_glyphless_glyph_face (it); - char buf[sizeof "\\x" + max (6, (sizeof it->c * CHAR_BIT + 3) / 4)]; + char buf[sizeof "\\x" + max (6, (INT_WIDTH + 3) / 4)]; char const *str = " "; if (it->glyphless_method == GLYPHLESS_DISPLAY_THIN_SPACE) @@ -1829,7 +1833,7 @@ produce_glyphless_glyph (struct it *it, Lisp_Object acronym) } else if (it->glyphless_method == GLYPHLESS_DISPLAY_EMPTY_BOX) { - len = CHAR_WIDTH (it->c); + len = CHARACTER_WIDTH (it->c); if (len == 0) len = 1; else if (len > 4) @@ -1954,8 +1958,6 @@ turn_off_face (struct frame *f, int face_id) struct face *face = FACE_FROM_ID (f, face_id); struct tty_display_info *tty = FRAME_TTY (f); - eassert (face != NULL); - if (tty->TS_exit_attribute_mode) { /* Capability "me" will turn off appearance modes double-bright, @@ -3101,7 +3103,7 @@ tty_menu_activate (tty_menu *menu, int *pane, int *selidx, struct tty_menu_state *state; int statecount, x, y, i; bool leave, onepane; - int result IF_LINT (= 0); + int result UNINIT; int title_faces[4]; /* Face to display the menu title. */ int faces[4], buffers_num_deleted = 0; struct frame *sf = SELECTED_FRAME (); @@ -3755,7 +3757,7 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags, /* Make "Cancel" equivalent to C-g unless FOR_CLICK (which means the menu was invoked with a mouse event as POSITION). */ if (!(menuflags & MENU_FOR_CLICK)) - Fsignal (Qquit, Qnil); + quit (); break; } @@ -3904,7 +3906,7 @@ dissociate_if_controlling_tty (int fd) /* Create a termcap display on the tty device with the given name and type. - If NAME is NULL, then use the controlling tty, i.e., "/dev/tty". + If NAME is NULL, then use the controlling tty, i.e., DEV_TTY. Otherwise NAME should be a path to the tty device file, e.g. "/dev/pts/7". @@ -3915,13 +3917,15 @@ dissociate_if_controlling_tty (int fd) struct terminal * init_tty (const char *name, const char *terminal_type, bool must_succeed) { + struct tty_display_info *tty = NULL; + struct terminal *terminal = NULL; +#ifndef DOS_NT char *area; char **address = &area; int status; - struct tty_display_info *tty = NULL; - struct terminal *terminal = NULL; sigset_t oldset; bool ctty = false; /* True if asked to open controlling tty. */ +#endif if (!terminal_type) maybe_fatal (must_succeed, 0, @@ -3930,8 +3934,10 @@ init_tty (const char *name, const char *terminal_type, bool must_succeed) if (name == NULL) name = DEV_TTY; +#ifndef DOS_NT if (!strcmp (name, DEV_TTY)) ctty = 1; +#endif /* If we already have a terminal on the given device, use that. If all such terminals are suspended, create a new one instead. */ diff --git a/src/termhooks.h b/src/termhooks.h index d21d6ce588a..81e06d9c368 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -158,6 +158,9 @@ enum event_kind SELECTION_CLEAR_EVENT, /* Another X client cleared our selection. */ BUFFER_SWITCH_EVENT, /* A process filter has switched buffers. */ DELETE_WINDOW_EVENT, /* An X client said "delete this window". */ +#ifdef HAVE_NTGUI + END_SESSION_EVENT, /* The user is logging out or shutting down. */ +#endif MENU_BAR_EVENT, /* An event generated by the menu bar. The frame_or_window field's cdr holds the Lisp-level event value. @@ -628,6 +631,11 @@ struct terminal /* Called when a frame's display becomes entirely up to date. */ void (*frame_up_to_date_hook) (struct frame *); + /* Called when buffer flipping becomes unblocked after having + previously been blocked. Redisplay always blocks buffer flips + while it runs. */ + void (*buffer_flipping_unblocked_hook) (struct frame *); + /* Called to delete the device-specific portions of a frame that is on this terminal device. */ @@ -646,6 +654,19 @@ struct terminal void (*delete_terminal_hook) (struct terminal *); }; +INLINE bool +TERMINALP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_TERMINAL); +} + +INLINE struct terminal * +XTERMINAL (Lisp_Object a) +{ + eassert (TERMINALP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + /* Most code should use these functions to set Lisp fields in struct terminal. */ INLINE void diff --git a/src/textprop.c b/src/textprop.c index c4e49d98ebc..7af8c698736 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -2043,18 +2043,19 @@ add_text_properties_from_list (Lisp_Object object, Lisp_Object list, Lisp_Object end-points to NEW_END. */ Lisp_Object -extend_property_ranges (Lisp_Object list, Lisp_Object new_end) +extend_property_ranges (Lisp_Object list, Lisp_Object old_end, Lisp_Object new_end) { Lisp_Object prev = Qnil, head = list; ptrdiff_t max = XINT (new_end); for (; CONSP (list); prev = list, list = XCDR (list)) { - Lisp_Object item, beg, end; + Lisp_Object item, beg; + ptrdiff_t end; item = XCAR (list); beg = XCAR (item); - end = XCAR (XCDR (item)); + end = XINT (XCAR (XCDR (item))); if (XINT (beg) >= max) { @@ -2065,9 +2066,16 @@ extend_property_ranges (Lisp_Object list, Lisp_Object new_end) else XSETCDR (prev, XCDR (list)); } - else if (XINT (end) > max) - /* The end-point is past the end of the new string. */ - XSETCAR (XCDR (item), new_end); + else if ((end == XINT (old_end) && end != max) + || end > max) + { + /* Either the end-point is past the end of the new string, + and we need to discard the properties past the new end, + or the caller is extending the property range, and we + should update all end-points that are on the old end of + the range to reflect that. */ + XSETCAR (XCDR (item), new_end); + } } return head; diff --git a/src/thread.c b/src/thread.c new file mode 100644 index 00000000000..9a1198a0ccb --- /dev/null +++ b/src/thread.c @@ -0,0 +1,997 @@ +/* Threading code. +Copyright (C) 2012-2016 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + + +#include <config.h> +#include <setjmp.h> +#include "lisp.h" +#include "character.h" +#include "buffer.h" +#include "process.h" +#include "coding.h" +#include "syssignal.h" + +static struct thread_state main_thread; + +struct thread_state *current_thread = &main_thread; + +static struct thread_state *all_threads = &main_thread; + +static sys_mutex_t global_lock; + +extern int poll_suppress_count; +extern volatile int interrupt_input_blocked; + + + +/* m_specpdl is set when the thread is created and cleared when the + thread dies. */ +#define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL) + + + +static void +release_global_lock (void) +{ + sys_mutex_unlock (&global_lock); +} + +/* You must call this after acquiring the global lock. + acquire_global_lock does it for you. */ +static void +post_acquire_global_lock (struct thread_state *self) +{ + struct thread_state *prev_thread = current_thread; + + /* Do this early on, so that code below could signal errors (e.g., + unbind_for_thread_switch might) correctly, because we are already + running in the context of the thread pointed by SELF. */ + current_thread = self; + + if (prev_thread != current_thread) + { + /* PREV_THREAD is NULL if the previously current thread + exited. In this case, there is no reason to unbind, and + trying will crash. */ + if (prev_thread != NULL) + unbind_for_thread_switch (prev_thread); + rebind_for_thread_switch (); + + /* Set the new thread's current buffer. This needs to be done + even if it is the same buffer as that of the previous thread, + because of thread-local bindings. */ + set_buffer_internal_2 (current_buffer); + } + + /* We could have been signaled while waiting to grab the global lock + for the first time since this thread was created, in which case + we didn't yet have the opportunity to set up the handlers. Delay + raising the signal in that case (it will be actually raised when + the thread comes here after acquiring the lock the next time). */ + if (!NILP (current_thread->error_symbol) && handlerlist) + { + Lisp_Object sym = current_thread->error_symbol; + Lisp_Object data = current_thread->error_data; + + current_thread->error_symbol = Qnil; + current_thread->error_data = Qnil; + Fsignal (sym, data); + } +} + +static void +acquire_global_lock (struct thread_state *self) +{ + sys_mutex_lock (&global_lock); + post_acquire_global_lock (self); +} + +/* This is called from keyboard.c when it detects that SIGINT + interrupted thread_select before the current thread could acquire + the lock. We must acquire the lock to prevent a thread from + running without holding the global lock, and to avoid repeated + calls to sys_mutex_unlock, which invokes undefined behavior. */ +void +maybe_reacquire_global_lock (void) +{ + if (current_thread->not_holding_lock) + { + struct thread_state *self = current_thread; + + acquire_global_lock (self); + current_thread->not_holding_lock = 0; + } +} + + + +static void +lisp_mutex_init (lisp_mutex_t *mutex) +{ + mutex->owner = NULL; + mutex->count = 0; + sys_cond_init (&mutex->condition); +} + +static int +lisp_mutex_lock (lisp_mutex_t *mutex, int new_count) +{ + struct thread_state *self; + + if (mutex->owner == NULL) + { + mutex->owner = current_thread; + mutex->count = new_count == 0 ? 1 : new_count; + return 0; + } + if (mutex->owner == current_thread) + { + eassert (new_count == 0); + ++mutex->count; + return 0; + } + + self = current_thread; + self->wait_condvar = &mutex->condition; + while (mutex->owner != NULL && (new_count != 0 + || NILP (self->error_symbol))) + sys_cond_wait (&mutex->condition, &global_lock); + self->wait_condvar = NULL; + + if (new_count == 0 && !NILP (self->error_symbol)) + return 1; + + mutex->owner = self; + mutex->count = new_count == 0 ? 1 : new_count; + + return 1; +} + +static int +lisp_mutex_unlock (lisp_mutex_t *mutex) +{ + if (mutex->owner != current_thread) + error ("Cannot unlock mutex owned by another thread"); + + if (--mutex->count > 0) + return 0; + + mutex->owner = NULL; + sys_cond_broadcast (&mutex->condition); + + return 1; +} + +static unsigned int +lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex) +{ + unsigned int result = mutex->count; + + /* Ensured by condvar code. */ + eassert (mutex->owner == current_thread); + + mutex->count = 0; + mutex->owner = NULL; + sys_cond_broadcast (&mutex->condition); + + return result; +} + +static void +lisp_mutex_destroy (lisp_mutex_t *mutex) +{ + sys_cond_destroy (&mutex->condition); +} + +static int +lisp_mutex_owned_p (lisp_mutex_t *mutex) +{ + return mutex->owner == current_thread; +} + + + +DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0, + doc: /* Create a mutex. +A mutex provides a synchronization point for threads. +Only one thread at a time can hold a mutex. Other threads attempting +to acquire it will block until the mutex is available. + +A thread can acquire a mutex any number of times. + +NAME, if given, is used as the name of the mutex. The name is +informational only. */) + (Lisp_Object name) +{ + struct Lisp_Mutex *mutex; + Lisp_Object result; + + if (!NILP (name)) + CHECK_STRING (name); + + mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX); + memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex), + 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex, + mutex)); + mutex->name = name; + lisp_mutex_init (&mutex->mutex); + + XSETMUTEX (result, mutex); + return result; +} + +static void +mutex_lock_callback (void *arg) +{ + struct Lisp_Mutex *mutex = arg; + struct thread_state *self = current_thread; + + if (lisp_mutex_lock (&mutex->mutex, 0)) + post_acquire_global_lock (self); +} + +static void +do_unwind_mutex_lock (void) +{ + current_thread->event_object = Qnil; +} + +DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0, + doc: /* Acquire a mutex. +If the current thread already owns MUTEX, increment the count and +return. +Otherwise, if no thread owns MUTEX, make the current thread own it. +Otherwise, block until MUTEX is available, or until the current thread +is signaled using `thread-signal'. +Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */) + (Lisp_Object mutex) +{ + struct Lisp_Mutex *lmutex; + ptrdiff_t count = SPECPDL_INDEX (); + + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); + + current_thread->event_object = mutex; + record_unwind_protect_void (do_unwind_mutex_lock); + flush_stack_call_func (mutex_lock_callback, lmutex); + return unbind_to (count, Qnil); +} + +static void +mutex_unlock_callback (void *arg) +{ + struct Lisp_Mutex *mutex = arg; + struct thread_state *self = current_thread; + + if (lisp_mutex_unlock (&mutex->mutex)) + post_acquire_global_lock (self); +} + +DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0, + doc: /* Release the mutex. +If this thread does not own MUTEX, signal an error. +Otherwise, decrement the mutex's count. If the count is zero, +release MUTEX. */) + (Lisp_Object mutex) +{ + struct Lisp_Mutex *lmutex; + + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); + + flush_stack_call_func (mutex_unlock_callback, lmutex); + return Qnil; +} + +DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0, + doc: /* Return the name of MUTEX. +If no name was given when MUTEX was created, return nil. */) + (Lisp_Object mutex) +{ + struct Lisp_Mutex *lmutex; + + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); + + return lmutex->name; +} + +void +finalize_one_mutex (struct Lisp_Mutex *mutex) +{ + lisp_mutex_destroy (&mutex->mutex); +} + + + +DEFUN ("make-condition-variable", + Fmake_condition_variable, Smake_condition_variable, + 1, 2, 0, + doc: /* Make a condition variable associated with MUTEX. +A condition variable provides a way for a thread to sleep while +waiting for a state change. + +MUTEX is the mutex associated with this condition variable. +NAME, if given, is the name of this condition variable. The name is +informational only. */) + (Lisp_Object mutex, Lisp_Object name) +{ + struct Lisp_CondVar *condvar; + Lisp_Object result; + + CHECK_MUTEX (mutex); + if (!NILP (name)) + CHECK_STRING (name); + + condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR); + memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond), + 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar, + cond)); + condvar->mutex = mutex; + condvar->name = name; + sys_cond_init (&condvar->cond); + + XSETCONDVAR (result, condvar); + return result; +} + +static void +condition_wait_callback (void *arg) +{ + struct Lisp_CondVar *cvar = arg; + struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex); + struct thread_state *self = current_thread; + unsigned int saved_count; + Lisp_Object cond; + + XSETCONDVAR (cond, cvar); + self->event_object = cond; + saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex); + /* If signaled while unlocking, skip the wait but reacquire the lock. */ + if (NILP (self->error_symbol)) + { + self->wait_condvar = &cvar->cond; + sys_cond_wait (&cvar->cond, &global_lock); + self->wait_condvar = NULL; + } + lisp_mutex_lock (&mutex->mutex, saved_count); + self->event_object = Qnil; + post_acquire_global_lock (self); +} + +DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0, + doc: /* Wait for the condition variable COND to be notified. +COND is the condition variable to wait on. + +The mutex associated with COND must be held when this is called. +It is an error if it is not held. + +This releases the mutex and waits for COND to be notified or for +this thread to be signaled with `thread-signal'. When +`condition-wait' returns, COND's mutex will again be locked by +this thread. */) + (Lisp_Object cond) +{ + struct Lisp_CondVar *cvar; + struct Lisp_Mutex *mutex; + + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); + + mutex = XMUTEX (cvar->mutex); + if (!lisp_mutex_owned_p (&mutex->mutex)) + error ("Condition variable's mutex is not held by current thread"); + + flush_stack_call_func (condition_wait_callback, cvar); + + return Qnil; +} + +/* Used to communicate arguments to condition_notify_callback. */ +struct notify_args +{ + struct Lisp_CondVar *cvar; + int all; +}; + +static void +condition_notify_callback (void *arg) +{ + struct notify_args *na = arg; + struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex); + struct thread_state *self = current_thread; + unsigned int saved_count; + Lisp_Object cond; + + XSETCONDVAR (cond, na->cvar); + saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex); + if (na->all) + sys_cond_broadcast (&na->cvar->cond); + else + sys_cond_signal (&na->cvar->cond); + lisp_mutex_lock (&mutex->mutex, saved_count); + post_acquire_global_lock (self); +} + +DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0, + doc: /* Notify COND, a condition variable. +This wakes a thread waiting on COND. +If ALL is non-nil, all waiting threads are awoken. + +The mutex associated with COND must be held when this is called. +It is an error if it is not held. + +This releases COND's mutex when notifying COND. When +`condition-notify' returns, the mutex will again be locked by this +thread. */) + (Lisp_Object cond, Lisp_Object all) +{ + struct Lisp_CondVar *cvar; + struct Lisp_Mutex *mutex; + struct notify_args args; + + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); + + mutex = XMUTEX (cvar->mutex); + if (!lisp_mutex_owned_p (&mutex->mutex)) + error ("Condition variable's mutex is not held by current thread"); + + args.cvar = cvar; + args.all = !NILP (all); + flush_stack_call_func (condition_notify_callback, &args); + + return Qnil; +} + +DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0, + doc: /* Return the mutex associated with condition variable COND. */) + (Lisp_Object cond) +{ + struct Lisp_CondVar *cvar; + + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); + + return cvar->mutex; +} + +DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0, + doc: /* Return the name of condition variable COND. +If no name was given when COND was created, return nil. */) + (Lisp_Object cond) +{ + struct Lisp_CondVar *cvar; + + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); + + return cvar->name; +} + +void +finalize_one_condvar (struct Lisp_CondVar *condvar) +{ + sys_cond_destroy (&condvar->cond); +} + + + +struct select_args +{ + select_func *func; + int max_fds; + fd_set *rfds; + fd_set *wfds; + fd_set *efds; + struct timespec *timeout; + sigset_t *sigmask; + int result; +}; + +static void +really_call_select (void *arg) +{ + struct select_args *sa = arg; + struct thread_state *self = current_thread; + sigset_t oldset; + + block_interrupt_signal (&oldset); + self->not_holding_lock = 1; + release_global_lock (); + restore_signal_mask (&oldset); + + sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds, + sa->timeout, sa->sigmask); + + block_interrupt_signal (&oldset); + acquire_global_lock (self); + self->not_holding_lock = 0; + restore_signal_mask (&oldset); +} + +int +thread_select (select_func *func, int max_fds, fd_set *rfds, + fd_set *wfds, fd_set *efds, struct timespec *timeout, + sigset_t *sigmask) +{ + struct select_args sa; + + sa.func = func; + sa.max_fds = max_fds; + sa.rfds = rfds; + sa.wfds = wfds; + sa.efds = efds; + sa.timeout = timeout; + sa.sigmask = sigmask; + flush_stack_call_func (really_call_select, &sa); + return sa.result; +} + + + +static void +mark_one_thread (struct thread_state *thread) +{ + struct handler *handler; + Lisp_Object tem; + + mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr); + + mark_stack (thread->m_stack_bottom, thread->stack_top); + + for (handler = thread->m_handlerlist; handler; handler = handler->next) + { + mark_object (handler->tag_or_ch); + mark_object (handler->val); + } + + if (thread->m_current_buffer) + { + XSETBUFFER (tem, thread->m_current_buffer); + mark_object (tem); + } + + mark_object (thread->m_last_thing_searched); + + if (!NILP (thread->m_saved_last_thing_searched)) + mark_object (thread->m_saved_last_thing_searched); +} + +static void +mark_threads_callback (void *ignore) +{ + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + Lisp_Object thread_obj; + + XSETTHREAD (thread_obj, iter); + mark_object (thread_obj); + mark_one_thread (iter); + } +} + +void +mark_threads (void) +{ + flush_stack_call_func (mark_threads_callback, NULL); +} + + + +static void +yield_callback (void *ignore) +{ + struct thread_state *self = current_thread; + + release_global_lock (); + sys_thread_yield (); + acquire_global_lock (self); +} + +DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0, + doc: /* Yield the CPU to another thread. */) + (void) +{ + flush_stack_call_func (yield_callback, NULL); + return Qnil; +} + +static Lisp_Object +invoke_thread_function (void) +{ + int count = SPECPDL_INDEX (); + + Ffuncall (1, ¤t_thread->function); + return unbind_to (count, Qnil); +} + +static Lisp_Object +do_nothing (Lisp_Object whatever) +{ + return whatever; +} + +static void * +run_thread (void *state) +{ + /* Make sure stack_top and m_stack_bottom are properly aligned as GC + expects. */ + max_align_t stack_pos; + + struct thread_state *self = state; + struct thread_state **iter; + + self->m_stack_bottom = self->stack_top = (char *) &stack_pos; + self->thread_id = sys_thread_self (); + + acquire_global_lock (self); + + /* Put a dummy catcher at top-level so that handlerlist is never NULL. + This is important since handlerlist->nextfree holds the freelist + which would otherwise leak every time we unwind back to top-level. */ + handlerlist_sentinel = xzalloc (sizeof (struct handler)); + handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel; + struct handler *c = push_handler (Qunbound, CATCHER); + eassert (c == handlerlist_sentinel); + handlerlist_sentinel->nextfree = NULL; + handlerlist_sentinel->next = NULL; + + /* It might be nice to do something with errors here. */ + internal_condition_case (invoke_thread_function, Qt, do_nothing); + + update_processes_for_thread_death (Fcurrent_thread ()); + + xfree (self->m_specpdl - 1); + self->m_specpdl = NULL; + self->m_specpdl_ptr = NULL; + self->m_specpdl_size = 0; + + { + struct handler *c, *c_next; + for (c = handlerlist_sentinel; c; c = c_next) + { + c_next = c->nextfree; + xfree (c); + } + } + + current_thread = NULL; + sys_cond_broadcast (&self->thread_condvar); + + /* Unlink this thread from the list of all threads. Note that we + have to do this very late, after broadcasting our death. + Otherwise the GC may decide to reap the thread_state object, + leading to crashes. */ + for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread) + ; + *iter = (*iter)->next_thread; + + release_global_lock (); + + return NULL; +} + +void +finalize_one_thread (struct thread_state *state) +{ + sys_cond_destroy (&state->thread_condvar); +} + +DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0, + doc: /* Start a new thread and run FUNCTION in it. +When the function exits, the thread dies. +If NAME is given, it must be a string; it names the new thread. */) + (Lisp_Object function, Lisp_Object name) +{ + sys_thread_t thr; + struct thread_state *new_thread; + Lisp_Object result; + const char *c_name = NULL; + size_t offset = offsetof (struct thread_state, m_stack_bottom); + + /* Can't start a thread in temacs. */ + if (!initialized) + emacs_abort (); + + if (!NILP (name)) + CHECK_STRING (name); + + new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_stack_bottom, + PVEC_THREAD); + memset ((char *) new_thread + offset, 0, + sizeof (struct thread_state) - offset); + + new_thread->function = function; + new_thread->name = name; + new_thread->m_last_thing_searched = Qnil; /* copy from parent? */ + new_thread->m_saved_last_thing_searched = Qnil; + new_thread->m_current_buffer = current_thread->m_current_buffer; + new_thread->error_symbol = Qnil; + new_thread->error_data = Qnil; + new_thread->event_object = Qnil; + + new_thread->m_specpdl_size = 50; + new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size) + * sizeof (union specbinding)); + /* Skip the dummy entry. */ + ++new_thread->m_specpdl; + new_thread->m_specpdl_ptr = new_thread->m_specpdl; + + sys_cond_init (&new_thread->thread_condvar); + + /* We'll need locking here eventually. */ + new_thread->next_thread = all_threads; + all_threads = new_thread; + + if (!NILP (name)) + c_name = SSDATA (ENCODE_UTF_8 (name)); + + if (! sys_thread_create (&thr, c_name, run_thread, new_thread)) + { + /* Restore the previous situation. */ + all_threads = all_threads->next_thread; + error ("Could not start a new thread"); + } + + /* FIXME: race here where new thread might not be filled in? */ + XSETTHREAD (result, new_thread); + return result; +} + +DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0, + doc: /* Return the current thread. */) + (void) +{ + Lisp_Object result; + XSETTHREAD (result, current_thread); + return result; +} + +DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0, + doc: /* Return the name of the THREAD. +The name is the same object that was passed to `make-thread'. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + return tstate->name; +} + +static void +thread_signal_callback (void *arg) +{ + struct thread_state *tstate = arg; + struct thread_state *self = current_thread; + + sys_cond_broadcast (tstate->wait_condvar); + post_acquire_global_lock (self); +} + +DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0, + doc: /* Signal an error in a thread. +This acts like `signal', but arranges for the signal to be raised +in THREAD. If THREAD is the current thread, acts just like `signal'. +This will interrupt a blocked call to `mutex-lock', `condition-wait', +or `thread-join' in the target thread. */) + (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + if (tstate == current_thread) + Fsignal (error_symbol, data); + + /* What to do if thread is already signaled? */ + /* What if error_symbol is Qnil? */ + tstate->error_symbol = error_symbol; + tstate->error_data = data; + + if (tstate->wait_condvar) + flush_stack_call_func (thread_signal_callback, tstate); + + return Qnil; +} + +DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0, + doc: /* Return t if THREAD is alive, or nil if it has exited. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + return thread_alive_p (tstate) ? Qt : Qnil; +} + +DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, + doc: /* Return the object that THREAD is blocking on. +If THREAD is blocked in `thread-join' on a second thread, return that +thread. +If THREAD is blocked in `mutex-lock', return the mutex. +If THREAD is blocked in `condition-wait', return the condition variable. +Otherwise, if THREAD is not blocked, return nil. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + return tstate->event_object; +} + +static void +thread_join_callback (void *arg) +{ + struct thread_state *tstate = arg; + struct thread_state *self = current_thread; + Lisp_Object thread; + + XSETTHREAD (thread, tstate); + self->event_object = thread; + self->wait_condvar = &tstate->thread_condvar; + while (thread_alive_p (tstate) && NILP (self->error_symbol)) + sys_cond_wait (self->wait_condvar, &global_lock); + + self->wait_condvar = NULL; + self->event_object = Qnil; + post_acquire_global_lock (self); +} + +DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0, + doc: /* Wait for THREAD to exit. +This blocks the current thread until THREAD exits or until +the current thread is signaled. +It is an error for a thread to try to join itself. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + if (tstate == current_thread) + error ("Cannot join current thread"); + + if (thread_alive_p (tstate)) + flush_stack_call_func (thread_join_callback, tstate); + + return Qnil; +} + +DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, + doc: /* Return a list of all the live threads. */) + (void) +{ + Lisp_Object result = Qnil; + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + if (thread_alive_p (iter)) + { + Lisp_Object thread; + + XSETTHREAD (thread, iter); + result = Fcons (thread, result); + } + } + + return result; +} + + + +bool +thread_check_current_buffer (struct buffer *buffer) +{ + struct thread_state *iter; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + if (iter == current_thread) + continue; + + if (iter->m_current_buffer == buffer) + return true; + } + + return false; +} + + + +static void +init_main_thread (void) +{ + main_thread.header.size + = PSEUDOVECSIZE (struct thread_state, m_stack_bottom); + XSETPVECTYPE (&main_thread, PVEC_THREAD); + main_thread.m_last_thing_searched = Qnil; + main_thread.m_saved_last_thing_searched = Qnil; + main_thread.name = Qnil; + main_thread.function = Qnil; + main_thread.error_symbol = Qnil; + main_thread.error_data = Qnil; + main_thread.event_object = Qnil; +} + +bool +main_thread_p (void *ptr) +{ + return ptr == &main_thread; +} + +void +init_threads_once (void) +{ + init_main_thread (); +} + +void +init_threads (void) +{ + init_main_thread (); + sys_cond_init (&main_thread.thread_condvar); + sys_mutex_init (&global_lock); + sys_mutex_lock (&global_lock); + current_thread = &main_thread; + main_thread.thread_id = sys_thread_self (); +} + +void +syms_of_threads (void) +{ +#ifndef THREADS_ENABLED + if (0) +#endif + { + defsubr (&Sthread_yield); + defsubr (&Smake_thread); + defsubr (&Scurrent_thread); + defsubr (&Sthread_name); + defsubr (&Sthread_signal); + defsubr (&Sthread_alive_p); + defsubr (&Sthread_join); + defsubr (&Sthread_blocker); + defsubr (&Sall_threads); + defsubr (&Smake_mutex); + defsubr (&Smutex_lock); + defsubr (&Smutex_unlock); + defsubr (&Smutex_name); + defsubr (&Smake_condition_variable); + defsubr (&Scondition_wait); + defsubr (&Scondition_notify); + defsubr (&Scondition_mutex); + defsubr (&Scondition_name); + } + + DEFSYM (Qthreadp, "threadp"); + DEFSYM (Qmutexp, "mutexp"); + DEFSYM (Qcondition_variable_p, "condition-variable-p"); +} diff --git a/src/thread.h b/src/thread.h new file mode 100644 index 00000000000..e6dc668f95a --- /dev/null +++ b/src/thread.h @@ -0,0 +1,299 @@ +/* Thread definitions +Copyright (C) 2012-2016 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#ifndef THREAD_H +#define THREAD_H + +#include "regex.h" + +#ifdef WINDOWSNT +#include <sys/socket.h> +#endif + +#include "sysselect.h" /* FIXME */ +#include "systime.h" /* FIXME */ +#include "systhread.h" + +struct thread_state +{ + struct vectorlike_header header; + + /* The buffer in which the last search was performed, or + Qt if the last search was done in a string; + Qnil if no searching has been done yet. */ + Lisp_Object m_last_thing_searched; +#define last_thing_searched (current_thread->m_last_thing_searched) + + Lisp_Object m_saved_last_thing_searched; +#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched) + + /* The thread's name. */ + Lisp_Object name; + + /* The thread's function. */ + Lisp_Object function; + + /* If non-nil, this thread has been signaled. */ + Lisp_Object error_symbol; + Lisp_Object error_data; + + /* If we are waiting for some event, this holds the object we are + waiting on. */ + Lisp_Object event_object; + + /* m_stack_bottom must be the first non-Lisp field. */ + /* An address near the bottom of the stack. + Tells GC how to save a copy of the stack. */ + char *m_stack_bottom; +#define stack_bottom (current_thread->m_stack_bottom) + + /* An address near the top of the stack. */ + char *stack_top; + + struct catchtag *m_catchlist; +#define catchlist (current_thread->m_catchlist) + + /* Chain of condition handlers currently in effect. + The elements of this chain are contained in the stack frames + of Fcondition_case and internal_condition_case. + When an error is signaled (by calling Fsignal), + this chain is searched for an element that applies. */ + struct handler *m_handlerlist; +#define handlerlist (current_thread->m_handlerlist) + + struct handler *m_handlerlist_sentinel; +#define handlerlist_sentinel (current_thread->m_handlerlist_sentinel) + + /* Current number of specbindings allocated in specpdl. */ + ptrdiff_t m_specpdl_size; +#define specpdl_size (current_thread->m_specpdl_size) + + /* Pointer to beginning of specpdl. */ + union specbinding *m_specpdl; +#define specpdl (current_thread->m_specpdl) + + /* Pointer to first unused element in specpdl. */ + union specbinding *m_specpdl_ptr; +#define specpdl_ptr (current_thread->m_specpdl_ptr) + + /* Depth in Lisp evaluations and function calls. */ + EMACS_INT m_lisp_eval_depth; +#define lisp_eval_depth (current_thread->m_lisp_eval_depth) + + /* This points to the current buffer. */ + struct buffer *m_current_buffer; +#define current_buffer (current_thread->m_current_buffer) + + /* Every call to re_match, etc., must pass &search_regs as the regs + argument unless you can show it is unnecessary (i.e., if re_match + is certainly going to be called again before region-around-match + can be called). + + Since the registers are now dynamically allocated, we need to make + sure not to refer to the Nth register before checking that it has + been allocated by checking search_regs.num_regs. + + The regex code keeps track of whether it has allocated the search + buffer using bits in the re_pattern_buffer. This means that whenever + you compile a new pattern, it completely forgets whether it has + allocated any registers, and will allocate new registers the next + time you call a searching or matching function. Therefore, we need + to call re_set_registers after compiling a new pattern or after + setting the match registers, so that the regex functions will be + able to free or re-allocate it properly. */ + struct re_registers m_search_regs; +#define search_regs (current_thread->m_search_regs) + + /* If non-zero the match data have been saved in saved_search_regs + during the execution of a sentinel or filter. */ + bool m_search_regs_saved; +#define search_regs_saved (current_thread->m_search_regs_saved) + + struct re_registers m_saved_search_regs; +#define saved_search_regs (current_thread->m_saved_search_regs) + + /* This is the string or buffer in which we + are matching. It is used for looking up syntax properties. + + If the value is a Lisp string object, we are matching text in that + string; if it's nil, we are matching text in the current buffer; if + it's t, we are matching text in a C string. */ + Lisp_Object m_re_match_object; +#define re_match_object (current_thread->m_re_match_object) + + /* This member is different from waiting_for_input. + It is used to communicate to a lisp process-filter/sentinel (via the + function Fwaiting_for_user_input_p) whether Emacs was waiting + for user-input when that process-filter was called. + waiting_for_input cannot be used as that is by definition 0 when + lisp code is being evalled. + This is also used in record_asynch_buffer_change. + For that purpose, this must be 0 + when not inside wait_reading_process_output. */ + int m_waiting_for_user_input_p; +#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p) + + /* True while doing kbd input. */ + bool m_waiting_for_input; +#define waiting_for_input (current_thread->m_waiting_for_input) + + /* The OS identifier for this thread. */ + sys_thread_t thread_id; + + /* The condition variable for this thread. This is associated with + the global lock. This thread broadcasts to it when it exits. */ + sys_cond_t thread_condvar; + + /* This thread might be waiting for some condition. If so, this + points to the condition. If the thread is interrupted, the + interrupter should broadcast to this condition. */ + sys_cond_t *wait_condvar; + + /* This thread might have released the global lock. If so, this is + non-zero. When a thread runs outside thread_select with this + flag non-zero, it means it has been interrupted by SIGINT while + in thread_select, and didn't have a chance of acquiring the lock. + It must do so ASAP. */ + int not_holding_lock; + + /* Threads are kept on a linked list. */ + struct thread_state *next_thread; +}; + +INLINE bool +THREADP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_THREAD); +} + +INLINE void +CHECK_THREAD (Lisp_Object x) +{ + CHECK_TYPE (THREADP (x), Qthreadp, x); +} + +INLINE struct thread_state * +XTHREAD (Lisp_Object a) +{ + eassert (THREADP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +/* A mutex in lisp is represented by a system condition variable. + The system mutex associated with this condition variable is the + global lock. + + Using a condition variable lets us implement interruptibility for + lisp mutexes. */ +typedef struct +{ + /* The owning thread, or NULL if unlocked. */ + struct thread_state *owner; + /* The lock count. */ + unsigned int count; + /* The underlying system condition variable. */ + sys_cond_t condition; +} lisp_mutex_t; + +/* A mutex as a lisp object. */ +struct Lisp_Mutex +{ + struct vectorlike_header header; + + /* The name of the mutex, or nil. */ + Lisp_Object name; + + /* The lower-level mutex object. */ + lisp_mutex_t mutex; +}; + +INLINE bool +MUTEXP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_MUTEX); +} + +INLINE void +CHECK_MUTEX (Lisp_Object x) +{ + CHECK_TYPE (MUTEXP (x), Qmutexp, x); +} + +INLINE struct Lisp_Mutex * +XMUTEX (Lisp_Object a) +{ + eassert (MUTEXP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +/* A condition variable as a lisp object. */ +struct Lisp_CondVar +{ + struct vectorlike_header header; + + /* The associated mutex. */ + Lisp_Object mutex; + + /* The name of the condition variable, or nil. */ + Lisp_Object name; + + /* The lower-level condition variable object. */ + sys_cond_t cond; +}; + +INLINE bool +CONDVARP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_CONDVAR); +} + +INLINE void +CHECK_CONDVAR (Lisp_Object x) +{ + CHECK_TYPE (CONDVARP (x), Qcondition_variable_p, x); +} + +INLINE struct Lisp_CondVar * +XCONDVAR (Lisp_Object a) +{ + eassert (CONDVARP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + +extern struct thread_state *current_thread; + +extern void finalize_one_thread (struct thread_state *state); +extern void finalize_one_mutex (struct Lisp_Mutex *); +extern void finalize_one_condvar (struct Lisp_CondVar *); +extern void maybe_reacquire_global_lock (void); + +extern void init_threads_once (void); +extern void init_threads (void); +extern void syms_of_threads (void); +extern bool main_thread_p (void *); + +typedef int select_func (int, fd_set *, fd_set *, fd_set *, + const struct timespec *, const sigset_t *); + +int thread_select (select_func *func, int max_fds, fd_set *rfds, + fd_set *wfds, fd_set *efds, struct timespec *timeout, + sigset_t *sigmask); + +bool thread_check_current_buffer (struct buffer *); + +#endif /* THREAD_H */ diff --git a/src/unexcw.c b/src/unexcw.c index afd5413c644..c0d1bc176a5 100644 --- a/src/unexcw.c +++ b/src/unexcw.c @@ -21,7 +21,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include "unexec.h" #include "lisp.h" -#include <string.h> #include <stdio.h> #include <fcntl.h> #include <a.out.h> @@ -30,10 +29,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #define DOTEXE ".exe" -extern void report_sheap_usage (int); - -extern int bss_sbrk_did_unexec; - /* ** header for Windows executable files */ @@ -151,7 +146,7 @@ fixup_executable (int fd) assert (ret == my_edata - (char *) start_address); ++found_data; if (debug_unexcw) - printf (" .data, mem start %#lx mem length %d\n", + printf (" .data, mem start %#lx mem length %td\n", start_address, my_edata - (char *) start_address); if (debug_unexcw) printf (" .data, file start %d file length %d\n", @@ -217,7 +212,7 @@ fixup_executable (int fd) sizeof (exe_header->section_header[i])); assert (ret == sizeof (exe_header->section_header[i])); if (debug_unexcw) - printf (" seek to %ld, write %d\n", + printf (" seek to %ld, write %zu\n", (long) ((char *) &exe_header->section_header[i] - (char *) exe_header), sizeof (exe_header->section_header[i])); @@ -232,7 +227,7 @@ fixup_executable (int fd) my_endbss - (char *) start_address); assert (ret == (my_endbss - (char *) start_address)); if (debug_unexcw) - printf (" .bss, mem start %#lx mem length %d\n", + printf (" .bss, mem start %#lx mem length %td\n", start_address, my_endbss - (char *) start_address); if (debug_unexcw) printf (" .bss, file start %d file length %d\n", @@ -276,14 +271,12 @@ unexec (const char *outfile, const char *infile) int ret; int ret2; - report_sheap_usage (1); - infile = add_exe_suffix_if_necessary (infile, infile_buffer); outfile = add_exe_suffix_if_necessary (outfile, outfile_buffer); - fd_in = emacs_open (infile, O_RDONLY | O_BINARY, 0); + fd_in = emacs_open (infile, O_RDONLY, 0); assert (fd_in >= 0); - fd_out = emacs_open (outfile, O_RDWR | O_TRUNC | O_CREAT | O_BINARY, 0755); + fd_out = emacs_open (outfile, O_RDWR | O_TRUNC | O_CREAT, 0755); assert (fd_out >= 0); for (;;) { @@ -302,9 +295,7 @@ unexec (const char *outfile, const char *infile) ret = emacs_close (fd_in); assert (ret == 0); - bss_sbrk_did_unexec = 1; fixup_executable (fd_out); - bss_sbrk_did_unexec = 0; ret = emacs_close (fd_out); assert (ret == 0); diff --git a/src/unexelf.c b/src/unexelf.c index 068d268808a..58c9244c3a5 100644 --- a/src/unexelf.c +++ b/src/unexelf.c @@ -66,9 +66,6 @@ what you give them. Help stamp out software-hoarding! */ #include <sys/elf_mips.h> #include <sym.h> #endif /* _SYSTYPE_SYSV */ -#if __sgi -#include <syms.h> /* for HDRR declaration */ -#endif /* __sgi */ #ifndef MAP_ANON #ifdef MAP_ANONYMOUS @@ -329,7 +326,11 @@ unexec (const char *new_name, const char *old_name) if (old_bss_index == -1) fatal ("no bss section found"); +#ifdef HAVE_SBRK new_break = sbrk (0); +#else + new_break = (byte *) old_bss_addr + old_bss_size; +#endif new_bss_addr = (ElfW (Addr)) new_break; bss_size_growth = new_bss_addr - old_bss_addr; new_data2_size = bss_size_growth; @@ -461,29 +462,6 @@ unexec (const char *new_name, const char *old_name) || !strcmp (old_section_names + new_shdr->sh_name, ".sdata") || !strcmp (old_section_names + new_shdr->sh_name, ".lit4") || !strcmp (old_section_names + new_shdr->sh_name, ".lit8") - /* The conditional bit below was in Oliva's original code - (1999-08-25) and seems to have been dropped by mistake - subsequently. It prevents a crash at startup under X in - `IRIX64 6.5 6.5.17m', whether compiled on that release or - an earlier one. It causes no trouble on the other ELF - platforms I could test (Irix 6.5.15m, Solaris 8, Debian - Potato x86, Debian Woody SPARC); however, it's reported - to cause crashes under some version of GNU/Linux. It's - not yet clear what's changed in that Irix version to - cause the problem, or why the fix sometimes fails under - GNU/Linux. There's probably no good reason to have - something Irix-specific here, but this will have to do - for now. IRIX6_5 is the most specific macro we have to - test. -- fx 2002-10-01 - - The issue _looks_ as though it's gone away on 6.5.18m, - but maybe it's still lurking, to be triggered by some - change in the binary. It appears to concern the dynamic - loader, but I never got anywhere with an SGI support call - seeking clues. -- fx 2002-11-29. */ -#ifdef IRIX6_5 - || !strcmp (old_section_names + new_shdr->sh_name, ".got") -#endif || !strcmp (old_section_names + new_shdr->sh_name, ".sdata1") || !strcmp (old_section_names + new_shdr->sh_name, ".data1")) src = (caddr_t) old_shdr->sh_addr; @@ -517,53 +495,6 @@ unexec (const char *new_name, const char *old_name) phdr->cbExtOffset += diff; } #endif /* __alpha__ || _SYSTYPE_SYSV */ - -#if __sgi - /* Adjust the HDRR offsets in .mdebug and copy the - line data if it's in its usual 'hole' in the object. - Makes the new file debuggable with dbx. - patches up two problems: the absolute file offsets - in the HDRR record of .mdebug (see /usr/include/syms.h), and - the ld bug that gets the line table in a hole in the - elf file rather than in the .mdebug section proper. - David Anderson. davea@sgi.com Jan 16,1994. */ - if (strcmp (old_section_names + new_shdr->sh_name, ".mdebug") == 0 - && new_shdr->sh_offset - old_shdr->sh_offset != 0) - { -#define MDEBUGADJUST(__ct,__fileaddr) \ - if (n_phdrr->__ct > 0) \ - { \ - n_phdrr->__fileaddr += movement; \ - } - - HDRR *o_phdrr = (HDRR *) ((byte *) old_base + old_shdr->sh_offset); - HDRR *n_phdrr = (HDRR *) ((byte *) new_base + new_shdr->sh_offset); - ptrdiff_t movement = new_shdr->sh_offset - old_shdr->sh_offset; - - MDEBUGADJUST (idnMax, cbDnOffset); - MDEBUGADJUST (ipdMax, cbPdOffset); - MDEBUGADJUST (isymMax, cbSymOffset); - MDEBUGADJUST (ioptMax, cbOptOffset); - MDEBUGADJUST (iauxMax, cbAuxOffset); - MDEBUGADJUST (issMax, cbSsOffset); - MDEBUGADJUST (issExtMax, cbSsExtOffset); - MDEBUGADJUST (ifdMax, cbFdOffset); - MDEBUGADJUST (crfd, cbRfdOffset); - MDEBUGADJUST (iextMax, cbExtOffset); - /* The Line Section, being possible off in a hole of the object, - requires special handling. */ - if (n_phdrr->cbLine > 0) - { - n_phdrr->cbLineOffset += movement; - - if (o_phdrr->cbLineOffset > (old_shdr->sh_offset - + old_shdr->sh_size)) - /* If not covered by section, it hasn't yet been copied. */ - memcpy (n_phdrr->cbLineOffset + new_base, - o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); - } - } -#endif /* __sgi */ } /* Update the symbol values of _edata and _end. */ @@ -665,9 +596,6 @@ unexec (const char *new_name, const char *old_name) || !strcmp (old_section_names + shdr->sh_name, ".sdata") || !strcmp (old_section_names + shdr->sh_name, ".lit4") || !strcmp (old_section_names + shdr->sh_name, ".lit8") -#ifdef IRIX6_5 /* see above */ - || !strcmp (old_section_names + shdr->sh_name, ".got") -#endif || !strcmp (old_section_names + shdr->sh_name, ".sdata1") || !strcmp (old_section_names + shdr->sh_name, ".data1")) { diff --git a/src/unexmacosx.c b/src/unexmacosx.c index f755f7fafd9..5584e693f75 100644 --- a/src/unexmacosx.c +++ b/src/unexmacosx.c @@ -85,17 +85,16 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ be changed accordingly. */ -/* config.h #define:s malloc/realloc/free and then includes stdlib.h. - We want the undefined versions, but if config.h includes stdlib.h - with the #define:s in place, the prototypes will be wrong and we get - warnings. To prevent that, include stdlib.h before config.h. */ - -#include <stdlib.h> #include <config.h> + +/* Although <config.h> redefines malloc to unexec_malloc, etc., this + file wants stdlib.h to declare the originals. */ #undef malloc #undef realloc #undef free +#include <stdlib.h> + #include "unexec.h" #include "lisp.h" diff --git a/src/unexw32.c b/src/unexw32.c index 15aa7263bf8..54224858a85 100644 --- a/src/unexw32.c +++ b/src/unexw32.c @@ -50,10 +50,6 @@ extern char *my_begbss_static; /* Basically, our "initialized" flag. */ BOOL using_dynamic_heap = FALSE; -int open_input_file (file_data *p_file, char *name); -int open_output_file (file_data *p_file, char *name, unsigned long size); -void close_file_data (file_data *p_file); - void get_section_info (file_data *p_file); void copy_executable_and_dump_data (file_data *, file_data *); void dump_bss_and_heap (file_data *p_infile, file_data *p_outfile); @@ -81,14 +77,17 @@ DWORD_PTR extra_bss_size_static = 0; #define _start __start #endif +extern void mainCRTStartup (void); + /* Startup code for running on NT. When we are running as the dumped version, we need to bootstrap our heap and .bss section into our address space before we can actually hand off control to the startup code supplied by NT (primarily because that code relies upon malloc ()). */ +void _start (void); + void _start (void) { - extern void mainCRTStartup (void); #if 1 /* Give us a way to debug problems with crashes on startup when @@ -205,7 +204,7 @@ close_file_data (file_data *p_file) /* Return pointer to section header for named section. */ IMAGE_SECTION_HEADER * -find_section (char * name, IMAGE_NT_HEADERS * nt_header) +find_section (const char * name, IMAGE_NT_HEADERS * nt_header) { PIMAGE_SECTION_HEADER section; int i; @@ -214,7 +213,7 @@ find_section (char * name, IMAGE_NT_HEADERS * nt_header) for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) { - if (strcmp (section->Name, name) == 0) + if (strcmp ((char *)section->Name, name) == 0) return section; section++; } @@ -249,9 +248,10 @@ rva_to_section (DWORD_PTR rva, IMAGE_NT_HEADERS * nt_header) return NULL; } +#if 0 /* unused */ /* Return pointer to section header for section containing the given offset in its raw data area. */ -IMAGE_SECTION_HEADER * +static IMAGE_SECTION_HEADER * offset_to_section (DWORD_PTR offset, IMAGE_NT_HEADERS * nt_header) { PIMAGE_SECTION_HEADER section; @@ -268,11 +268,12 @@ offset_to_section (DWORD_PTR offset, IMAGE_NT_HEADERS * nt_header) } return NULL; } +#endif /* Return offset to an object in dst, given offset in src. We assume there is at least one section in both src and dst images, and that the some sections may have been added to dst (after sections in src). */ -DWORD_PTR +static DWORD_PTR relocate_offset (DWORD_PTR offset, IMAGE_NT_HEADERS * src_nt_header, IMAGE_NT_HEADERS * dst_nt_header) @@ -306,9 +307,6 @@ relocate_offset (DWORD_PTR offset, (dst_section->PointerToRawData - src_section->PointerToRawData); } -#define OFFSET_TO_RVA(offset, section) \ - ((section)->VirtualAddress + ((DWORD_PTR)(offset) - (section)->PointerToRawData)) - #define RVA_TO_OFFSET(rva, section) \ ((section)->PointerToRawData + ((DWORD_PTR)(rva) - (section)->VirtualAddress)) @@ -318,15 +316,20 @@ relocate_offset (DWORD_PTR offset, /* Convert address in executing image to RVA. */ #define PTR_TO_RVA(ptr) ((DWORD_PTR)(ptr) - (DWORD_PTR) GetModuleHandle (NULL)) -#define RVA_TO_PTR(var,section,filedata) \ - ((unsigned char *)(RVA_TO_OFFSET (var,section) + (filedata).file_base)) - #define PTR_TO_OFFSET(ptr, pfile_data) \ ((unsigned char *)(ptr) - (pfile_data)->file_base) #define OFFSET_TO_PTR(offset, pfile_data) \ ((pfile_data)->file_base + (DWORD_PTR)(offset)) +#if 0 /* unused */ +#define OFFSET_TO_RVA(offset, section) \ + ((section)->VirtualAddress + ((DWORD_PTR)(offset) - (section)->PointerToRawData)) + +#define RVA_TO_PTR(var,section,filedata) \ + ((unsigned char *)(RVA_TO_OFFSET (var,section) + (filedata).file_base)) +#endif + /* Flip through the executable and cache the info necessary for dumping. */ void @@ -462,6 +465,7 @@ get_section_info (file_data *p_infile) bss_start = min (bss_start, bss_start_static); bss_size = max (my_endbss, my_endbss_static) - bss_start; bss_section_static = 0; + extra_bss_size = max (extra_bss_size, extra_bss_size_static); extra_bss_size_static = 0; } } diff --git a/src/vm-limit.c b/src/vm-limit.c index d32050fd015..d53eecae3d3 100644 --- a/src/vm-limit.c +++ b/src/vm-limit.c @@ -51,9 +51,16 @@ char data_start[1] = { 1 }; # endif #endif -/* From gmalloc.c. */ -extern void (* __after_morecore_hook) (void); +#ifdef HAVE_MALLOC_H +# include <malloc.h> +#endif +#ifndef DOUG_LEA_MALLOC +# ifndef __MALLOC_HOOK_VOLATILE +# define __MALLOC_HOOK_VOLATILE volatile +# endif extern void *(*__morecore) (ptrdiff_t); +extern void (*__MALLOC_HOOK_VOLATILE __after_morecore_hook) (void); +#endif /* From ralloc.c. */ #ifdef REL_ALLOC diff --git a/src/w32.c b/src/w32.c index 7c57693cf3d..59dc685710e 100644 --- a/src/w32.c +++ b/src/w32.c @@ -21,6 +21,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ Geoff Voelker (voelker@cs.washington.edu) 7-29-94 */ +#define DEFER_MS_W32_H +#include <config.h> + #include <mingw_time.h> #include <stddef.h> /* for offsetof */ #include <stdlib.h> @@ -37,9 +40,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <sys/utime.h> #include <math.h> -/* must include CRT headers *before* config.h */ +/* Include (most) CRT headers *before* ms-w32.h. */ +#include <ms-w32.h> -#include <config.h> +#include <string.h> /* for strerror, needed by sys_strerror */ #include <mbstring.h> /* for _mbspbrk, _mbslwr, _mbsrchr, ... */ #undef access @@ -66,19 +70,30 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #undef localtime +char *sys_ctime (const time_t *); +int sys_chdir (const char *); +int sys_creat (const char *, int); +FILE *sys_fopen (const char *, const char *); +int sys_mkdir (const char *); +int sys_open (const char *, int, int); +int sys_rename (char const *, char const *); +int sys_rmdir (const char *); +int sys_close (int); +int sys_dup2 (int, int); +int sys_read (int, char *, unsigned int); +int sys_write (int, const void *, unsigned int); +struct tm *sys_localtime (const time_t *); + +#ifdef HAVE_MODULES +extern void dynlib_reset_last_error (void); +#endif + #include "lisp.h" #include "epaths.h" /* for PATH_EXEC */ #include <pwd.h> #include <grp.h> -/* MinGW64 defines these in its _mingw.h. */ -#ifndef _ANONYMOUS_UNION -# define _ANONYMOUS_UNION -#endif -#ifndef _ANONYMOUS_STRUCT -# define _ANONYMOUS_STRUCT -#endif #include <windows.h> /* Some versions of compiler define MEMORYSTATUSEX, some don't, so we use a different name to avoid compilation problems. */ @@ -227,6 +242,7 @@ typedef struct _REPARSE_DATA_BUFFER { #include <wincrypt.h> #include <c-strcase.h> +#include <utimens.h> /* for fdutimens */ #include "w32.h" #include <dirent.h> @@ -246,7 +262,6 @@ typedef struct _REPARSE_DATA_BUFFER { typedef HRESULT (WINAPI * ShGetFolderPath_fn) (IN HWND, IN int, IN HANDLE, IN DWORD, OUT char *); -void globals_of_w32 (void); static DWORD get_rid (PSID); static int is_symlink (const char *); static char * chase_symlinks (const char *); @@ -257,11 +272,9 @@ static BOOL WINAPI revert_to_self (void); static int sys_access (const char *, int); extern void *e_malloc (size_t); extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - struct timespec *, void *); + const struct timespec *, const sigset_t *); extern int sys_dup (int); - - /* Initialization states. @@ -312,6 +325,7 @@ static BOOL g_b_init_set_named_security_info_a; static BOOL g_b_init_get_adapters_info; BOOL g_b_init_compare_string_w; +BOOL g_b_init_debug_break_process; /* BEGIN: Wrapper functions around OpenProcessToken @@ -512,6 +526,8 @@ static Lisp_Object ltime (ULONGLONG); /* Get total user and system times for get-internal-run-time. Returns a list of integers if the times are provided by the OS (NT derivatives), otherwise it returns the result of current-time. */ +Lisp_Object w32_get_internal_run_time (void); + Lisp_Object w32_get_internal_run_time (void) { @@ -2138,17 +2154,40 @@ w32_init_random (void *buf, ptrdiff_t buflen) return -1; } +/* MS-Windows 'rand' produces separate identical series for each + thread, so we replace it with our version. */ + +/* Algorithm AS183: An Efficient and Portable Pseudo-random Number + Generator, by B.A. Wichmann, I.D. Hill. AS, v31, No. 2 (1982). */ +static int ix = 3172, iy = 9814, iz = 20125; +#define RAND_MAX_X 30269 +#define RAND_MAX_Y 30307 +#define RAND_MAX_Z 30323 + +static int +rand_as183 (void) +{ + ix = (171 * ix) % RAND_MAX_X; + iy = (172 * iy) % RAND_MAX_Y; + iz = (170 * iz) % RAND_MAX_Z; + + return (ix + iy + iz) & 0x7fff; +} + int random (void) { - /* rand () on NT gives us 15 random bits...hack together 30 bits. */ - return ((rand () << 15) | rand ()); + /* rand_as183 () gives us 15 random bits...hack together 30 bits. */ + return ((rand_as183 () << 15) | rand_as183 ()); } void srandom (int seed) { srand (seed); + ix = rand () % RAND_MAX_X; + iy = rand () % RAND_MAX_Y; + iz = rand () % RAND_MAX_Z; } /* Return the maximum length in bytes of a multibyte character @@ -2499,13 +2538,42 @@ sys_putenv (char *str) return unsetenv (str); } + if (strncmp (str, "TZ=<", 4) == 0) + { + /* MS-Windows does not support POSIX.1-2001 angle-bracket TZ + abbreviation syntax. Convert to POSIX.1-1988 syntax if possible, + and to the undocumented placeholder "ZZZ" otherwise. */ + bool supported_abbr = true; + for (char *p = str + 4; *p; p++) + { + if (('0' <= *p && *p <= '9') || *p == '-' || *p == '+') + supported_abbr = false; + else if (*p == '>') + { + ptrdiff_t abbrlen; + if (supported_abbr) + { + abbrlen = p - (str + 4); + memmove (str + 3, str + 4, abbrlen); + } + else + { + abbrlen = 3; + memset (str + 3, 'Z', abbrlen); + } + memmove (str + 3 + abbrlen, p + 1, strlen (p)); + break; + } + } + } + return _putenv (str); } #define REG_ROOT "SOFTWARE\\GNU\\Emacs" LPBYTE -w32_get_resource (char *key, LPDWORD lpdwtype) +w32_get_resource (const char *key, LPDWORD lpdwtype) { LPBYTE lpvalue; HKEY hrootkey = NULL; @@ -2614,8 +2682,8 @@ init_environment (char ** argv) static const struct env_entry { - char * name; - char * def_value; + const char * name; + const char * def_value; } dflt_envvars[] = { /* If the default value is NULL, we will use the value from the @@ -2775,14 +2843,14 @@ init_environment (char ** argv) { /* If not found in any directory, use the default as the last resort. */ - lpval = env_vars[i].def_value; + lpval = (char *)env_vars[i].def_value; dwType = REG_EXPAND_SZ; } } while (*pstart); } else { - lpval = env_vars[i].def_value; + lpval = (char *)env_vars[i].def_value; dwType = REG_EXPAND_SZ; } if (strcmp (env_vars[i].name, "HOME") == 0 && !appdata) @@ -2803,7 +2871,7 @@ init_environment (char ** argv) if (dwType == REG_EXPAND_SZ) ExpandEnvironmentStrings ((LPSTR) lpval, buf1, sizeof (buf1)); else if (dwType == REG_SZ) - strcpy (buf1, lpval); + strcpy (buf1, (char *)lpval); if (dwType == REG_EXPAND_SZ || dwType == REG_SZ) { _snprintf (buf2, sizeof (buf2)-1, "%s=%s", env_vars[i].name, @@ -2832,12 +2900,29 @@ init_environment (char ** argv) The same applies to COMSPEC. */ { char ** envp; + const char *path = "PATH="; + int path_len = strlen (path); + const char *comspec = "COMSPEC="; + int comspec_len = strlen (comspec); for (envp = environ; *envp; envp++) - if (_strnicmp (*envp, "PATH=", 5) == 0) - memcpy (*envp, "PATH=", 5); - else if (_strnicmp (*envp, "COMSPEC=", 8) == 0) - memcpy (*envp, "COMSPEC=", 8); + if (_strnicmp (*envp, path, path_len) == 0) + memcpy (*envp, path, path_len); + else if (_strnicmp (*envp, comspec, comspec_len) == 0) + memcpy (*envp, comspec, comspec_len); + + /* Make the same modification to `process-environment' which has + already been initialized in set_initial_environment. */ + for (Lisp_Object env = Vprocess_environment; CONSP (env); env = XCDR (env)) + { + Lisp_Object entry = XCAR (env); + if (_strnicmp (SDATA (entry), path, path_len) == 0) + for (int i = 0; i < path_len; i++) + SSET (entry, i, path[i]); + else if (_strnicmp (SDATA (entry), comspec, comspec_len) == 0) + for (int i = 0; i < comspec_len; i++) + SSET (entry, i, comspec[i]); + } } /* Remember the initial working directory for getcwd. */ @@ -2978,7 +3063,7 @@ char * sys_ctime (const time_t *t) { char *str = (char *) ctime (t); - return (str ? str : "Sun Jan 01 00:00:00 1970"); + return (str ? str : (char *)"Sun Jan 01 00:00:00 1970"); } /* Emulate sleep...we could have done this with a define, but that @@ -3242,6 +3327,8 @@ is_fat_volume (const char * name, const char ** pPath) /* Convert all slashes in a filename to backslashes, and map filename to a valid 8.3 name if necessary. The result is a pointer to a static buffer, so CAVEAT EMPTOR! */ +const char *map_w32_filename (const char *, const char **); + const char * map_w32_filename (const char * name, const char ** pPath) { @@ -4447,7 +4534,7 @@ sys_rename_replace (const char *oldname, const char *newname, BOOL force) { /* Force temp name to require a manufactured 8.3 alias - this seems to make the second rename work properly. */ - sprintf (p, "_.%s.%u", o, i); + sprintf (p, "_.%s.%d", o, i); i++; result = rename (oldname_a, temp_a); } @@ -4875,6 +4962,8 @@ get_file_owner_and_group (PSECURITY_DESCRIPTOR psd, struct stat *st) } /* Return non-zero if NAME is a potentially slow filesystem. */ +int is_slow_fs (const char *); + int is_slow_fs (const char *name) { @@ -7219,6 +7308,10 @@ int (PASCAL *pfn_recvfrom) (SOCKET s, char * buf, int len, int flags, int (PASCAL *pfn_sendto) (SOCKET s, const char * buf, int len, int flags, const struct sockaddr * to, int tolen); +int (PASCAL *pfn_getaddrinfo) (const char *, const char *, + const struct addrinfo *, struct addrinfo **); +void (PASCAL *pfn_freeaddrinfo) (struct addrinfo *); + /* SetHandleInformation is only needed to make sockets non-inheritable. */ BOOL (WINAPI *pfn_SetHandleInformation) (HANDLE object, DWORD mask, DWORD flags); #ifndef HANDLE_FLAG_INHERIT @@ -7228,6 +7321,8 @@ BOOL (WINAPI *pfn_SetHandleInformation) (HANDLE object, DWORD mask, DWORD flags) HANDLE winsock_lib; static int winsock_inuse; +BOOL term_winsock (void); + BOOL term_winsock (void) { @@ -7301,6 +7396,16 @@ init_winsock (int load_now) LOAD_PROC (sendto); #undef LOAD_PROC + /* Try loading functions not available before XP. */ + pfn_getaddrinfo = (void *) GetProcAddress (winsock_lib, "getaddrinfo"); + pfn_freeaddrinfo = (void *) GetProcAddress (winsock_lib, "freeaddrinfo"); + /* Paranoia: these two functions should go together, so if one + is absent, we cannot use the other. */ + if (pfn_getaddrinfo == NULL) + pfn_freeaddrinfo = NULL; + else if (pfn_freeaddrinfo == NULL) + pfn_getaddrinfo = NULL; + /* specify version 1.1 of winsock */ if (pfn_WSAStartup (0x101, &winsockData) == 0) { @@ -7375,7 +7480,7 @@ check_errno (void) /* Extend strerror to handle the winsock-specific error codes. */ struct { int errnum; - char * msg; + const char * msg; } _wsa_errlist[] = { {WSAEINTR , "Interrupted function call"}, {WSAEBADF , "Bad file descriptor"}, @@ -7459,7 +7564,7 @@ sys_strerror (int error_no) for (i = 0; _wsa_errlist[i].errnum >= 0; i++) if (_wsa_errlist[i].errnum == error_no) - return _wsa_errlist[i].msg; + return (char *)_wsa_errlist[i].msg; sprintf (unknown_msg, "Unidentified error: %d", error_no); return unknown_msg; @@ -7751,6 +7856,117 @@ sys_getpeername (int s, struct sockaddr *addr, int * namelen) } int +sys_getaddrinfo (const char *node, const char *service, + const struct addrinfo *hints, struct addrinfo **res) +{ + int rc; + + if (winsock_lib == NULL) + { + errno = ENETDOWN; + return SOCKET_ERROR; + } + + check_errno (); + if (pfn_getaddrinfo) + rc = pfn_getaddrinfo (node, service, hints, res); + else + { + int port = 0; + struct hostent *host_info; + struct gai_storage { + struct addrinfo addrinfo; + struct sockaddr_in sockaddr_in; + } *gai_storage; + + /* We don't (yet) support any flags, as Emacs doesn't need that. */ + if (hints && hints->ai_flags != 0) + return WSAEINVAL; + /* NODE cannot be NULL, since process.c has fallbacks for that. */ + if (!node) + return WSAHOST_NOT_FOUND; + + if (service) + { + const char *protocol = + (hints && hints->ai_socktype == SOCK_DGRAM) ? "udp" : "tcp"; + struct servent *srv = sys_getservbyname (service, protocol); + + if (srv) + port = srv->s_port; + else if (*service >= '0' && *service <= '9') + { + char *endp; + + port = strtoul (service, &endp, 10); + if (*endp || port > 65536) + return WSAHOST_NOT_FOUND; + port = sys_htons ((unsigned short) port); + } + else + return WSAHOST_NOT_FOUND; + } + + gai_storage = xzalloc (sizeof *gai_storage); + gai_storage->sockaddr_in.sin_port = port; + host_info = sys_gethostbyname (node); + if (host_info) + { + memcpy (&gai_storage->sockaddr_in.sin_addr, + host_info->h_addr, host_info->h_length); + gai_storage->sockaddr_in.sin_family = host_info->h_addrtype; + } + else + { + /* Attempt to interpret host as numeric inet address. */ + unsigned long numeric_addr = sys_inet_addr (node); + + if (numeric_addr == -1) + { + free (gai_storage); + return WSAHOST_NOT_FOUND; + } + + memcpy (&gai_storage->sockaddr_in.sin_addr, &numeric_addr, + sizeof (gai_storage->sockaddr_in.sin_addr)); + gai_storage->sockaddr_in.sin_family = (hints) ? hints->ai_family : 0; + } + + gai_storage->addrinfo.ai_addr = + (struct sockaddr *)&gai_storage->sockaddr_in; + gai_storage->addrinfo.ai_addrlen = sizeof (gai_storage->sockaddr_in); + gai_storage->addrinfo.ai_protocol = (hints) ? hints->ai_protocol : 0; + gai_storage->addrinfo.ai_socktype = (hints) ? hints->ai_socktype : 0; + gai_storage->addrinfo.ai_family = gai_storage->sockaddr_in.sin_family; + gai_storage->addrinfo.ai_next = NULL; + + *res = &gai_storage->addrinfo; + rc = 0; + } + + return rc; +} + +void +sys_freeaddrinfo (struct addrinfo *ai) +{ + if (winsock_lib == NULL) + { + errno = ENETDOWN; + return; + } + + check_errno (); + if (pfn_freeaddrinfo) + pfn_freeaddrinfo (ai); + else + { + eassert (ai->ai_next == NULL); + xfree (ai); + } +} + +int sys_shutdown (int s, int how) { if (winsock_lib == NULL) @@ -8073,17 +8289,33 @@ sys_dup2 (int src, int dst) return -1; } - /* make sure we close the destination first if it's a pipe or socket */ - if (src != dst && fd_info[dst].flags != 0) + /* MS _dup2 seems to have weird side effect when invoked with 2 + identical arguments: an attempt to fclose the corresponding stdio + stream after that hangs (we do close standard streams in + init_ntproc). Attempt to avoid that by not calling _dup2 that + way: if SRC is valid, we know that dup2 should be a no-op, so do + nothing and return DST. */ + if (src == dst) + { + if ((HANDLE)_get_osfhandle (src) == INVALID_HANDLE_VALUE) + { + errno = EBADF; + return -1; + } + return dst; + } + + /* Make sure we close the destination first if it's a pipe or socket. */ + if (fd_info[dst].flags != 0) sys_close (dst); rc = _dup2 (src, dst); if (rc == 0) { - /* duplicate our internal info as well */ + /* Duplicate our internal info as well. */ fd_info[dst] = fd_info[src]; } - return rc; + return rc == 0 ? dst : rc; } int @@ -8664,6 +8896,30 @@ sys_write (int fd, const void * buffer, unsigned int count) unsigned long nblock = 0; if (winsock_lib == NULL) emacs_abort (); + child_process *cp = fd_info[fd].cp; + + /* If this is a non-blocking socket whose connection is in + progress or terminated with an error already, return the + proper error code to the caller. */ + if (cp != NULL && (fd_info[fd].flags & FILE_CONNECT) != 0) + { + /* In case connection is in progress, ENOTCONN that would + result from calling pfn_send is not what callers expect. */ + if (cp->status != STATUS_CONNECT_FAILED) + { + errno = EWOULDBLOCK; + return -1; + } + /* In case connection failed, use the actual error code + stashed by '_sys_wait_connect' in cp->errcode. */ + else if (cp->errcode != 0) + { + pfn_WSASetLastError (cp->errcode); + set_errno (); + return -1; + } + } + /* TODO: implement select() properly so non-blocking I/O works. */ /* For now, make sure the write blocks. */ if (fd_info[fd].flags & FILE_NDELAY) @@ -8671,6 +8927,13 @@ sys_write (int fd, const void * buffer, unsigned int count) nchars = pfn_send (SOCK_HANDLE (fd), buffer, count, 0); + if (nchars == SOCKET_ERROR) + { + set_errno (); + DebPrint (("sys_write.send failed with error %d on socket %ld\n", + pfn_WSAGetLastError (), SOCK_HANDLE (fd))); + } + /* Set the socket back to non-blocking if it was before, for other operations that support it. */ if (fd_info[fd].flags & FILE_NDELAY) @@ -8678,13 +8941,6 @@ sys_write (int fd, const void * buffer, unsigned int count) nblock = 1; pfn_ioctlsocket (SOCK_HANDLE (fd), FIONBIO, &nblock); } - - if (nchars == SOCKET_ERROR) - { - DebPrint (("sys_write.send failed with error %d on socket %ld\n", - pfn_WSAGetLastError (), SOCK_HANDLE (fd))); - set_errno (); - } } else { @@ -8757,8 +9013,6 @@ sys_write (int fd, const void * buffer, unsigned int count) /* Emulation of SIOCGIFCONF and getifaddrs, see process.c. */ -extern Lisp_Object conv_sockaddr_to_lisp (struct sockaddr *, int); - /* Return information about network interface IFNAME, or about all interfaces (if IFNAME is nil). */ static Lisp_Object @@ -9449,6 +9703,7 @@ globals_of_w32 (void) g_b_init_set_named_security_info_a = 0; g_b_init_get_adapters_info = 0; g_b_init_compare_string_w = 0; + g_b_init_debug_break_process = 0; num_of_processors = 0; /* The following sets a handler for shutdown notifications for console apps. This actually applies to Emacs in both console and @@ -9471,7 +9726,6 @@ globals_of_w32 (void) w32_unicode_filenames = 1; #ifdef HAVE_MODULES - extern void dynlib_reset_last_error (void); dynlib_reset_last_error (); #endif diff --git a/src/w32.h b/src/w32.h index 08b88f5f5a0..03dee099c01 100644 --- a/src/w32.h +++ b/src/w32.h @@ -89,7 +89,7 @@ typedef struct _child_process terminate it by sys_kill. */ HWND hwnd; /* Information about subprocess returned by CreateProcess. Includes - handles to the subprocess and its primary thread, and the + handles to the subprocess and its main thread, and the corresponding process ID and thread ID numbers. The PID is mirrored by the 'pid' member above. The process handle is used to wait on it. */ @@ -162,7 +162,7 @@ extern void reset_standard_handles (int in, int out, int err, HANDLE handles[4]); /* Return the string resource associated with KEY of type TYPE. */ -extern LPBYTE w32_get_resource (char * key, LPDWORD type); +extern LPBYTE w32_get_resource (const char * key, LPDWORD type); extern void release_listen_threads (void); extern void init_ntproc (int); diff --git a/src/w32console.c b/src/w32console.c index 512d20dd242..c71afb6f888 100644 --- a/src/w32console.c +++ b/src/w32console.c @@ -35,6 +35,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "w32common.h" /* for os_subtype */ #include "w32inevt.h" +#ifdef WINDOWSNT +#include "w32.h" /* for syms_of_ntterm */ +#endif + static void w32con_move_cursor (struct frame *f, int row, int col); static void w32con_clear_to_end (struct frame *f); static void w32con_clear_frame (struct frame *f); @@ -67,6 +71,8 @@ int w32_console_unicode_input; someone hits ^C in a 'suspended' session (child shell). Also ignore Ctrl-Break signals. */ +BOOL ctrl_c_handler (unsigned long); + BOOL ctrl_c_handler (unsigned long type) { @@ -509,11 +515,15 @@ w32con_update_end (struct frame * f) stubs from termcap.c ***********************************************************************/ +void sys_tputs (char *, int, int (*) (int)); + void sys_tputs (char *str, int nlines, int (*outfun) (int)) { } +char *sys_tgetstr (char *, char **); + char * sys_tgetstr (char *cap, char **area) { @@ -528,33 +538,45 @@ sys_tgetstr (char *cap, char **area) struct tty_display_info *current_tty = NULL; int cost = 0; +int evalcost (int); + int evalcost (int c) { return c; } +int cmputc (int); + int cmputc (int c) { return c; } +void cmcheckmagic (struct tty_display_info *); + void cmcheckmagic (struct tty_display_info *tty) { } +void cmcostinit (struct tty_display_info *); + void cmcostinit (struct tty_display_info *tty) { } +void cmgoto (struct tty_display_info *, int, int); + void cmgoto (struct tty_display_info *tty, int row, int col) { } +void Wcm_clear (struct tty_display_info *); + void Wcm_clear (struct tty_display_info *tty) { @@ -589,8 +611,6 @@ w32_face_attributes (struct frame *f, int face_id) WORD char_attr; struct face *face = FACE_FROM_ID (f, face_id); - eassert (face != NULL); - char_attr = char_attr_normal; /* Reverse the default color if requested. If background and @@ -759,6 +779,9 @@ initialize_w32_display (struct terminal *term, int *width, int *height) /* Setup w32_display_info structure for this frame. */ w32_initialize_display_info (build_string ("Console")); + + /* Set up the keyboard hook. */ + setup_w32_kbdhook (); } diff --git a/src/w32fns.c b/src/w32fns.c index 9f4232d5b92..79762ea36ab 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -20,6 +20,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* Added by Kevin Gallo */ #include <config.h> +/* Override API version to get the latest functionality. */ +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 #include <signal.h> #include <stdio.h> @@ -41,6 +44,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "coding.h" #include "w32common.h" +#include "w32inevt.h" #ifdef WINDOWSNT #include <mbstring.h> @@ -52,6 +56,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "w32.h" #endif +#include <basetyps.h> +#include <unknwn.h> #include <commctrl.h> #include <commdlg.h> #include <shellapi.h> @@ -68,15 +74,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #define FOF_NO_CONNECTED_ELEMENTS 0x2000 #endif -void syms_of_w32fns (void); -void globals_of_w32fns (void); - -extern void free_frame_menubar (struct frame *); extern int w32_console_toggle_lock_key (int, Lisp_Object); extern void w32_menu_display_help (HWND, HMENU, UINT, UINT); extern void w32_free_menu_strings (HWND); extern const char *map_w32_filename (const char *, const char **); -extern char * w32_strerror (int error_no); #ifndef IDC_HAND #define IDC_HAND MAKEINTRESOURCE(32649) @@ -185,11 +186,7 @@ MonitorFromWindow_Proc monitor_from_window_fn = NULL; EnumDisplayMonitors_Proc enum_display_monitors_fn = NULL; GetTitleBarInfo_Proc get_title_bar_info_fn = NULL; -#ifdef NTGUI_UNICODE -#define unicode_append_menu AppendMenuW -#else /* !NTGUI_UNICODE */ extern AppendMenuW_Proc unicode_append_menu; -#endif /* NTGUI_UNICODE */ /* Flag to selectively ignore WM_IME_CHAR messages. */ static int ignore_ime_char = 0; @@ -216,7 +213,6 @@ static HWND w32_visible_system_caret_hwnd; static int w32_unicode_gui; /* From w32menu.c */ -extern HMENU current_popup_menu; int menubar_in_use = 0; /* From w32uniscribe.c */ @@ -251,6 +247,40 @@ HINSTANCE hinst = NULL; static unsigned int sound_type = 0xFFFFFFFF; #define MB_EMACS_SILENT (0xFFFFFFFF - 1) +/* Special virtual key code for indicating "any" key. */ +#define VK_ANY 0xFF + +#ifndef WM_WTSSESSION_CHANGE +/* 32-bit MinGW does not define these constants. */ +# define WM_WTSSESSION_CHANGE 0x02B1 +# define WTS_SESSION_LOCK 0x7 +#endif + +/* Keyboard hook state data. */ +static struct +{ + int hook_count; /* counter, if several windows are created */ + HHOOK hook; /* hook handle */ + HWND console; /* console window handle */ + + int lwindown; /* Left Windows key currently pressed (and hooked) */ + int rwindown; /* Right Windows key currently pressed (and hooked) */ + int winsdown; /* Number of handled keys currently pressed */ + int send_win_up; /* Pass through the keyup for this Windows key press? */ + int suppress_lone; /* Suppress simulated Windows keydown-keyup for this press? */ + int winseen; /* Windows keys seen during this press? */ + + char alt_hooked[256]; /* hook Alt+[this key]? */ + char lwin_hooked[256]; /* hook left Win+[this key]? */ + char rwin_hooked[256]; /* hook right Win+[this key]? */ +} kbdhook; +typedef HWND (WINAPI *GetConsoleWindow_Proc) (void); + +typedef BOOL (WINAPI *IsDebuggerPresent_Proc) (void); + +/* stdin, from w32console.c */ +extern HANDLE keyboard_handle; + /* Let the user specify a display with a frame. nil stands for the selected frame--or, if that is not a w32 frame, the first display on the list. */ @@ -327,10 +357,7 @@ void x_set_cursor_type (struct frame *, Lisp_Object, Lisp_Object); void x_set_icon_type (struct frame *, Lisp_Object, Lisp_Object); void x_set_icon_name (struct frame *, Lisp_Object, Lisp_Object); void x_explicitly_set_name (struct frame *, Lisp_Object, Lisp_Object); -void x_set_menu_bar_lines (struct frame *, Lisp_Object, Lisp_Object); void x_set_title (struct frame *, Lisp_Object, Lisp_Object); -void x_set_tool_bar_lines (struct frame *, Lisp_Object, Lisp_Object); -void x_set_internal_border_width (struct frame *f, Lisp_Object, Lisp_Object); /* Store the screen positions of frame F into XPTR and YPTR. @@ -453,7 +480,7 @@ if the entry is new. */) /* The default colors for the w32 color map */ typedef struct colormap_t { - char *name; + const char *name; COLORREF colorref; } colormap_t; @@ -791,7 +818,7 @@ add_system_logical_colors_to_map (Lisp_Object *system_colors) NULL, NULL, (LPBYTE)color_buffer, &color_size) == ERROR_SUCCESS) { - int r, g, b; + unsigned r, g, b; if (sscanf (color_buffer, " %u %u %u", &r, &g, &b) == 3) *system_colors = Fcons (Fcons (build_string (full_name_buffer), make_number (RGB (r, g, b))), @@ -1206,7 +1233,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def, If F is not a color screen, return DEF (default) regardless of what ARG says. */ -int +static int x_decode_color (struct frame *f, Lisp_Object arg, int def) { XColor cdef; @@ -1489,7 +1516,7 @@ x_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) Note that this does not fully take effect if done before F has a window. */ -void +static void x_set_border_pixel (struct frame *f, int pix) { @@ -1600,7 +1627,7 @@ x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) #endif } -void +static void x_clear_under_internal_border (struct frame *f) { int border = FRAME_INTERNAL_BORDER_WIDTH (f); @@ -1633,7 +1660,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { - FRAME_INTERNAL_BORDER_WIDTH (f) = border; + f->internal_border_width = border; if (FRAME_X_WINDOW (f) != 0) { @@ -1826,7 +1853,7 @@ w32_set_title_bar_text (struct frame *f, Lisp_Object name) suggesting a new name, which lisp code should override; if F->explicit_name is set, ignore the new name; otherwise, set it. */ -void +static void x_set_name (struct frame *f, Lisp_Object name, bool explicit) { /* Make sure that requests from lisp code override requests from @@ -1931,6 +1958,8 @@ x_set_scroll_bar_default_height (struct frame *f) /* Subroutines for creating a frame. */ +Cursor w32_load_cursor (LPCTSTR); + Cursor w32_load_cursor (LPCTSTR name) { @@ -2074,6 +2103,365 @@ my_post_msg (W32Msg * wmsg, HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) post_msg (wmsg); } +#ifdef WINDOWSNT +/* The Windows keyboard hook callback. */ +static LRESULT CALLBACK +funhook (int code, WPARAM w, LPARAM l) +{ + INPUT inputs[2]; + HWND focus = GetFocus (); + int console = 0; + KBDLLHOOKSTRUCT const *hs = (KBDLLHOOKSTRUCT*)l; + + if (code < 0 || (hs->flags & LLKHF_INJECTED)) + return CallNextHookEx (0, code, w, l); + + /* The keyboard hook sees keyboard input on all processes (except + elevated ones, when Emacs itself is not elevated). As such, + care must be taken to only filter out keyboard input when Emacs + itself is on the foreground. + + GetFocus returns a non-NULL window if another application is active, + and always for a console Emacs process. For a console Emacs, determine + focus by checking if the current foreground window is the process's + console window. */ + if (focus == NULL && kbdhook.console != NULL) + { + if (GetForegroundWindow () == kbdhook.console) + { + focus = kbdhook.console; + console = 1; + } + } + + /* First, check hooks for the left and right Windows keys. */ + if (hs->vkCode == VK_LWIN || hs->vkCode == VK_RWIN) + { + if (focus != NULL && (w == WM_KEYDOWN || w == WM_SYSKEYDOWN)) + { + /* The key is being pressed in an Emacs window. */ + if (hs->vkCode == VK_LWIN && !kbdhook.lwindown) + { + kbdhook.lwindown = 1; + kbdhook.winseen = 1; + kbdhook.winsdown++; + } + else if (hs->vkCode == VK_RWIN && !kbdhook.rwindown) + { + kbdhook.rwindown = 1; + kbdhook.winseen = 1; + kbdhook.winsdown++; + } + /* Returning 1 here drops the keypress without further processing. + If the keypress was allowed to go through, the normal Windows + hotkeys would take over. */ + return 1; + } + else if (kbdhook.winsdown > 0 && (w == WM_KEYUP || w == WM_SYSKEYUP)) + { + /* A key that has been captured earlier is being released now. */ + if (hs->vkCode == VK_LWIN && kbdhook.lwindown) + { + kbdhook.lwindown = 0; + kbdhook.winsdown--; + } + else if (hs->vkCode == VK_RWIN && kbdhook.rwindown) + { + kbdhook.rwindown = 0; + kbdhook.winsdown--; + } + if (kbdhook.winsdown == 0 && kbdhook.winseen) + { + if (!kbdhook.suppress_lone) + { + /* The Windows key was pressed, then released, + without any other key pressed simultaneously. + Normally, this opens the Start menu, but the user + can prevent this by setting the + w32-pass-[lr]window-to-system variable to + NIL. */ + if ((hs->vkCode == VK_LWIN && !NILP (Vw32_pass_lwindow_to_system)) || + (hs->vkCode == VK_RWIN && !NILP (Vw32_pass_rwindow_to_system))) + { + /* Not prevented - Simulate the keypress to the system. */ + memset (inputs, 0, sizeof (inputs)); + inputs[0].type = INPUT_KEYBOARD; + inputs[0].ki.wVk = hs->vkCode; + inputs[0].ki.wScan = hs->vkCode; + inputs[0].ki.dwFlags = KEYEVENTF_EXTENDEDKEY; + inputs[0].ki.time = 0; + inputs[1].type = INPUT_KEYBOARD; + inputs[1].ki.wVk = hs->vkCode; + inputs[1].ki.wScan = hs->vkCode; + inputs[1].ki.dwFlags + = KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP; + inputs[1].ki.time = 0; + SendInput (2, inputs, sizeof (INPUT)); + } + else if (focus != NULL) + { + /* When not passed to system, must simulate privately to Emacs. */ + PostMessage (focus, WM_SYSKEYDOWN, hs->vkCode, 0); + PostMessage (focus, WM_SYSKEYUP, hs->vkCode, 0); + } + } + } + if (kbdhook.winsdown == 0) + { + /* No Windows keys pressed anymore - clear the state flags. */ + kbdhook.suppress_lone = 0; + kbdhook.winseen = 0; + } + if (!kbdhook.send_win_up) + { + /* Swallow this release message, as not to confuse + applications who did not get to see the original + WM_KEYDOWN message either. */ + return 1; + } + kbdhook.send_win_up = 0; + } + } + else if (kbdhook.winsdown > 0) + { + /* Some other key was pressed while a captured Win key is down. + This is either an Emacs registered hotkey combination, or a + system hotkey. */ + if ((kbdhook.lwindown && kbdhook.lwin_hooked[hs->vkCode]) || + (kbdhook.rwindown && kbdhook.rwin_hooked[hs->vkCode])) + { + /* Hooked Win-x combination, do not pass the keypress to Windows. */ + kbdhook.suppress_lone = 1; + } + else if (!kbdhook.suppress_lone) + { + /* Unhooked S-x combination; simulate the combination now + (will be seen by the system). */ + memset (inputs, 0, sizeof (inputs)); + inputs[0].type = INPUT_KEYBOARD; + inputs[0].ki.wVk = kbdhook.lwindown ? VK_LWIN : VK_RWIN; + inputs[0].ki.wScan = kbdhook.lwindown ? VK_LWIN : VK_RWIN; + inputs[0].ki.dwFlags = KEYEVENTF_EXTENDEDKEY; + inputs[0].ki.time = 0; + inputs[1].type = INPUT_KEYBOARD; + inputs[1].ki.wVk = hs->vkCode; + inputs[1].ki.wScan = hs->scanCode; + inputs[1].ki.dwFlags = + (hs->flags & LLKHF_EXTENDED) ? KEYEVENTF_EXTENDEDKEY : 0; + inputs[1].ki.time = 0; + SendInput (2, inputs, sizeof (INPUT)); + /* Stop processing of this Win sequence here; the + corresponding keyup messages will come through the normal + channel when the keys are released. */ + kbdhook.suppress_lone = 1; + kbdhook.send_win_up = 1; + /* Swallow the original keypress (as we want the Win key + down message simulated above to precede this real message). */ + return 1; + } + } + + /* Next, handle the registered Alt-* combinations. */ + if ((w == WM_SYSKEYDOWN || w == WM_KEYDOWN) + && kbdhook.alt_hooked[hs->vkCode] + && focus != NULL + && (GetAsyncKeyState (VK_MENU) & 0x8000)) + { + /* Prevent the system from getting this Alt-* key - suppress the + message and post as a normal keypress to Emacs. */ + if (console) + { + INPUT_RECORD rec; + DWORD n; + rec.EventType = KEY_EVENT; + rec.Event.KeyEvent.bKeyDown = TRUE; + rec.Event.KeyEvent.wVirtualKeyCode = hs->vkCode; + rec.Event.KeyEvent.wVirtualScanCode = hs->scanCode; + rec.Event.KeyEvent.uChar.UnicodeChar = 0; + rec.Event.KeyEvent.dwControlKeyState = + ((GetAsyncKeyState (VK_LMENU) & 0x8000) ? LEFT_ALT_PRESSED : 0) + | ((GetAsyncKeyState (VK_RMENU) & 0x8000) ? RIGHT_ALT_PRESSED : 0) + | ((GetAsyncKeyState (VK_LCONTROL) & 0x8000) ? LEFT_CTRL_PRESSED : 0) + | ((GetAsyncKeyState (VK_RCONTROL) & 0x8000) ? RIGHT_CTRL_PRESSED : 0) + | ((GetAsyncKeyState (VK_SHIFT) & 0x8000) ? SHIFT_PRESSED : 0) + | ((hs->flags & LLKHF_EXTENDED) ? ENHANCED_KEY : 0); + if (w32_console_unicode_input) + WriteConsoleInputW (keyboard_handle, &rec, 1, &n); + else + WriteConsoleInputA (keyboard_handle, &rec, 1, &n); + } + else + PostMessage (focus, w, hs->vkCode, 1 | (1<<29)); + return 1; + } + + /* The normal case - pass the message through. */ + return CallNextHookEx (0, code, w, l); +} + +/* Set up the hook; can be called several times, with matching + remove_w32_kbdhook calls. */ +void +setup_w32_kbdhook (void) +{ + kbdhook.hook_count++; + + /* This hook gets in the way of debugging, since when Emacs stops, + its input thread stops, and there's nothing to process keyboard + events, whereas this hook is global, and is invoked in the + context of the thread that installed it. So we don't install the + hook if the process is being debugged. */ + if (w32_kbdhook_active) + { + IsDebuggerPresent_Proc is_debugger_present = (IsDebuggerPresent_Proc) + GetProcAddress (GetModuleHandle ("kernel32.dll"), "IsDebuggerPresent"); + if (is_debugger_present && is_debugger_present ()) + return; + } + + /* Hooking is only available on NT architecture systems, as + indicated by the w32_kbdhook_active variable. */ + if (kbdhook.hook_count == 1 && w32_kbdhook_active) + { + /* Get the handle of the Emacs console window. As the + GetConsoleWindow function is only available on Win2000+, a + hackish workaround described in Microsoft KB article 124103 + (https://support.microsoft.com/en-us/kb/124103) is used for + NT 4 systems. */ + GetConsoleWindow_Proc get_console = (GetConsoleWindow_Proc) + GetProcAddress (GetModuleHandle ("kernel32.dll"), "GetConsoleWindow"); + + if (get_console != NULL) + kbdhook.console = get_console (); + else + { + GUID guid; + wchar_t *oldTitle = malloc (1024 * sizeof(wchar_t)); + wchar_t newTitle[64]; + int i; + + CoCreateGuid (&guid); + StringFromGUID2 (&guid, newTitle, 64); + if (newTitle != NULL) + { + GetConsoleTitleW (oldTitle, 1024); + SetConsoleTitleW (newTitle); + for (i = 0; i < 25; i++) + { + Sleep (40); + kbdhook.console = FindWindowW (NULL, newTitle); + if (kbdhook.console != NULL) + break; + } + SetConsoleTitleW (oldTitle); + } + free (oldTitle); + } + + /* Set the hook. */ + kbdhook.hook = SetWindowsHookEx (WH_KEYBOARD_LL, funhook, + GetModuleHandle (NULL), 0); + } +} + +/* Remove the hook. */ +void +remove_w32_kbdhook (void) +{ + kbdhook.hook_count--; + if (kbdhook.hook_count == 0 && w32_kbdhook_active) + { + UnhookWindowsHookEx (kbdhook.hook); + kbdhook.hook = NULL; + } +} +#endif /* WINDOWSNT */ + +/* Mark a specific key combination as hooked, preventing it to be + handled by the system. */ +static void +hook_w32_key (int hook, int modifier, int vkey) +{ + char *tbl = NULL; + + switch (modifier) + { + case VK_MENU: + tbl = kbdhook.alt_hooked; + break; + case VK_LWIN: + tbl = kbdhook.lwin_hooked; + break; + case VK_RWIN: + tbl = kbdhook.rwin_hooked; + break; + } + + if (tbl != NULL && vkey >= 0 && vkey <= 255) + { + /* VK_ANY hooks all keys for this modifier */ + if (vkey == VK_ANY) + memset (tbl, (char)hook, 256); + else + tbl[vkey] = (char)hook; + /* Alt-<modifier>s should go through */ + kbdhook.alt_hooked[VK_MENU] = 0; + kbdhook.alt_hooked[VK_LMENU] = 0; + kbdhook.alt_hooked[VK_RMENU] = 0; + kbdhook.alt_hooked[VK_CONTROL] = 0; + kbdhook.alt_hooked[VK_LCONTROL] = 0; + kbdhook.alt_hooked[VK_RCONTROL] = 0; + kbdhook.alt_hooked[VK_SHIFT] = 0; + kbdhook.alt_hooked[VK_LSHIFT] = 0; + kbdhook.alt_hooked[VK_RSHIFT] = 0; + } +} + +#ifdef WINDOWSNT +/* Check the current Win key pressed state. */ +int +check_w32_winkey_state (int vkey) +{ + /* The hook code handles grabbing of the Windows keys and Alt-* key + combinations reserved by the system. Handling Alt is a bit + easier, as Windows intends Alt-* shortcuts for application use in + Windows; hotkeys such as Alt-tab and Alt-escape are special + cases. Win-* hotkeys, on the other hand, are primarily meant for + system use. + + As a result, when we want Emacs to be able to grab the Win-* + keys, we must swallow all Win key presses in a low-level keyboard + hook. Unfortunately, this means that the Emacs window procedure + (and console input handler) never see the keypresses either. + Thus, to check the modifier states properly, Emacs code must use + the check_w32_winkey_state function that uses the flags directly + updated by the hook callback. */ + switch (vkey) + { + case VK_LWIN: + return kbdhook.lwindown; + case VK_RWIN: + return kbdhook.rwindown; + } + return 0; +} +#endif /* WINDOWSNT */ + +/* Reset the keyboard hook state. Locking the workstation with Win-L + leaves the Win key(s) "down" from the hook's point of view - the + keyup event is never seen. Thus, this function must be called when + the system is locked. */ +static void +reset_w32_kbdhook_state (void) +{ + kbdhook.lwindown = 0; + kbdhook.rwindown = 0; + kbdhook.winsdown = 0; + kbdhook.send_win_up = 0; + kbdhook.suppress_lone = 0; + kbdhook.winseen = 0; +} + /* GetKeyState and MapVirtualKey on Windows 95 do not actually distinguish between left and right keys as advertised. We test for this support dynamically, and set a flag when the support is absent. If @@ -2248,6 +2636,10 @@ modifier_set (int vkey) else return (GetKeyState (vkey) & 0x1); } +#ifdef WINDOWSNT + if (w32_kbdhook_active && (vkey == VK_LWIN || vkey == VK_RWIN)) + return check_w32_winkey_state (vkey); +#endif if (!modifiers_recorded) return (GetKeyState (vkey) & 0x8000); @@ -2268,6 +2660,7 @@ modifier_set (int vkey) /* Convert between the modifier bits W32 uses and the modifier bits Emacs uses. */ +unsigned int w32_key_to_modifier (int); unsigned int w32_key_to_modifier (int key) @@ -2366,6 +2759,8 @@ w32_get_key_modifiers (unsigned int wparam, unsigned int lparam) return mods; } +unsigned int map_keypad_keys (unsigned int, unsigned int); + unsigned int map_keypad_keys (unsigned int virt_key, unsigned int extended) { @@ -2390,7 +2785,9 @@ map_keypad_keys (unsigned int virt_key, unsigned int extended) /* List of special key combinations which w32 would normally capture, but Emacs should grab instead. Not directly visible to lisp, to simplify synchronization. Each item is an integer encoding a virtual - key code and modifier combination to capture. */ + key code and modifier combination to capture. + Note: This code is not used if keyboard hooks are active + (Windows 2000 and later). */ static Lisp_Object w32_grabbed_keys; #define HOTKEY(vk, mods) make_number (((vk) & 255) | ((mods) << 8)) @@ -2736,6 +3133,8 @@ cancel_all_deferred_msgs (void) PostThreadMessage (dwWindowsThreadId, WM_NULL, 0, 0); } +DWORD WINAPI w32_msg_worker (void *); + DWORD WINAPI w32_msg_worker (void *arg) { @@ -2954,7 +3353,7 @@ get_wm_chars (HWND aWnd, int *buf, int buflen, int ignore_ctrl, int ctrl, Be ready to treat the case when this delivers WM_(SYS)DEADCHAR. */ static int after_deadkey = -1; -int +static int deliver_wm_chars (int do_translate, HWND hwnd, UINT msg, UINT wParam, UINT lParam, int legacy_alt_meta) { @@ -2998,7 +3397,7 @@ deliver_wm_chars (int do_translate, HWND hwnd, UINT msg, UINT wParam, W32Msg wmsg; DWORD console_modifiers = construct_console_modifiers (); int *b = buf, strip_ExtraMods = 1, hairy = 0; - char *type_CtrlAlt = NULL; + const char *type_CtrlAlt = NULL; /* XXXX In fact, there may be another case when we need to do the same: What happens if the string defined in the LIGATURES has length @@ -3476,7 +3875,7 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) switch (wParam) { case VK_LWIN: - if (NILP (Vw32_pass_lwindow_to_system)) + if (!w32_kbdhook_active && NILP (Vw32_pass_lwindow_to_system)) { /* Prevent system from acting on keyup (which opens the Start menu if no other key was pressed) by simulating a @@ -3495,7 +3894,7 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) return 0; break; case VK_RWIN: - if (NILP (Vw32_pass_rwindow_to_system)) + if (!w32_kbdhook_active && NILP (Vw32_pass_rwindow_to_system)) { if (GetAsyncKeyState (wParam) & 1) { @@ -4352,10 +4751,12 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) case WM_SETFOCUS: dpyinfo->faked_key = 0; reset_modifiers (); - register_hot_keys (hwnd); + if (!w32_kbdhook_active) + register_hot_keys (hwnd); goto command; case WM_KILLFOCUS: - unregister_hot_keys (hwnd); + if (!w32_kbdhook_active) + unregister_hot_keys (hwnd); button_state = 0; ReleaseCapture (); /* Relinquish the system caret. */ @@ -4384,15 +4785,34 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) my_post_msg (&wmsg, hwnd, msg, wParam, lParam); goto dflt; +#ifdef WINDOWSNT + case WM_CREATE: + setup_w32_kbdhook (); + goto dflt; +#endif + case WM_DESTROY: +#ifdef WINDOWSNT + remove_w32_kbdhook (); +#endif CoUninitialize (); return 0; + case WM_WTSSESSION_CHANGE: + if (wParam == WTS_SESSION_LOCK) + reset_w32_kbdhook_state (); + goto dflt; + case WM_CLOSE: wmsg.dwModifiers = w32_get_modifiers (); my_post_msg (&wmsg, hwnd, msg, wParam, lParam); return 0; + case WM_ENDSESSION: + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + /* If we return, the process will be terminated immediately. */ + sleep (1000); + case WM_WINDOWPOSCHANGING: /* Don't restrict the sizing of any kind of frames. If the window manager doesn't, there's no reason to do it ourselves. */ @@ -4860,7 +5280,7 @@ x_default_font_parameter (struct frame *f, Lisp_Object parms) if (!STRINGP (font)) { int i; - static char *names[] + static const char *names[] = { "Courier New-10", "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1", "-*-Fixedsys-normal-r-*-*-12-*-*-*-c-*-iso8859-1", @@ -4880,7 +5300,8 @@ x_default_font_parameter (struct frame *f, Lisp_Object parms) { /* Remember the explicit font parameter, so we can re-apply it after we've applied the `default' face settings. */ - x_set_frame_parameters (f, Fcons (Fcons (Qfont_param, font_param), Qnil)); + x_set_frame_parameters (f, Fcons (Fcons (Qfont_parameter, font_param), + Qnil)); } x_default_parameter (f, parms, Qfont, font, "font", "Font", RES_TYPE_STRING); } @@ -5202,8 +5623,10 @@ This function is an internal primitive--use `make-frame' instead. */) else if (! NILP (visibility)) x_make_frame_visible (f); else - /* Must have been Qnil. */ - ; + { + /* Must have been Qnil. */ + ; + } } /* Initialize `default-minibuffer-frame' in case this is the first @@ -5746,11 +6169,13 @@ SOUND is nil to use the normal beep. */) return sound; } +#if 0 /* unused */ int x_screen_planes (register struct frame *f) { return FRAME_DISPLAY_INFO (f)->n_planes; } +#endif /* Return the display structure for the display named NAME. Open a new connection if necessary. */ @@ -6056,8 +6481,6 @@ no value of TYPE (always string in the MS Windows case). */) Tool tips ***********************************************************************/ -static Lisp_Object x_create_tip_frame (struct w32_display_info *, - Lisp_Object, Lisp_Object); static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object, Lisp_Object, int, int, int *, int *); @@ -6092,8 +6515,7 @@ unwind_create_tip_frame (Lisp_Object frame) /* Create a frame for a tooltip on the display described by DPYINFO. - PARMS is a list of frame parameters. TEXT is the string to - display in the tip frame. Value is the frame. + PARMS is a list of frame parameters. Value is the frame. Note that functions called here, esp. x_default_parameter can signal errors, for instance when a specified color name is @@ -6101,8 +6523,7 @@ unwind_create_tip_frame (Lisp_Object frame) when this happens. */ static Lisp_Object -x_create_tip_frame (struct w32_display_info *dpyinfo, - Lisp_Object parms, Lisp_Object text) +x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms) { struct frame *f; Lisp_Object frame; @@ -6111,8 +6532,6 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, ptrdiff_t count = SPECPDL_INDEX (); struct kboard *kb; bool face_change_before = face_change; - Lisp_Object buffer; - struct buffer *old_buffer; int x_width = 0, x_height = 0; /* Use this general default value to start with until we know if @@ -6136,23 +6555,9 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, frame = Qnil; /* Make a frame without minibuffer nor mode-line. */ f = make_frame (false); - f->wants_modeline = 0; + f->wants_modeline = false; XSETFRAME (frame, f); - AUTO_STRING (tip, " *tip*"); - buffer = Fget_buffer_create (tip); - /* Use set_window_buffer instead of Fset_window_buffer (see - discussion of bug#11984, bug#12025, bug#12026). */ - set_window_buffer (FRAME_ROOT_WINDOW (f), buffer, false, false); - old_buffer = current_buffer; - set_buffer_internal_1 (XBUFFER (buffer)); - bset_truncate_lines (current_buffer, Qnil); - specbind (Qinhibit_read_only, Qt); - specbind (Qinhibit_modification_hooks, Qt); - Ferase_buffer (); - Finsert (1, &text); - set_buffer_internal_1 (old_buffer); - record_unwind_protect (unwind_create_tip_frame, frame); /* By setting the output method, we're essentially saying that @@ -6186,7 +6591,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, { fset_name (f, name); f->explicit_name = true; - /* use the frame's title when getting resources for this frame. */ + /* Use the frame's title when getting resources for this frame. */ specbind (Qx_resource_name, name); } @@ -6216,14 +6621,10 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, parms = Fcons (Fcons (Qinternal_border_width, value), parms); } + x_default_parameter (f, parms, Qinternal_border_width, make_number (1), "internalBorderWidth", "internalBorderWidth", RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qright_divider_width, make_number (0), - NULL, NULL, RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qbottom_divider_width, make_number (0), - NULL, NULL, RES_TYPE_NUMBER); - /* Also do the stuff which must be set before the window exists. */ x_default_parameter (f, parms, Qforeground_color, build_string ("black"), "foreground", "Foreground", RES_TYPE_STRING); @@ -6250,6 +6651,9 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, f->fringe_cols = 0; f->left_fringe_width = 0; f->right_fringe_width = 0; + /* No dividers on tip frame. */ + f->right_divider_width = 0; + f->bottom_divider_width = 0; block_input (); my_create_tip_window (f); @@ -6276,7 +6680,6 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, SET_FRAME_LINES (f, 0); adjust_frame_size (f, width * FRAME_COLUMN_WIDTH (f), height * FRAME_LINE_HEIGHT (f), 0, true, Qtip_frame); - /* Add `tooltip' frame parameter's default value. */ if (NILP (Fframe_parameter (frame, Qtooltip))) Fmodify_frame_parameters (frame, Fcons (Fcons (Qtooltip, Qt), Qnil)); @@ -6294,8 +6697,6 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object fg = Fframe_parameter (frame, Qforeground_color); Lisp_Object colors = Qnil; - /* Set tip_frame here, so that */ - tip_frame = frame; call2 (Qface_set_after_frame_default, frame, Qnil); if (!EQ (bg, Fframe_parameter (frame, Qbackground_color))) @@ -6427,6 +6828,48 @@ compute_tip_xy (struct frame *f, *root_x = min_x; } +/* Hide tooltip. Delete its frame if DELETE is true. */ +static Lisp_Object +x_hide_tip (bool delete) +{ + if (!NILP (tip_timer)) + { + call1 (Qcancel_timer, tip_timer); + tip_timer = Qnil; + } + + if (NILP (tip_frame) + || (!delete && FRAMEP (tip_frame) + && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) + return Qnil; + else + { + ptrdiff_t count; + Lisp_Object was_open = Qnil; + + count = SPECPDL_INDEX (); + specbind (Qinhibit_redisplay, Qt); + specbind (Qinhibit_quit, Qt); + + if (FRAMEP (tip_frame)) + { + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (XFRAME (tip_frame)); + + was_open = Qt; + } + else + tip_frame = Qnil; + + return unbind_to (count, was_open); + } +} + DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, doc: /* Show STRING in a \"tooltip\" window on frame FRAME. @@ -6460,20 +6903,22 @@ A tooltip's maximum size is specified by `x-max-tooltip-size'. Text larger than the specified size is clipped. */) (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) { - struct frame *f; + struct frame *tip_f; struct window *w; int root_x, root_y; struct buffer *old_buffer; struct text_pos pos; - int i, width, height; - bool seen_reversed_p; + int width, height; int old_windows_or_buffers_changed = windows_or_buffers_changed; ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t count_1; + Lisp_Object window, size; + AUTO_STRING (tip, " *tip*"); specbind (Qinhibit_redisplay, Qt); CHECK_STRING (string); - f = decode_window_system_frame (frame); + decode_window_system_frame (frame); if (NILP (timeout)) timeout = make_number (5); else @@ -6492,91 +6937,155 @@ Text larger than the specified size is clipped. */) if (NILP (last_show_tip_args)) last_show_tip_args = Fmake_vector (make_number (3), Qnil); - if (!NILP (tip_frame)) + if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { Lisp_Object last_string = AREF (last_show_tip_args, 0); Lisp_Object last_frame = AREF (last_show_tip_args, 1); Lisp_Object last_parms = AREF (last_show_tip_args, 2); - if (EQ (frame, last_frame) - && !NILP (Fequal (last_string, string)) + if (FRAME_VISIBLE_P (XFRAME (tip_frame)) + && EQ (frame, last_frame) + && !NILP (Fequal_including_properties (last_string, string)) && !NILP (Fequal (last_parms, parms))) { - struct frame *f = XFRAME (tip_frame); - /* Only DX and DY have changed. */ + tip_f = XFRAME (tip_frame); if (!NILP (tip_timer)) { Lisp_Object timer = tip_timer; + tip_timer = Qnil; call1 (Qcancel_timer, timer); } block_input (); - compute_tip_xy (f, parms, dx, dy, FRAME_PIXEL_WIDTH (f), - FRAME_PIXEL_HEIGHT (f), &root_x, &root_y); + compute_tip_xy (tip_f, parms, dx, dy, FRAME_PIXEL_WIDTH (tip_f), + FRAME_PIXEL_HEIGHT (tip_f), &root_x, &root_y); /* Put tooltip in topmost group and in position. */ - SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOPMOST, + SetWindowPos (FRAME_W32_WINDOW (tip_f), HWND_TOPMOST, root_x, root_y, 0, 0, SWP_NOSIZE | SWP_NOACTIVATE | SWP_NOOWNERZORDER); /* Ensure tooltip is on top of other topmost windows (eg menus). */ - SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOP, + SetWindowPos (FRAME_W32_WINDOW (tip_f), HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE | SWP_NOACTIVATE | SWP_NOOWNERZORDER); + /* Let redisplay know that we have made the frame visible already. */ + SET_FRAME_VISIBLE (tip_f, 1); + ShowWindow (FRAME_W32_WINDOW (tip_f), SW_SHOWNOACTIVATE); unblock_input (); + goto start_timer; } - } + else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame)) + { + bool delete = false; + Lisp_Object tail, elt, parm, last; + + /* Check if every parameter in PARMS has the same value in + last_parms. This may destruct last_parms which, however, + will be recreated below. */ + for (tail = parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + /* The left, top, right and bottom parameters are handled + by compute_tip_xy so they can be ignored here. */ + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) + && !EQ (parm, Qright) && !EQ (parm, Qbottom)) + { + last = Fassq (parm, last_parms); + if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + else + last_parms = call2 (Qassq_delete_all, parm, last_parms); + } + else + last_parms = call2 (Qassq_delete_all, parm, last_parms); + } + + /* Now check if there's a parameter left in last_parms with a + non-nil value. */ + for (tail = last_parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) + && !EQ (parm, Qbottom) && !NILP (Fcdr (elt))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + } - /* Hide a previous tip, if any. */ - Fx_hide_tip (); + x_hide_tip (delete); + } + else + x_hide_tip (true); + } + else + x_hide_tip (true); ASET (last_show_tip_args, 0, string); ASET (last_show_tip_args, 1, frame); ASET (last_show_tip_args, 2, parms); - /* Add default values to frame parameters. */ - if (NILP (Fassq (Qname, parms))) - parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms); - if (NILP (Fassq (Qinternal_border_width, parms))) - parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms); - if (NILP (Fassq (Qright_divider_width, parms))) - parms = Fcons (Fcons (Qright_divider_width, make_number (0)), parms); - if (NILP (Fassq (Qbottom_divider_width, parms))) - parms = Fcons (Fcons (Qbottom_divider_width, make_number (0)), parms); - if (NILP (Fassq (Qborder_width, parms))) - parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); - if (NILP (Fassq (Qborder_color, parms))) - parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms); - if (NILP (Fassq (Qbackground_color, parms))) - parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), - parms); - /* Block input until the tip has been fully drawn, to avoid crashes when drawing tips in menus. */ block_input (); - /* Create a frame for the tooltip, and record it in the global - variable tip_frame. */ - frame = x_create_tip_frame (FRAME_DISPLAY_INFO (f), parms, string); - f = XFRAME (frame); + if (!FRAMEP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame))) + { + /* Add default values to frame parameters. */ + if (NILP (Fassq (Qname, parms))) + parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms); + if (NILP (Fassq (Qinternal_border_width, parms))) + parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms); + if (NILP (Fassq (Qborder_width, parms))) + parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); + if (NILP (Fassq (Qborder_color, parms))) + parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms); + if (NILP (Fassq (Qbackground_color, parms))) + parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), + parms); - /* Set up the frame's root window. */ - w = XWINDOW (FRAME_ROOT_WINDOW (f)); + /* Create a frame for the tooltip, and record it in the global + variable tip_frame. */ + struct frame *f; /* The value is unused. */ + if (NILP (tip_frame = x_create_tip_frame (FRAME_DISPLAY_INFO (f), parms))) + { + /* Creating the tip frame failed. */ + unblock_input (); + return unbind_to (count, Qnil); + } + } + + tip_f = XFRAME (tip_frame); + window = FRAME_ROOT_WINDOW (tip_f); + set_window_buffer (window, Fget_buffer_create (tip), false, false); + w = XWINDOW (window); + w->pseudo_window_p = true; + + /* Set up the frame's root window. Note: The following code does not + try to size the window or its frame correctly. Its only purpose is + to make the subsequent text size calculations work. The right + sizes should get installed when the toolkit gets back to us. */ w->left_col = 0; w->top_line = 0; w->pixel_left = 0; w->pixel_top = 0; if (CONSP (Vx_max_tooltip_size) - && INTEGERP (XCAR (Vx_max_tooltip_size)) - && XINT (XCAR (Vx_max_tooltip_size)) > 0 - && INTEGERP (XCDR (Vx_max_tooltip_size)) - && XINT (XCDR (Vx_max_tooltip_size)) > 0) + && RANGED_INTEGERP (1, XCAR (Vx_max_tooltip_size), INT_MAX) + && RANGED_INTEGERP (1, XCDR (Vx_max_tooltip_size), INT_MAX)) { w->total_cols = XFASTINT (XCAR (Vx_max_tooltip_size)); w->total_lines = XFASTINT (XCDR (Vx_max_tooltip_size)); @@ -6587,164 +7096,71 @@ Text larger than the specified size is clipped. */) w->total_lines = 40; } - w->pixel_width = w->total_cols * FRAME_COLUMN_WIDTH (f); - w->pixel_height = w->total_lines * FRAME_LINE_HEIGHT (f); + w->pixel_width = w->total_cols * FRAME_COLUMN_WIDTH (tip_f); + w->pixel_height = w->total_lines * FRAME_LINE_HEIGHT (tip_f); + FRAME_TOTAL_COLS (tip_f) = WINDOW_TOTAL_COLS (w); + adjust_frame_glyphs (tip_f); - FRAME_TOTAL_COLS (f) = WINDOW_TOTAL_COLS (w); - adjust_frame_glyphs (f); - w->pseudo_window_p = true; - - /* Display the tooltip text in a temporary buffer. */ + /* Insert STRING into the root window's buffer and fit the frame to + the buffer. */ + count_1 = SPECPDL_INDEX (); old_buffer = current_buffer; - set_buffer_internal_1 (XBUFFER (XWINDOW (FRAME_ROOT_WINDOW (f))->contents)); + set_buffer_internal_1 (XBUFFER (w->contents)); bset_truncate_lines (current_buffer, Qnil); + specbind (Qinhibit_read_only, Qt); + specbind (Qinhibit_modification_hooks, Qt); + specbind (Qinhibit_point_motion_hooks, Qt); + Ferase_buffer (); + Finsert (1, &string); clear_glyph_matrix (w->desired_matrix); clear_glyph_matrix (w->current_matrix); SET_TEXT_POS (pos, BEGV, BEGV_BYTE); - try_window (FRAME_ROOT_WINDOW (f), pos, TRY_WINDOW_IGNORE_FONTS_CHANGE); - - /* Compute width and height of the tooltip. */ - width = height = 0; - seen_reversed_p = false; - for (i = 0; i < w->desired_matrix->nrows; ++i) - { - struct glyph_row *row = &w->desired_matrix->rows[i]; - struct glyph *last; - int row_width; - - /* Stop at the first empty row at the end. */ - if (!row->enabled_p || !MATRIX_ROW_DISPLAYS_TEXT_P (row)) - break; - - /* Let the row go over the full width of the frame. */ - row->full_width_p = true; - - row_width = row->pixel_width; - if (row->used[TEXT_AREA]) - { - if (!row->reversed_p) - { - /* There's a glyph at the end of rows that is used to - place the cursor there. Don't include the width of - this glyph. */ - last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1]; - if (NILP (last->object)) - row_width -= last->pixel_width; - } - else - { - /* There could be a stretch glyph at the beginning of R2L - rows that is produced by extend_face_to_end_of_line. - Don't count that glyph. */ - struct glyph *g = row->glyphs[TEXT_AREA]; - - if (g->type == STRETCH_GLYPH && NILP (g->object)) - { - row_width -= g->pixel_width; - seen_reversed_p = true; - } - } - } - - height += row->height; - width = max (width, row_width); - } - - /* If we've seen partial-length R2L rows, we need to re-adjust the - tool-tip frame width and redisplay it again, to avoid over-wide - tips due to the stretch glyph that extends R2L lines to full - width of the frame. */ - if (seen_reversed_p) - { - /* PXW: Why do we do the pixel-to-cols conversion only if - seen_reversed_p holds? Don't we have to set other fields of - the window/frame structure? - - w->total_cols and FRAME_TOTAL_COLS want the width in columns, - not in pixels. */ - w->pixel_width = width; - width /= WINDOW_FRAME_COLUMN_WIDTH (w); - w->total_cols = width; - FRAME_TOTAL_COLS (f) = width; - SET_FRAME_WIDTH (f, width); - adjust_frame_glyphs (f); - w->pseudo_window_p = 1; - clear_glyph_matrix (w->desired_matrix); - clear_glyph_matrix (w->current_matrix); - try_window (FRAME_ROOT_WINDOW (f), pos, TRY_WINDOW_IGNORE_FONTS_CHANGE); - width = height = 0; - /* Recompute width and height of the tooltip. */ - for (i = 0; i < w->desired_matrix->nrows; ++i) - { - struct glyph_row *row = &w->desired_matrix->rows[i]; - struct glyph *last; - int row_width; - - if (!row->enabled_p || !MATRIX_ROW_DISPLAYS_TEXT_P (row)) - break; - row->full_width_p = true; - row_width = row->pixel_width; - if (row->used[TEXT_AREA] && !row->reversed_p) - { - last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1]; - if (NILP (last->object)) - row_width -= last->pixel_width; - } - - height += row->height; - width = max (width, row_width); - } - } - - /* Add the frame's internal border to the width and height the w32 - window should have. */ - height += 2 * FRAME_INTERNAL_BORDER_WIDTH (f); - width += 2 * FRAME_INTERNAL_BORDER_WIDTH (f); - - /* Move the tooltip window where the mouse pointer is. Resize and - show it. - - PXW: This should use the frame's pixel coordinates. */ - compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y); - + try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE); + /* Calculate size of tooltip window. */ + size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil, + make_number (w->pixel_height), Qnil); + /* Add the frame's internal border to calculated size. */ + width = XINT (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + height = XINT (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + /* Calculate position of tooltip frame. */ + compute_tip_xy (tip_f, parms, dx, dy, width, height, &root_x, &root_y); + + /* Show tooltip frame. */ { - /* Adjust Window size to take border into account. */ RECT rect; + int pad = (NUMBERP (Vw32_tooltip_extra_pixels) + ? max (0, XINT (Vw32_tooltip_extra_pixels)) + : FRAME_COLUMN_WIDTH (tip_f)); + rect.left = rect.top = 0; rect.right = width; rect.bottom = height; - AdjustWindowRect (&rect, f->output_data.w32->dwStyle, false); - - /* Position and size tooltip, and put it in the topmost group. - The add-on of FRAME_COLUMN_WIDTH to the 5th argument is a - peculiarity of w32 display: without it, some fonts cause the - last character of the tip to be truncated or wrapped around to - the next line. */ - SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOPMOST, + AdjustWindowRect (&rect, tip_f->output_data.w32->dwStyle, + FRAME_EXTERNAL_MENU_BAR (tip_f)); + + /* Position and size tooltip and put it in the topmost group. */ + SetWindowPos (FRAME_W32_WINDOW (tip_f), HWND_TOPMOST, root_x, root_y, - rect.right - rect.left + FRAME_COLUMN_WIDTH (f), + rect.right - rect.left + pad, rect.bottom - rect.top, SWP_NOACTIVATE | SWP_NOOWNERZORDER); /* Ensure tooltip is on top of other topmost windows (eg menus). */ - SetWindowPos (FRAME_W32_WINDOW (f), HWND_TOP, + SetWindowPos (FRAME_W32_WINDOW (tip_f), HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE | SWP_NOACTIVATE | SWP_NOOWNERZORDER); /* Let redisplay know that we have made the frame visible already. */ - SET_FRAME_VISIBLE (f, 1); + SET_FRAME_VISIBLE (tip_f, 1); - ShowWindow (FRAME_W32_WINDOW (f), SW_SHOWNOACTIVATE); + ShowWindow (FRAME_W32_WINDOW (tip_f), SW_SHOWNOACTIVATE); } - /* Draw into the window. */ w->must_be_updated_p = true; update_single_window (w); - - unblock_input (); - - /* Restore original current buffer. */ set_buffer_internal_1 (old_buffer); + unbind_to (count_1, Qnil); + unblock_input (); windows_or_buffers_changed = old_windows_or_buffers_changed; start_timer: @@ -6761,31 +7177,7 @@ DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, Value is t if tooltip was open, nil otherwise. */) (void) { - ptrdiff_t count; - Lisp_Object deleted, frame, timer; - - /* Return quickly if nothing to do. */ - if (NILP (tip_timer) && NILP (tip_frame)) - return Qnil; - - frame = tip_frame; - timer = tip_timer; - tip_frame = tip_timer = deleted = Qnil; - - count = SPECPDL_INDEX (); - specbind (Qinhibit_redisplay, Qt); - specbind (Qinhibit_quit, Qt); - - if (!NILP (timer)) - call1 (Qcancel_timer, timer); - - if (FRAMEP (frame)) - { - delete_frame (frame, Qnil); - deleted = Qt; - } - - return unbind_to (count, deleted); + return x_hide_tip (!tooltip_reuse_hidden_frame); } /*********************************************************************** @@ -6912,7 +7304,9 @@ value of DIR as in previous invocations; this is standard Windows behavior. */) { /* Filter index: 1: All Files, 2: Directories only */ static const wchar_t filter_w[] = L"All Files (*.*)\0*.*\0Directories\0*|*\0"; +#ifndef NTGUI_UNICODE static const char filter_a[] = "All Files (*.*)\0*.*\0Directories\0*|*\0"; +#endif Lisp_Object filename = default_filename; struct frame *f = SELECTED_FRAME (); @@ -7190,7 +7584,7 @@ value of DIR as in previous invocations; this is standard Windows behavior. */) /* Make "Cancel" equivalent to C-g. */ if (NILP (filename)) - Fsignal (Qquit, Qnil); + quit (); return filename; } @@ -7653,19 +8047,34 @@ lookup_vk_code (char *key) && strcmp (lispy_function_keys[i], key) == 0) return i; + if (w32_kbdhook_active) + { + /* Alphanumerics map to themselves. */ + if (key[1] == 0) + { + if ((key[0] >= 'A' && key[0] <= 'Z') + || (key[0] >= '0' && key[0] <= '9')) + return key[0]; + if (key[0] >= 'a' && key[0] <= 'z') + return toupper(key[0]); + } + } + return -1; } /* Convert a one-element vector style key sequence to a hot key definition. */ static Lisp_Object -w32_parse_hot_key (Lisp_Object key) +w32_parse_and_hook_hot_key (Lisp_Object key, int hook) { /* Copied from Fdefine_key and store_in_keymap. */ register Lisp_Object c; int vk_code; int lisp_modifiers; int w32_modifiers; + Lisp_Object res = Qnil; + char* vkname; CHECK_VECTOR (key); @@ -7688,7 +8097,12 @@ w32_parse_hot_key (Lisp_Object key) c = Fcar (c); if (!SYMBOLP (c)) emacs_abort (); - vk_code = lookup_vk_code (SSDATA (SYMBOL_NAME (c))); + vkname = SSDATA (SYMBOL_NAME (c)); + /* [s-], [M-], [h-]: Register all keys for this modifier */ + if (w32_kbdhook_active && vkname[0] == 0) + vk_code = VK_ANY; + else + vk_code = lookup_vk_code (vkname); } else if (INTEGERP (c)) { @@ -7712,34 +8126,75 @@ w32_parse_hot_key (Lisp_Object key) #define MOD_WIN 0x0008 #endif - /* Convert lisp modifiers to Windows hot-key form. */ - w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0; - w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0; - w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0; - w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0; + if (w32_kbdhook_active) + { + /* Register Alt-x combinations. */ + if (lisp_modifiers & alt_modifier) + { + hook_w32_key (hook, VK_MENU, vk_code); + res = Qt; + } + /* Register Win-x combinations based on modifier mappings. */ + if (((lisp_modifiers & hyper_modifier) + && EQ (Vw32_lwindow_modifier, Qhyper)) + || ((lisp_modifiers & super_modifier) + && EQ (Vw32_lwindow_modifier, Qsuper))) + { + hook_w32_key (hook, VK_LWIN, vk_code); + res = Qt; + } + if (((lisp_modifiers & hyper_modifier) + && EQ (Vw32_rwindow_modifier, Qhyper)) + || ((lisp_modifiers & super_modifier) + && EQ (Vw32_rwindow_modifier, Qsuper))) + { + hook_w32_key (hook, VK_RWIN, vk_code); + res = Qt; + } + return res; + } + else + { + /* Convert lisp modifiers to Windows hot-key form. */ + w32_modifiers = (lisp_modifiers & hyper_modifier) ? MOD_WIN : 0; + w32_modifiers |= (lisp_modifiers & alt_modifier) ? MOD_ALT : 0; + w32_modifiers |= (lisp_modifiers & ctrl_modifier) ? MOD_CONTROL : 0; + w32_modifiers |= (lisp_modifiers & shift_modifier) ? MOD_SHIFT : 0; - return HOTKEY (vk_code, w32_modifiers); + return HOTKEY (vk_code, w32_modifiers); + } } DEFUN ("w32-register-hot-key", Fw32_register_hot_key, Sw32_register_hot_key, 1, 1, 0, doc: /* Register KEY as a hot-key combination. -Certain key combinations like Alt-Tab are reserved for system use on -Windows, and therefore are normally intercepted by the system. However, -most of these key combinations can be received by registering them as -hot-keys, overriding their special meaning. - -KEY must be a one element key definition in vector form that would be -acceptable to `define-key' (e.g. [A-tab] for Alt-Tab). The meta -modifier is interpreted as Alt if `w32-alt-is-meta' is t, and hyper -is always interpreted as the Windows modifier keys. - -The return value is the hotkey-id if registered, otherwise nil. */) +Certain key combinations like Alt-Tab and Win-R are reserved for +system use on Windows, and therefore are normally intercepted by the +system. These key combinations can be received by registering them +as hot-keys, except for Win-L which always locks the computer. + +On Windows 98 and ME, KEY must be a one element key definition in +vector form that would be acceptable to `define-key' (e.g. [A-tab] for +Alt-Tab). The meta modifier is interpreted as Alt if +`w32-alt-is-meta' is t, and hyper is always interpreted as the Windows +modifier keys. The return value is the hotkey-id if registered, otherwise nil. + +On Windows versions since NT, KEY can also be specified as [M-], [s-] or +[h-] to indicate that all combinations of that key should be processed +by Emacs instead of the operating system. The super and hyper +modifiers are interpreted according to the current values of +`w32-lwindow-modifier' and `w32-rwindow-modifier'. For instance, +setting `w32-lwindow-modifier' to `super' and then calling +`(register-hot-key [s-])' grabs all combinations of the left Windows +key to Emacs, but leaves the right Windows key free for the operating +system keyboard shortcuts. The return value is t if the call affected +any key combinations, otherwise nil. */) (Lisp_Object key) { - key = w32_parse_hot_key (key); + key = w32_parse_and_hook_hot_key (key, 1); - if (!NILP (key) && NILP (Fmemq (key, w32_grabbed_keys))) + if (!w32_kbdhook_active + && !NILP (key) && NILP (Fmemq (key, w32_grabbed_keys))) { /* Reuse an empty slot if possible. */ Lisp_Object item = Fmemq (Qnil, w32_grabbed_keys); @@ -7767,7 +8222,10 @@ DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, Lisp_Object item; if (!INTEGERP (key)) - key = w32_parse_hot_key (key); + key = w32_parse_and_hook_hot_key (key, 0); + + if (w32_kbdhook_active) + return key; item = Fmemq (key, w32_grabbed_keys); @@ -8007,24 +8465,25 @@ and width values are in pixels. Fcons (Qouter_size, Fcons (make_number (right - left), make_number (bottom - top))), - Fcons (Qexternal_border_size, + Fcons (Qexternal_border_size, Fcons (make_number (external_border_width), make_number (external_border_height))), Fcons (Qtitle_bar_size, Fcons (make_number (title_bar_width), make_number (title_bar_height))), - Fcons (Qmenu_bar_external, Qt), - Fcons (Qmenu_bar_size, - Fcons (make_number - (menu_bar.rcBar.right - menu_bar.rcBar.left), - make_number (menu_bar_height))), - Fcons (Qtool_bar_external, Qnil), + Fcons (Qmenu_bar_external, Qt), + Fcons (Qmenu_bar_size, + Fcons (make_number + (menu_bar.rcBar.right - menu_bar.rcBar.left), + make_number (menu_bar_height))), + Fcons (Qtool_bar_external, Qnil), Fcons (Qtool_bar_position, tool_bar_height ? Qtop : Qnil), - Fcons (Qtool_bar_size, + Fcons (Qtool_bar_size, Fcons (make_number (tool_bar_height - ? right - left - 2 * internal_border_width - : 0), + ? (right - left - 2 * external_border_width + - 2 * internal_border_width) + : 0), make_number (tool_bar_height))), Fcons (Qinternal_border_width, make_number (internal_border_width))); @@ -8229,7 +8688,7 @@ The following %-sequences are provided: else { long m; - float h; + double h; char buffer[16]; snprintf (buffer, 16, "%ld", seconds_left); seconds = build_string (buffer); @@ -8522,7 +8981,7 @@ w32_strerror (int error_no) --ret; buf[ret] = '\0'; if (!ret) - sprintf (buf, "w32 error %u", error_no); + sprintf (buf, "w32 error %d", error_no); return buf; } @@ -8530,6 +8989,8 @@ w32_strerror (int error_no) /* For convenience when debugging. (You cannot call GetLastError directly from GDB: it will crash, because it uses the __stdcall calling convention, not the _cdecl convention assumed by GDB.) */ +DWORD w32_last_error (void); + DWORD w32_last_error (void) { @@ -9180,7 +9641,7 @@ usage: (w32-notification-notify &rest PARAMS) */) EMACS_INT retval; char *icon, *tip, *title, *msg; enum NI_Severity severity; - unsigned timeout; + unsigned timeout = 0; if (nargs == 0) return Qnil; @@ -9192,14 +9653,14 @@ usage: (w32-notification-notify &rest PARAMS) */) if (STRINGP (lres)) icon = SSDATA (ENCODE_FILE (Fexpand_file_name (lres, Qnil))); else - icon = ""; + icon = (char *)""; /* Tip. */ lres = Fplist_get (arg_plist, QCtip); if (STRINGP (lres)) tip = SSDATA (code_convert_string_norecord (lres, Qutf_8, 1)); else - tip = "Emacs notification"; + tip = (char *)"Emacs notification"; /* Severity. */ lres = Fplist_get (arg_plist, QClevel); @@ -9219,14 +9680,14 @@ usage: (w32-notification-notify &rest PARAMS) */) if (STRINGP (lres)) title = SSDATA (code_convert_string_norecord (lres, Qutf_8, 1)); else - title = ""; + title = (char *)""; /* Notification body text. */ lres = Fplist_get (arg_plist, QCbody); if (STRINGP (lres)) msg = SSDATA (code_convert_string_norecord (lres, Qutf_8, 1)); else - msg = ""; + msg = (char *)""; /* Do it! */ retval = add_tray_notification (f, icon, tip, severity, timeout, title, msg); @@ -9296,6 +9757,7 @@ frame_parm_handler w32_frame_parm_handlers[] = x_set_alpha, 0, /* x_set_sticky */ 0, /* x_set_tool_bar_position */ + 0, /* x_set_inhibit_double_buffering */ }; void @@ -9315,12 +9777,13 @@ syms_of_w32fns (void) DEFSYM (Qctrl, "ctrl"); DEFSYM (Qcontrol, "control"); DEFSYM (Qshift, "shift"); - DEFSYM (Qfont_param, "font-parameter"); + DEFSYM (Qfont_parameter, "font-parameter"); DEFSYM (Qgeometry, "geometry"); DEFSYM (Qworkarea, "workarea"); DEFSYM (Qmm_size, "mm-size"); DEFSYM (Qframes, "frames"); DEFSYM (Qtip_frame, "tip-frame"); + DEFSYM (Qassq_delete_all, "assq-delete-all"); DEFSYM (Qunicode_sip, "unicode-sip"); #if defined WINDOWSNT && !defined HAVE_DBUS DEFSYM (QCicon, ":icon"); @@ -9333,10 +9796,10 @@ syms_of_w32fns (void) #endif /* Symbols used elsewhere, but only in MS-Windows-specific code. */ - DEFSYM (Qgnutls_dll, "gnutls"); - DEFSYM (Qlibxml2_dll, "libxml2"); + DEFSYM (Qgnutls, "gnutls"); + DEFSYM (Qlibxml2, "libxml2"); DEFSYM (Qserif, "serif"); - DEFSYM (Qzlib_dll, "zlib"); + DEFSYM (Qzlib, "zlib"); Fput (Qundefined_color, Qerror_conditions, listn (CONSTYPE_PURE, 2, Qundefined_color, Qerror)); @@ -9374,11 +9837,15 @@ When non-nil, the Start menu is opened by tapping the key. If you set this to nil, the left \"Windows\" key is processed by Emacs according to the value of `w32-lwindow-modifier', which see. -Note that some combinations of the left \"Windows\" key with other keys are -caught by Windows at low level, and so binding them in Emacs will have no -effect. For example, <lwindow>-r always pops up the Windows Run dialog, -<lwindow>-<Pause> pops up the "System Properties" dialog, etc. However, see -the doc string of `w32-phantom-key-code'. */); +Note that some combinations of the left \"Windows\" key with other +keys are caught by Windows at low level. For example, <lwindow>-r +pops up the Windows Run dialog, <lwindow>-<Pause> pops up the "System +Properties" dialog, etc. On Windows 10, no \"Windows\" key +combinations are normally handed to applications. To enable Emacs to +process \"Windows\" key combinations, use the function +`w32-register-hot-key`. + +For Windows 98/ME, see the doc string of `w32-phantom-key-code'. */); Vw32_pass_lwindow_to_system = Qt; DEFVAR_LISP ("w32-pass-rwindow-to-system", @@ -9389,11 +9856,15 @@ When non-nil, the Start menu is opened by tapping the key. If you set this to nil, the right \"Windows\" key is processed by Emacs according to the value of `w32-rwindow-modifier', which see. -Note that some combinations of the right \"Windows\" key with other keys are -caught by Windows at low level, and so binding them in Emacs will have no -effect. For example, <rwindow>-r always pops up the Windows Run dialog, -<rwindow>-<Pause> pops up the "System Properties" dialog, etc. However, see -the doc string of `w32-phantom-key-code'. */); +Note that some combinations of the right \"Windows\" key with other +keys are caught by Windows at low level. For example, <rwindow>-r +pops up the Windows Run dialog, <rwindow>-<Pause> pops up the "System +Properties" dialog, etc. On Windows 10, no \"Windows\" key +combinations are normally handed to applications. To enable Emacs to +process \"Windows\" key combinations, use the function +`w32-register-hot-key`. + +For Windows 98/ME, see the doc string of `w32-phantom-key-code'. */); Vw32_pass_rwindow_to_system = Qt; DEFVAR_LISP ("w32-phantom-key-code", @@ -9403,7 +9874,11 @@ Value is a number between 0 and 255. Phantom key presses are generated in order to stop the system from acting on \"Windows\" key events when `w32-pass-lwindow-to-system' or -`w32-pass-rwindow-to-system' is nil. */); +`w32-pass-rwindow-to-system' is nil. + +This variable is only used on Windows 98 and ME. For other Windows +versions, see the documentation of the `w32-register-hot-key` +function. */); /* Although 255 is technically not a valid key code, it works and means that this hack won't interfere with any real key code. */ XSETINT (Vw32_phantom_key_code, 255); @@ -9434,7 +9909,9 @@ and it will have the same effect as in other applications. */); doc: /* Modifier to use for the left \"Windows\" key. The value can be hyper, super, meta, alt, control or shift for the respective modifier, or nil to appear as the `lwindow' key. -Any other value will cause the key to be ignored. */); +Any other value will cause the key to be ignored. + +Also see the documentation of the `w32-register-hot-key` function. */); Vw32_lwindow_modifier = Qnil; DEFVAR_LISP ("w32-rwindow-modifier", @@ -9442,7 +9919,9 @@ Any other value will cause the key to be ignored. */); doc: /* Modifier to use for the right \"Windows\" key. The value can be hyper, super, meta, alt, control or shift for the respective modifier, or nil to appear as the `rwindow' key. -Any other value will cause the key to be ignored. */); +Any other value will cause the key to be ignored. + +Also see the documentation of the `w32-register-hot-key` function. */); Vw32_rwindow_modifier = Qnil; DEFVAR_LISP ("w32-apps-modifier", @@ -9618,6 +10097,18 @@ Default is nil. This variable has effect only on Windows Vista and later. */); w32_disable_new_uniscribe_apis = 0; + DEFVAR_LISP ("w32-tooltip-extra-pixels", + Vw32_tooltip_extra_pixels, + doc: /* Number of pixels added after tooltip text. +On Windows some fonts may cause the last character of a tooltip be +truncated or wrapped around to the next line. Adding some extra space +at the end of the toooltip works around this problem. + +This variable specifies the number of pixels that shall be added. The +default value t means to add the width of one canonical character of the +tip frame. */); + Vw32_tooltip_extra_pixels = Qt; + #if 0 /* TODO: Port to W32 */ defsubr (&Sx_change_window_property); defsubr (&Sx_delete_window_property); @@ -9788,7 +10279,7 @@ typedef USHORT (WINAPI * CaptureStackBackTrace_proc) (ULONG, ULONG, PVOID *, #define BACKTRACE_LIMIT_MAX 62 -int +static int w32_backtrace (void **buffer, int limit) { static CaptureStackBackTrace_proc s_pfn_CaptureStackBackTrace = NULL; @@ -9861,8 +10352,8 @@ emacs_abort (void) but not on Windows 7. addr2line doesn't mind a missing "0x", but will be confused by an extra one. */ if (except_addr) - sprintf (buf, "\r\nException 0x%lx at this address:\r\n%p\r\n", - except_code, except_addr); + sprintf (buf, "\r\nException 0x%x at this address:\r\n%p\r\n", + (unsigned int) except_code, except_addr); if (stderr_fd >= 0) { if (except_addr) diff --git a/src/w32font.c b/src/w32font.c index 018e6572563..e966024517f 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -102,7 +102,6 @@ static void list_all_matching_fonts (struct font_callback_data *); static BOOL g_b_init_get_outline_metrics_w; static BOOL g_b_init_get_text_metrics_w; static BOOL g_b_init_get_glyph_outline_w; -static BOOL g_b_init_get_glyph_outline_w; static BOOL g_b_init_get_char_width_32_w; typedef UINT (WINAPI * GetOutlineTextMetricsW_Proc) ( @@ -1688,7 +1687,7 @@ w32_to_x_charset (int fncharset, char *matching) /* Handle startup case of w32-charset-info-alist not being set up yet. */ if (NILP (Vw32_charset_info_alist)) - return "iso8859-1"; + return (char *)"iso8859-1"; charset_type = Qw32_charset_ansi; break; case DEFAULT_CHARSET: @@ -1748,7 +1747,7 @@ w32_to_x_charset (int fncharset, char *matching) default: /* Encode numerical value of unknown charset. */ - sprintf (buf, "*-#%u", fncharset); + sprintf (buf, "*-#%d", fncharset); return buf; } @@ -1835,7 +1834,7 @@ w32_to_x_charset (int fncharset, char *matching) /* If no match, encode the numeric value. */ if (!best_match) { - sprintf (buf, "*-#%u", fncharset); + sprintf (buf, "*-#%d", fncharset); return buf; } @@ -2355,7 +2354,7 @@ w32font_full_name (LOGFONT * font, Lisp_Object font_obj, { if (outline) { - float pointsize = height * 72.0 / one_w32_display_info.resy; + double pointsize = height * 72.0 / one_w32_display_info.resy; /* Round to nearest half point. floor is used, since round is not supported in MS library. */ pointsize = floor (pointsize * 2 + 0.5) / 2; @@ -2536,7 +2535,7 @@ w32font_filter_properties (Lisp_Object font, Lisp_Object alist) struct font_driver w32font_driver = { - LISP_INITIALLY_ZERO, /* Qgdi */ + LISPSYM_INITIALLY (Qgdi), false, /* case insensitive */ w32font_get_cache, w32font_list, @@ -2747,7 +2746,6 @@ versions of Windows) characters. */); defsubr (&Sx_select_font); - w32font_driver.type = Qgdi; register_font_driver (&w32font_driver, NULL); } diff --git a/src/w32font.h b/src/w32font.h index 728ad8be96c..0e2d0f79820 100644 --- a/src/w32font.h +++ b/src/w32font.h @@ -84,7 +84,6 @@ int uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec); Lisp_Object intern_font_name (char *); -extern void syms_of_w32font (void); extern void globals_of_w32font (void); #endif diff --git a/src/w32heap.c b/src/w32heap.c index 3e628d54c42..26a04413df1 100644 --- a/src/w32heap.c +++ b/src/w32heap.c @@ -50,9 +50,11 @@ #include <errno.h> #include <sys/mman.h> +#include <sys/resource.h> #include "w32common.h" #include "w32heap.h" #include "lisp.h" +#include "w32.h" /* for FD_SETSIZE */ /* We chose to leave those declarations here. They are used only in this file. The RtlCreateHeap is available since XP. It is located @@ -114,7 +116,7 @@ typedef struct _RTL_HEAP_PARAMETERS { to build only the first bootstrap-emacs.exe with the large size, and reset that to a lower value afterwards. */ #if defined _WIN64 || defined WIDE_EMACS_INT -# define DUMPED_HEAP_SIZE (20*1024*1024) +# define DUMPED_HEAP_SIZE (21*1024*1024) #else # define DUMPED_HEAP_SIZE (12*1024*1024) #endif @@ -189,7 +191,7 @@ free_fn the_free_fn; claims for new memory. Before dumping, we allocate space from the fixed size dumped_data[] array. */ -NTSTATUS NTAPI +static NTSTATUS NTAPI dumped_data_commit (PVOID Base, PVOID *CommitAddress, PSIZE_T CommitSize) { /* This is used before dumping. @@ -317,15 +319,18 @@ init_heap (void) cache_system_info (); } + +/* malloc, realloc, free. */ + #undef malloc #undef realloc #undef free /* FREEABLE_P checks if the block can be safely freed. */ #define FREEABLE_P(addr) \ - ((unsigned char *)(addr) > 0 \ - && ((unsigned char *)(addr) < dumped_data \ - || (unsigned char *)(addr) >= dumped_data + DUMPED_HEAP_SIZE)) + ((DWORD_PTR)(unsigned char *)(addr) > 0 \ + && ((unsigned char *)(addr) < dumped_data \ + || (unsigned char *)(addr) >= dumped_data + DUMPED_HEAP_SIZE)) void * malloc_after_dump (size_t size) @@ -623,9 +628,12 @@ sbrk (ptrdiff_t increment) return data_region_end; } -#define MAX_BUFFER_SIZE (512 * 1024 * 1024) + /* MMAP allocation for buffers. */ + +#define MAX_BUFFER_SIZE (512 * 1024 * 1024) + void * mmap_alloc (void **var, size_t nbytes) { @@ -708,7 +716,7 @@ mmap_realloc (void **var, size_t nbytes) if (memInfo.RegionSize < nbytes) { memset (&m2, 0, sizeof (m2)); - if (VirtualQuery (*var + memInfo.RegionSize, &m2, sizeof(m2)) == 0) + if (VirtualQuery ((char *)*var + memInfo.RegionSize, &m2, sizeof(m2)) == 0) DebPrint (("mmap_realloc: VirtualQuery error = %ld\n", GetLastError ())); /* If there is enough room in the current reserved area, then @@ -778,7 +786,7 @@ mmap_realloc (void **var, size_t nbytes) } /* We still can decommit pages. */ - if (VirtualFree (*var + nbytes + get_page_size(), + if (VirtualFree ((char *)*var + nbytes + get_page_size(), memInfo.RegionSize - nbytes - get_page_size(), MEM_DECOMMIT) == 0) DebPrint (("mmap_realloc: VirtualFree error %ld\n", GetLastError ())); @@ -788,3 +796,78 @@ mmap_realloc (void **var, size_t nbytes) /* Not enlarging, not shrinking by more than one page. */ return *var; } + + +/* Emulation of getrlimit and setrlimit. */ + +int +getrlimit (rlimit_resource_t rltype, struct rlimit *rlp) +{ + int retval = -1; + + switch (rltype) + { + case RLIMIT_STACK: + { + MEMORY_BASIC_INFORMATION m; + /* Implementation note: Posix says that RLIMIT_STACK returns + information about the stack size for the main thread. The + implementation below returns the stack size for the calling + thread, so it's more like pthread_attr_getstacksize. But + Emacs clearly wants the latter, given how it uses the + results, so the implementation below is more future-proof, + if what's now the main thread will become some other thread + at some future point. */ + if (!VirtualQuery ((LPCVOID) &m, &m, sizeof m)) + errno = EPERM; + else + { + rlp->rlim_cur = (DWORD_PTR) &m - (DWORD_PTR) m.AllocationBase; + rlp->rlim_max = + (DWORD_PTR) m.BaseAddress + m.RegionSize + - (DWORD_PTR) m.AllocationBase; + + /* The last page is the guard page, so subtract that. */ + rlp->rlim_cur -= getpagesize (); + rlp->rlim_max -= getpagesize (); + retval = 0; + } + } + break; + case RLIMIT_NOFILE: + /* Implementation note: The real value is returned by + _getmaxstdio. But our FD_SETSIZE is smaller, to cater to + Windows 9X, and process.c includes some logic that's based on + the assumption that the handle resource is inherited to child + processes. We want to avoid that logic, so we tell process.c + our current limit is already equal to FD_SETSIZE. */ + rlp->rlim_cur = FD_SETSIZE; + rlp->rlim_max = 2048; /* see _setmaxstdio documentation */ + retval = 0; + break; + default: + /* Note: we could return meaningful results for other RLIMIT_* + requests, but Emacs doesn't currently need that, so we just + punt for them. */ + errno = ENOSYS; + break; + } + return retval; +} + +int +setrlimit (rlimit_resource_t rltype, const struct rlimit *rlp) +{ + switch (rltype) + { + case RLIMIT_STACK: + case RLIMIT_NOFILE: + /* We cannot modfy these limits, so we always fail. */ + errno = EPERM; + break; + default: + errno = ENOSYS; + break; + } + return -1; +} diff --git a/src/w32heap.h b/src/w32heap.h index 523bcebe125..4f2d6c82a78 100644 --- a/src/w32heap.h +++ b/src/w32heap.h @@ -61,10 +61,10 @@ int open_output_file (file_data *p_file, char *name, unsigned long size); void close_file_data (file_data *p_file); /* Return pointer to section header for named section. */ -IMAGE_SECTION_HEADER * find_section (char * name, IMAGE_NT_HEADERS * nt_header); +IMAGE_SECTION_HEADER * find_section (const char *, IMAGE_NT_HEADERS *); /* Return pointer to section header for section containing the given relative virtual address. */ -IMAGE_SECTION_HEADER * rva_to_section (DWORD_PTR rva, IMAGE_NT_HEADERS * nt_header); +IMAGE_SECTION_HEADER * rva_to_section (DWORD_PTR, IMAGE_NT_HEADERS *); #endif /* NTHEAP_H_ */ diff --git a/src/w32inevt.c b/src/w32inevt.c index 867425f0bf2..2269d318051 100644 --- a/src/w32inevt.c +++ b/src/w32inevt.c @@ -41,6 +41,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "termchar.h" /* for Mouse_HLInfo, tty_display_info */ #include "w32term.h" #include "w32inevt.h" +#include "w32common.h" /* stdin, from w32console.c */ extern HANDLE keyboard_handle; @@ -148,10 +149,12 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead) switch (event->wVirtualKeyCode) { case VK_LWIN: - mod_key_state &= ~LEFT_WIN_PRESSED; + if (!w32_kbdhook_active) + mod_key_state &= ~LEFT_WIN_PRESSED; break; case VK_RWIN: - mod_key_state &= ~RIGHT_WIN_PRESSED; + if (!w32_kbdhook_active) + mod_key_state &= ~RIGHT_WIN_PRESSED; break; case VK_APPS: mod_key_state &= ~APPS_PRESSED; @@ -185,7 +188,8 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead) keybd_event (faked_key, (BYTE) MapVirtualKey (faked_key, 0), 0, 0); } } - mod_key_state |= LEFT_WIN_PRESSED; + if (!w32_kbdhook_active) + mod_key_state |= LEFT_WIN_PRESSED; if (!NILP (Vw32_lwindow_modifier)) return 0; break; @@ -201,7 +205,8 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead) keybd_event (faked_key, (BYTE) MapVirtualKey (faked_key, 0), 0, 0); } } - mod_key_state |= RIGHT_WIN_PRESSED; + if (!w32_kbdhook_active) + mod_key_state |= RIGHT_WIN_PRESSED; if (!NILP (Vw32_rwindow_modifier)) return 0; break; @@ -267,6 +272,13 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead) /* Recognize state of Windows and Apps keys. */ event->dwControlKeyState |= mod_key_state; + if (w32_kbdhook_active) + { + if (check_w32_winkey_state (VK_LWIN)) + event->dwControlKeyState |= LEFT_WIN_PRESSED; + if (check_w32_winkey_state (VK_RWIN)) + event->dwControlKeyState |= RIGHT_WIN_PRESSED; + } /* Distinguish numeric keypad keys from extended keys. */ event->wVirtualKeyCode = @@ -608,70 +620,89 @@ maybe_generate_resize_event (void) int handle_file_notifications (struct input_event *hold_quit) { - BYTE *p = file_notifications; - FILE_NOTIFY_INFORMATION *fni = (PFILE_NOTIFY_INFORMATION)p; - const DWORD min_size - = offsetof (FILE_NOTIFY_INFORMATION, FileName) + sizeof(wchar_t); - struct input_event inev; + struct notifications_set *ns = NULL; int nevents = 0; + int done = 0; /* We cannot process notification before Emacs is fully initialized, since we need the UTF-16LE coding-system to be set up. */ if (!initialized) { - notification_buffer_in_use = 0; return nevents; } - enter_crit (); - if (notification_buffer_in_use) + while (!done) { - DWORD info_size = notifications_size; - Lisp_Object cs = Qutf_16le; - Lisp_Object obj = w32_get_watch_object (notifications_desc); - - /* notifications_size could be zero when the buffer of - notifications overflowed on the OS level, or when the - directory being watched was itself deleted. Do nothing in - that case. */ - if (info_size - && !NILP (obj) && CONSP (obj)) - { - Lisp_Object callback = XCDR (obj); + ns = NULL; - EVENT_INIT (inev); + /* Find out if there is a record available in the linked list of + notifications sets. If so, unlink te set from the linked list. + Use the critical section. */ + enter_crit (); + if (notifications_set_head->next != notifications_set_head) + { + ns = notifications_set_head->next; + ns->prev->next = ns->next; + ns->next->prev = ns->prev; + } + else + done = 1; + leave_crit(); - while (info_size >= min_size) + if (ns) + { + BYTE *p = ns->notifications; + FILE_NOTIFY_INFORMATION *fni = (PFILE_NOTIFY_INFORMATION)p; + const DWORD min_size + = offsetof (FILE_NOTIFY_INFORMATION, FileName) + sizeof(wchar_t); + struct input_event inev; + DWORD info_size = ns->size; + Lisp_Object cs = Qutf_16le; + Lisp_Object obj = w32_get_watch_object (ns->desc); + + /* notifications size could be zero when the buffer of + notifications overflowed on the OS level, or when the + directory being watched was itself deleted. Do nothing in + that case. */ + if (info_size + && !NILP (obj) && CONSP (obj)) { - Lisp_Object utf_16_fn - = make_unibyte_string ((char *)fni->FileName, - fni->FileNameLength); - /* Note: mule-conf is preloaded, so utf-16le must - already be defined at this point. */ - Lisp_Object fname - = code_convert_string_norecord (utf_16_fn, cs, 0); - Lisp_Object action = lispy_file_action (fni->Action); - - inev.kind = FILE_NOTIFY_EVENT; - inev.timestamp = GetTickCount (); - inev.modifiers = 0; - inev.frame_or_window = callback; - inev.arg = Fcons (action, fname); - inev.arg = list3 (make_pointer_integer (notifications_desc), - action, fname); - kbd_buffer_store_event_hold (&inev, hold_quit); - nevents++; - - if (!fni->NextEntryOffset) - break; - p += fni->NextEntryOffset; - fni = (PFILE_NOTIFY_INFORMATION)p; - info_size -= fni->NextEntryOffset; + Lisp_Object callback = XCDR (obj); + + EVENT_INIT (inev); + + while (info_size >= min_size) + { + Lisp_Object utf_16_fn + = make_unibyte_string ((char *)fni->FileName, + fni->FileNameLength); + /* Note: mule-conf is preloaded, so utf-16le must + already be defined at this point. */ + Lisp_Object fname + = code_convert_string_norecord (utf_16_fn, cs, 0); + Lisp_Object action = lispy_file_action (fni->Action); + + inev.kind = FILE_NOTIFY_EVENT; + inev.timestamp = GetTickCount (); + inev.modifiers = 0; + inev.frame_or_window = callback; + inev.arg = Fcons (action, fname); + inev.arg = list3 (make_pointer_integer (ns->desc), + action, fname); + kbd_buffer_store_event_hold (&inev, hold_quit); + nevents++; + if (!fni->NextEntryOffset) + break; + p += fni->NextEntryOffset; + fni = (PFILE_NOTIFY_INFORMATION)p; + info_size -= fni->NextEntryOffset; + } } + /* Free this notification set. */ + free (ns->notifications); + free (ns); } - notification_buffer_in_use = 0; } - leave_crit (); return nevents; } #else /* !HAVE_W32NOTIFY */ diff --git a/src/w32menu.c b/src/w32menu.c index d9ab8f5e518..7c66360becd 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -60,9 +60,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ HMENU current_popup_menu; -void syms_of_w32menu (void); -void globals_of_w32menu (void); - typedef BOOL (WINAPI * GetMenuItemInfoA_Proc) ( IN HMENU, IN UINT, @@ -80,10 +77,10 @@ typedef int (WINAPI * MessageBoxW_Proc) ( IN UINT type); #ifdef NTGUI_UNICODE -#define get_menu_item_info GetMenuItemInfoA -#define set_menu_item_info SetMenuItemInfoA -#define unicode_append_menu AppendMenuW -#define unicode_message_box MessageBoxW +GetMenuItemInfoA_Proc get_menu_item_info = GetMenuItemInfoA; +SetMenuItemInfoA_Proc set_menu_item_info = SetMenuItemInfoA; +AppendMenuW_Proc unicode_append_menu = AppendMenuW; +MessageBoxW_Proc unicode_message_box = MessageBoxW; #else /* !NTGUI_UNICODE */ GetMenuItemInfoA_Proc get_menu_item_info = NULL; SetMenuItemInfoA_Proc set_menu_item_info = NULL; @@ -91,8 +88,6 @@ AppendMenuW_Proc unicode_append_menu = NULL; MessageBoxW_Proc unicode_message_box = NULL; #endif /* NTGUI_UNICODE */ -void set_frame_menubar (struct frame *, bool, bool); - #ifdef HAVE_DIALOGS static Lisp_Object w32_dialog_show (struct frame *, Lisp_Object, Lisp_Object, char **); #else @@ -172,6 +167,7 @@ x_activate_menubar (struct frame *f) when the user makes a selection. Figure out what the user chose and put the appropriate events into the keyboard buffer. */ +void menubar_selection_callback (struct frame *, void *); void menubar_selection_callback (struct frame *f, void * client_data) @@ -831,7 +827,7 @@ w32_menu_show (struct frame *f, int x, int y, int menuflags, { unblock_input (); /* Make "Cancel" equivalent to C-g. */ - Fsignal (Qquit, Qnil); + quit (); } unblock_input (); @@ -1023,7 +1019,7 @@ w32_dialog_show (struct frame *f, Lisp_Object title, } else /* Make "Cancel" equivalent to C-g. */ - Fsignal (Qquit, Qnil); + quit (); return Qnil; } @@ -1111,7 +1107,7 @@ simple_dialog_show (struct frame *f, Lisp_Object contents, Lisp_Object header) } else { - text = L""; + text = (WCHAR *)L""; } if (NILP (header)) @@ -1159,7 +1155,7 @@ simple_dialog_show (struct frame *f, Lisp_Object contents, Lisp_Object header) else if (answer == IDNO) lispy_answer = build_string ("No"); else - Fsignal (Qquit, Qnil); + quit (); for (temp = XCDR (contents); CONSP (temp); temp = XCDR (temp)) { @@ -1181,8 +1177,7 @@ simple_dialog_show (struct frame *f, Lisp_Object contents, Lisp_Object header) return value; } } - Fsignal (Qquit, Qnil); - return Qnil; + return quit (); } #endif /* !HAVE_DIALOGS */ @@ -1465,6 +1460,8 @@ fill_in_menu (HMENU menu, widget_value *wv) /* Display help string for currently pointed to menu item. Not supported on NT 3.51 and earlier, as GetMenuItemInfo is not available. */ +void w32_menu_display_help (HWND, HMENU, UINT, UINT); + void w32_menu_display_help (HWND owner, HMENU menu, UINT item, UINT flags) { diff --git a/src/w32notify.c b/src/w32notify.c index 586c2062f62..e23e2b8740c 100644 --- a/src/w32notify.c +++ b/src/w32notify.c @@ -22,27 +22,30 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ For each watch request, we launch a separate worker thread. The worker thread runs the watch_worker function, which issues an - asynchronous call to ReadDirectoryChangesW, and then waits in - SleepEx for that call to complete. Waiting in SleepEx puts the - thread in an "alertable" state, so it wakes up when either (a) the - call to ReadDirectoryChangesW completes, or (b) the main thread - instructs the worker thread to terminate by sending it an APC, see - below. + asynchronous call to ReadDirectoryChangesW, and then calls + WaitForSingleObjectEx to wait that an event be signaled + to terminate the thread. + Waiting with WaitForSingleObjectEx puts the thread in an + "alertable" state, so it wakes up when either (a) the call to + ReadDirectoryChangesW completes, or (b) the main thread instructs + the worker thread to terminate by signaling an event, see below. When the ReadDirectoryChangesW call completes, its completion routine watch_completion is automatically called. watch_completion - stashes the received file events in a buffer used to communicate - them to the main thread (using a critical section, so that several - threads could use the same buffer), posts a special message, - WM_EMACS_FILENOTIFY, to the Emacs's message queue, and returns. - That causes the SleepEx function call inside watch_worker to - return, and watch_worker then issues another call to - ReadDirectoryChangesW. (Except when it does not, see below.) + stashes the received file events in a linked list used to + communicate them to the main thread (using a critical section, so + that several threads could alter the same linked list), posts a + special message, WM_EMACS_FILENOTIFY, to the Emacs's message queue, + and returns. That causes the WaitForSingleObjectEx function call + inside watch_worker to return, but the thread won't terminate until + the event telling to do so will be signaled. The completion + routine issued another call to ReadDirectoryChangesW as quickly as + possible. (Except when it does not, see below.) In a GUI session, the WM_EMACS_FILENOTIFY message posted to the message queue gets dispatched to the main Emacs window procedure, which queues it for processing by w32_read_socket. When - w32_read_socket sees this message, it accesses the buffer with file + w32_read_socket sees this message, it accesses the linked list with file notifications (using a critical section), extracts the information, converts it to a series of FILE_NOTIFY_EVENT events, and stuffs them into the input event queue to be processed by keyboard.c input @@ -53,7 +56,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ procedures in console programs. That message wakes up MsgWaitForMultipleObjects inside sys_select, which then signals to its caller that some keyboard input is available. This causes - w32_console_read_socket to be called, which accesses the buffer + w32_console_read_socket to be called, which accesses the linked list with file notifications and stuffs them into the input event queue for keyboard.c to process. @@ -62,30 +65,30 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ bound to a command. The default binding is file-notify-handle-event, defined on subr.el. - After w32_read_socket or w32_console_read_socket are done - processing the notifications, they reset a flag signaling to all - watch worker threads that the notifications buffer is available for - more input. + Routines w32_read_socket or w32_console_read_socket process notifications + sets as long as some are available. When the watch is removed by a call to w32notify-rm-watch, the main - thread requests that the worker thread terminates by queuing an APC - for the worker thread. The APC specifies the watch_end function to - be called. watch_end calls CancelIo on the outstanding - ReadDirectoryChangesW call and closes the handle on which the - watched directory was open. When watch_end returns, the - watch_completion function is called one last time with the - ERROR_OPERATION_ABORTED status, which causes it to clean up and set - a flag telling watch_worker to exit without issuing another - ReadDirectoryChangesW call. Since watch_worker is the thread - procedure of the worker thread, exiting it causes the thread to - exit. The main thread waits for some time for the worker thread to - exit, and if it doesn't, terminates it forcibly. */ + thread requests that the worker thread terminates by signaling the + appropriate event and queuing an APC for the worker thread. The + APC specifies the watch_end function to be called. watch_end calls + CancelIo on the outstanding ReadDirectoryChangesW call. When + watch_end returns, the watch_completion function is called one last + time with the ERROR_OPERATION_ABORTED status, which causes it to + clean up and set a flag telling watch_worker to exit without + issuing another ReadDirectoryChangesW call. Since watch_worker is + the thread procedure of the worker thread, exiting it causes the + thread to exit. The main thread waits for some time for the worker + thread to exit, and if it doesn't, terminates it forcibly. */ + +#define DEFER_MS_W32_H +#include <config.h> #include <stddef.h> #include <errno.h> -/* must include CRT headers *before* config.h */ -#include <config.h> +/* Include CRT headers *before* ms-w32.h. */ +#include <ms-w32.h> #include <windows.h> @@ -98,6 +101,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "frame.h" /* needed by termhooks.h */ #include "termhooks.h" /* for FILE_NOTIFY_EVENT */ +#define DIRWATCH_BUFFER_SIZE 16384 #define DIRWATCH_SIGNATURE 0x01233210 struct notification { @@ -108,73 +112,53 @@ struct notification { char *watchee; /* the file we are interested in, UTF-8 encoded */ HANDLE dir; /* handle to the watched directory */ HANDLE thr; /* handle to the thread that watches */ - volatile int terminate; /* if non-zero, request for the thread to terminate */ + HANDLE terminate; /* event signaling the thread to terminate */ unsigned signature; }; /* Used for communicating notifications to the main thread. */ -volatile int notification_buffer_in_use; -BYTE file_notifications[16384]; -DWORD notifications_size; -void *notifications_desc; +struct notifications_set *notifications_set_head; static Lisp_Object watch_list; /* Signal to the main thread that we have file notifications for it to process. */ static void -send_notifications (BYTE *info, DWORD info_size, void *desc, - volatile int *terminate) +send_notifications (struct notifications_set *ns) { - int done = 0; struct frame *f = SELECTED_FRAME (); - /* A single buffer is used to communicate all notifications to the - main thread. Since both the main thread and several watcher - threads could be active at the same time, we use a critical area - and an "in-use" flag to synchronize them. A watcher thread can - only put its notifications in the buffer if it acquires the - critical area and finds the "in-use" flag reset. The main thread - resets the flag after it is done processing notifications. - - FIXME: is there a better way of dealing with this? */ - while (!done && !*terminate) - { + /* We add the current notification set to the linked list. Use the + critical section to make sure only one thread will access the + linked list. */ enter_crit (); - if (!notification_buffer_in_use) - { - if (info_size) - memcpy (file_notifications, info, - min (info_size, sizeof (file_notifications))); - notifications_size = min (info_size, sizeof (file_notifications)); - notifications_desc = desc; - /* If PostMessage fails, the message queue is full. If that - happens, the last thing they will worry about is file - notifications. So we effectively discard the - notification in that case. */ - if ((FRAME_TERMCAP_P (f) - /* We send the message to the main (a.k.a. "Lisp") - thread, where it will wake up MsgWaitForMultipleObjects - inside sys_select, causing it to report that there's - some keyboard input available. This will in turn cause - w32_console_read_socket to be called, which will pick - up the file notifications. */ - && PostThreadMessage (dwMainThreadId, WM_EMACS_FILENOTIFY, 0, 0)) - || (FRAME_W32_P (f) - && PostMessage (FRAME_W32_WINDOW (f), - WM_EMACS_FILENOTIFY, 0, 0)) - /* When we are running in batch mode, there's no one to - send a message, so we just signal the data is - available and hope sys_select will be called soon and - will read the data. */ - || (FRAME_INITIAL_P (f) && noninteractive)) - notification_buffer_in_use = 1; - done = 1; - } - leave_crit (); - if (!done) - Sleep (5); - } + ns->next = notifications_set_head; + ns->prev = notifications_set_head->prev; + ns->prev->next = ns; + notifications_set_head->prev = ns; + leave_crit(); + + /* If PostMessage fails, the message queue is full. If that + happens, the last thing they will worry about is file + notifications. So we effectively discard the notification in + that case. */ + if (FRAME_TERMCAP_P (f)) + /* We send the message to the main (a.k.a. "Lisp") thread, where + it will wake up MsgWaitForMultipleObjects inside sys_select, + causing it to report that there's some keyboard input + available. This will in turn cause w32_console_read_socket to + be called, which will pick up the file notifications. */ + PostThreadMessage (dwMainThreadId, WM_EMACS_FILENOTIFY, 0, 0); + else if (FRAME_W32_P (f)) + PostMessage (FRAME_W32_WINDOW (f), + WM_EMACS_FILENOTIFY, 0, 0); + /* When we are running in batch mode, there's no one to send a + message, so we just signal the data is available and hope + sys_select will be called soon and will read the data. */ +#if 0 + else if (FRAME_INITIAL_P (f) && noninteractive) + ; +#endif } /* An APC routine to cancel outstanding directory watch. Invoked by @@ -182,33 +166,40 @@ send_notifications (BYTE *info, DWORD info_size, void *desc, thread that issued the ReadDirectoryChangesW call can call CancelIo to cancel that. (CancelIoEx is only available since Vista, so we cannot use it on XP.) */ +VOID CALLBACK watch_end (ULONG_PTR); + VOID CALLBACK watch_end (ULONG_PTR arg) { HANDLE hdir = (HANDLE)arg; if (hdir && hdir != INVALID_HANDLE_VALUE) - { - CancelIo (hdir); - CloseHandle (hdir); - } + CancelIo (hdir); } /* A completion routine (a.k.a. "APC function") for handling events read by ReadDirectoryChangesW. Called by the OS when the thread which issued the asynchronous ReadDirectoryChangesW call is in the "alertable state", i.e. waiting inside SleepEx call. */ +VOID CALLBACK watch_completion (DWORD, DWORD, OVERLAPPED *); + VOID CALLBACK watch_completion (DWORD status, DWORD bytes_ret, OVERLAPPED *io_info) { struct notification *dirwatch; + DWORD _bytes; + struct notifications_set *ns = NULL; + BOOL terminate = FALSE; /* Who knows what happened? Perhaps the OVERLAPPED structure was freed by someone already? In any case, we cannot do anything with this request, so just punt and skip it. FIXME: should we raise the 'terminate' flag in this case? */ if (!io_info) - return; + { + DebPrint(("watch_completion: io_info is null.\n")); + return; + } /* We have a pointer to our dirwatch structure conveniently stashed away in the hEvent member of the OVERLAPPED struct. According to @@ -216,26 +207,69 @@ watch_completion (DWORD status, DWORD bytes_ret, OVERLAPPED *io_info) of the OVERLAPPED structure is not used by the system, so you can use it yourself." */ dirwatch = (struct notification *)io_info->hEvent; + if (status == ERROR_OPERATION_ABORTED) { /* We've been called because the main thread told us to issue CancelIo on the directory we watch, and watch_end did so. - The directory handle is already closed. We should clean up - and exit, signaling to the thread worker routine not to - issue another call to ReadDirectoryChangesW. Note that we - don't free the dirwatch object itself nor the memory consumed - by its buffers; this is done by the main thread in - remove_watch. Calling malloc/free from a thread other than - the main thread is a no-no. */ - dirwatch->dir = NULL; - dirwatch->terminate = 1; + We must exit, without issuing another call to + ReadDirectoryChangesW. */ + return; } - else + + /* We allocate a new set of notifications to be linked to the linked + list of notifications set. This will be processed by Emacs event + loop in the main thread. We need to duplicate the notifications + buffer, but not the dirwatch structure. */ + + /* Implementation note: In general, allocating memory in non-main + threads is a no-no in Emacs. We certainly cannot call xmalloc + and friends, because it can longjmp when allocation fails, which + will crash Emacs because the jmp_buf is set up to a location on + the main thread's stack. However, we can call 'malloc' directly, + since that is redirected to HeapAlloc that uses our private heap, + see w32heap.c, and that is thread-safe. */ + ns = malloc (sizeof(struct notifications_set)); + if (ns) + { + memset (ns, 0, sizeof(struct notifications_set)); + ns->notifications = malloc (bytes_ret); + if (ns->notifications) + { + memcpy (ns->notifications, dirwatch->buf, bytes_ret); + ns->size = bytes_ret; + ns->desc = dirwatch; + } + else + { + free (ns); + ns = NULL; + } + } + if (ns == NULL) + DebPrint(("Out of memory. Notifications lost.")); + + /* Calling ReadDirectoryChangesW quickly to watch again for new + notifications. */ + if (!ReadDirectoryChangesW (dirwatch->dir, dirwatch->buf, + DIRWATCH_BUFFER_SIZE, dirwatch->subtree, + dirwatch->filter, &_bytes, dirwatch->io_info, + watch_completion)) { - /* Tell the main thread we have notifications for it. */ - send_notifications (dirwatch->buf, bytes_ret, dirwatch, - &dirwatch->terminate); + DebPrint (("ReadDirectoryChangesW error: %lu\n", GetLastError ())); + /* If this call fails, it means that the directory is not + watchable any more. We need to terminate the worker thread. + Still, we will wait until the current notifications have been + sent to the main thread. */ + terminate = TRUE; } + + if (ns) + send_notifications(ns); + + /* If we were asked to terminate the thread, then fire the event. */ + if (terminate) + SetEvent(dirwatch->terminate); } /* Worker routine for the watch thread. */ @@ -243,42 +277,43 @@ static DWORD WINAPI watch_worker (LPVOID arg) { struct notification *dirwatch = (struct notification *)arg; + BOOL bErr; + DWORD _bytes = 0; + DWORD status; + + if (dirwatch->dir) + { + bErr = ReadDirectoryChangesW (dirwatch->dir, dirwatch->buf, + DIRWATCH_BUFFER_SIZE, dirwatch->subtree, + dirwatch->filter, &_bytes, + dirwatch->io_info, watch_completion); + if (!bErr) + { + DebPrint (("ReadDirectoryChangesW: %lu\n", GetLastError ())); + /* We cannot remove the dirwatch object from watch_list, + because we are in a separate thread. For the same + reason, we also cannot free memory consumed by the + buffers allocated for the dirwatch object. So we close + the directory handle, but do not free the object itself + or its buffers. We also don't touch the signature. This + way, remove_watch can still identify the object, remove + it, and free its memory. */ + CloseHandle (dirwatch->dir); + dirwatch->dir = NULL; + return 1; + } + } do { - BOOL status; - DWORD bytes_ret = 0; - - if (dirwatch->dir) - { - status = ReadDirectoryChangesW (dirwatch->dir, dirwatch->buf, 16384, - dirwatch->subtree, dirwatch->filter, - &bytes_ret, - dirwatch->io_info, watch_completion); - if (!status) - { - DebPrint (("watch_worker, abnormal exit: %lu\n", GetLastError ())); - /* We cannot remove the dirwatch object from watch_list, - because we are in a separate thread. For the same - reason, we also cannot free memory consumed by the - buffers allocated for the dirwatch object. So we close - the directory handle, but do not free the object itself - or its buffers. We also don't touch the signature. - This way, remove_watch can still identify the object, - remove it, and free its memory. */ - CloseHandle (dirwatch->dir); - dirwatch->dir = NULL; - return 1; - } - } - /* Sleep indefinitely until awoken by the I/O completion, which - could be either a change notification or a cancellation of the - watch. */ - SleepEx (INFINITE, TRUE); - } while (!dirwatch->terminate); + status = WaitForSingleObjectEx(dirwatch->terminate, INFINITE, TRUE); + } while (status == WAIT_IO_COMPLETION); + + /* The thread is about to terminate, so we clean up the dir handle. */ + CloseHandle (dirwatch->dir); + dirwatch->dir = NULL; return 0; } - /* Launch a thread to watch changes to FILE in a directory open on handle HDIR. */ static struct notification * @@ -287,7 +322,7 @@ start_watching (const char *file, HANDLE hdir, BOOL subdirs, DWORD flags) struct notification *dirwatch = xzalloc (sizeof (struct notification)); dirwatch->signature = DIRWATCH_SIGNATURE; - dirwatch->buf = xmalloc (16384); + dirwatch->buf = xmalloc (DIRWATCH_BUFFER_SIZE); dirwatch->io_info = xzalloc (sizeof(OVERLAPPED)); /* Stash a pointer to dirwatch structure for use by the completion routine. According to MSDN documentation of ReadDirectoryChangesW: @@ -297,7 +332,9 @@ start_watching (const char *file, HANDLE hdir, BOOL subdirs, DWORD flags) dirwatch->subtree = subdirs; dirwatch->filter = flags; dirwatch->watchee = xstrdup (file); - dirwatch->terminate = 0; + + dirwatch->terminate = CreateEvent(NULL, FALSE, FALSE, NULL); + dirwatch->dir = hdir; /* See w32proc.c where it calls CreateThread for the story behind @@ -307,11 +344,11 @@ start_watching (const char *file, HANDLE hdir, BOOL subdirs, DWORD flags) if (!dirwatch->thr) { + CloseHandle(dirwatch->terminate); xfree (dirwatch->buf); xfree (dirwatch->io_info); xfree (dirwatch->watchee); xfree (dirwatch); - dirwatch = NULL; } return dirwatch; } @@ -370,7 +407,10 @@ add_watch (const char *parent_dir, const char *file, BOOL subdirs, DWORD flags) return NULL; if ((dirwatch = start_watching (file, hdir, subdirs, flags)) == NULL) - CloseHandle (hdir); + { + CloseHandle (hdir); + dirwatch->dir = NULL; + } return dirwatch; } @@ -383,7 +423,7 @@ remove_watch (struct notification *dirwatch) { int i; BOOL status; - DWORD exit_code, err; + DWORD exit_code = 0, err; /* Only the thread that issued the outstanding I/O call can call CancelIo on it. (CancelIoEx is available only since Vista.) @@ -391,12 +431,10 @@ remove_watch (struct notification *dirwatch) to terminate. */ if (!QueueUserAPC (watch_end, dirwatch->thr, (ULONG_PTR)dirwatch->dir)) DebPrint (("QueueUserAPC failed (%lu)!\n", GetLastError ())); - /* We also set the terminate flag, for when the thread is - waiting on the critical section that never gets acquired. - FIXME: is there a cleaner method? Using SleepEx there is a - no-no, as that will lead to recursive APC invocations and - stack overflow. */ - dirwatch->terminate = 1; + + /* We also signal the thread that it can terminate. */ + SetEvent(dirwatch->terminate); + /* Wait for the thread to exit. FIXME: is there a better method that is not overly complex? */ for (i = 0; i < 50; i++) @@ -406,11 +444,13 @@ remove_watch (struct notification *dirwatch) break; Sleep (10); } + if ((status == FALSE && (err = GetLastError ()) == ERROR_INVALID_HANDLE) || exit_code == STILL_ACTIVE) { if (!(status == FALSE && err == ERROR_INVALID_HANDLE)) { + DebPrint(("Forcing thread termination.\n")); TerminateThread (dirwatch->thr, 0); if (dirwatch->dir) CloseHandle (dirwatch->dir); @@ -423,11 +463,11 @@ remove_watch (struct notification *dirwatch) CloseHandle (dirwatch->thr); dirwatch->thr = NULL; } + CloseHandle(dirwatch->terminate); xfree (dirwatch->buf); xfree (dirwatch->io_info); xfree (dirwatch->watchee); xfree (dirwatch); - return 0; } else @@ -630,7 +670,7 @@ w32_get_watch_object (void *desc) } DEFUN ("w32notify-valid-p", Fw32notify_valid_p, Sw32notify_valid_p, 1, 1, 0, - doc: /* "Check a watch specified by its WATCH-DESCRIPTOR for validity. + doc: /* Check a watch specified by its WATCH-DESCRIPTOR for validity. WATCH-DESCRIPTOR should be an object returned by `w32notify-add-watch'. diff --git a/src/w32proc.c b/src/w32proc.c index 4a6f7862801..6f3a6e0efca 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -22,6 +22,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ Adapted from alarm.c by Tim Fleehart */ +#define DEFER_MS_W32_H +#include <config.h> + #include <mingw_time.h> #include <stdio.h> #include <stdlib.h> @@ -35,8 +38,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <mbstring.h> #include <locale.h> -/* must include CRT headers *before* config.h */ -#include <config.h> +/* Include CRT headers *before* ms-w32.h. */ +#include <ms-w32.h> #undef signal #undef wait @@ -45,11 +48,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #undef kill #include <windows.h> -#if defined(__GNUC__) && !defined(__MINGW64__) -/* This definition is missing from mingw.org headers, but not MinGW64 - headers. */ -extern BOOL WINAPI IsValidLocale (LCID, DWORD); -#endif #ifdef HAVE_LANGINFO_CODESET #include <nl_types.h> @@ -70,6 +68,12 @@ extern BOOL WINAPI IsValidLocale (LCID, DWORD); + ((DWORD_PTR)(var) - (section)->VirtualAddress) \ + (filedata).file_base)) +extern BOOL g_b_init_compare_string_w; +extern BOOL g_b_init_debug_break_process; + +int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, + const struct timespec *, const sigset_t *); + /* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */ static signal_handler sig_handlers[NSIG]; @@ -87,9 +91,9 @@ sys_signal (int sig, signal_handler handler) /* SIGCHLD is needed for supporting subprocesses, see sys_kill below. SIGALRM and SIGPROF are used by setitimer. All the others are the only ones supported by the MS runtime. */ - if (!(sig == SIGCHLD || sig == SIGSEGV || sig == SIGILL + if (!(sig == SIGINT || sig == SIGSEGV || sig == SIGILL || sig == SIGFPE || sig == SIGABRT || sig == SIGTERM - || sig == SIGALRM || sig == SIGPROF)) + || sig == SIGCHLD || sig == SIGALRM || sig == SIGPROF)) { errno = EINVAL; return SIG_ERR; @@ -225,7 +229,7 @@ sigismember (const sigset_t *set, int signo) errno = EINVAL; return -1; } - if (signo > sizeof (*set) * BITS_PER_CHAR) + if (signo > sizeof (*set) * CHAR_BIT) emacs_abort (); return (*set & (1U << signo)) != 0; @@ -845,8 +849,8 @@ alarm (int seconds) stream is terminated, terminates the reader thread as part of deleting the child_process object. - The sys_select function emulates the Posix 'pselect' function; it - is needed because the Windows 'select' function supports only + The sys_select function emulates the Posix 'pselect' functionality; + it is needed because the Windows 'select' function supports only network sockets, while Emacs expects 'pselect' to work for any file descriptor, including pipes and serial streams. @@ -1728,7 +1732,7 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp) are not expanded if we run the program directly without a shell. Some extra whitespace characters need quoting in Cygwin/MSYS programs, so this list is conditionally modified below. */ - char *sepchars = " \t*?"; + const char *sepchars = " \t*?"; /* This is for native w32 apps; modified below for Cygwin/MSUS apps. */ char escape_char = '\\'; char cmdname_a[MAX_PATH]; @@ -2092,7 +2096,7 @@ extern int proc_buffered_char[]; int sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, - struct timespec *timeout, void *ignored) + const struct timespec *timeout, const sigset_t *ignored) { SELECT_TYPE orfds, owfds; DWORD timeout_ms, start_time; @@ -2495,6 +2499,9 @@ find_child_console (HWND hwnd, LPARAM arg) return TRUE; } +typedef BOOL (WINAPI * DebugBreakProcess_Proc) ( + HANDLE hProcess); + /* Emulate 'kill', but only for other processes. */ int sys_kill (pid_t pid, int sig) @@ -2508,9 +2515,9 @@ sys_kill (pid_t pid, int sig) if (pid < 0) pid = -pid; - /* Only handle signals that will result in the process dying */ + /* Only handle signals that can be mapped to a similar behavior on Windows */ if (sig != 0 - && sig != SIGINT && sig != SIGKILL && sig != SIGQUIT && sig != SIGHUP) + && sig != SIGINT && sig != SIGKILL && sig != SIGQUIT && sig != SIGHUP && sig != SIGTRAP) { errno = EINVAL; return -1; @@ -2553,7 +2560,11 @@ sys_kill (pid_t pid, int sig) close the selected frame, which does not necessarily terminates Emacs. But then we are not supposed to call sys_kill with our own PID. */ - proc_hand = OpenProcess (PROCESS_TERMINATE, 0, pid); + + DWORD desiredAccess = + (sig == SIGTRAP) ? PROCESS_ALL_ACCESS : PROCESS_TERMINATE; + + proc_hand = OpenProcess (desiredAccess, 0, pid); if (proc_hand == NULL) { errno = EPERM; @@ -2649,6 +2660,43 @@ sys_kill (pid_t pid, int sig) rc = -1; } } + else if (sig == SIGTRAP) + { + static DebugBreakProcess_Proc s_pfn_Debug_Break_Process = NULL; + + if (g_b_init_debug_break_process == 0) + { + g_b_init_debug_break_process = 1; + s_pfn_Debug_Break_Process = (DebugBreakProcess_Proc) + GetProcAddress (GetModuleHandle ("kernel32.dll"), + "DebugBreakProcess"); + } + + if (s_pfn_Debug_Break_Process == NULL) + { + errno = ENOTSUP; + rc = -1; + } + else if (!s_pfn_Debug_Break_Process (proc_hand)) + { + DWORD err = GetLastError (); + + DebPrint (("sys_kill.DebugBreakProcess return %d " + "for pid %lu\n", err, pid)); + + switch (err) + { + case ERROR_ACCESS_DENIED: + errno = EPERM; + break; + default: + errno = EINVAL; + break; + } + + rc = -1; + } + } else { if (NILP (Vw32_start_process_share_console) && cp && cp->hwnd) @@ -2815,7 +2863,6 @@ set_process_dir (char * dir) /* From w32.c */ extern HANDLE winsock_lib; extern BOOL term_winsock (void); -extern BOOL init_winsock (int load_now); DEFUN ("w32-has-winsock", Fw32_has_winsock, Sw32_has_winsock, 0, 1, 0, doc: /* Test for presence of the Windows socket library `winsock'. @@ -3522,7 +3569,6 @@ w32_compare_strings (const char *s1, const char *s2, char *locname, LCID lcid = GetThreadLocale (); wchar_t *string1_w, *string2_w; int val, needed; - extern BOOL g_b_init_compare_string_w; static CompareStringW_Proc pCompareStringW; DWORD flags = 0; diff --git a/src/w32reg.c b/src/w32reg.c index a87381831e2..25d6bb83934 100644 --- a/src/w32reg.c +++ b/src/w32reg.c @@ -56,9 +56,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ */ static char * -w32_get_rdb_resource (char *rdb, const char *resource) +w32_get_rdb_resource (const char *rdb, const char *resource) { - char *value = rdb; + char *value = (char *)rdb; int len = strlen (resource); while (*value) diff --git a/src/w32select.c b/src/w32select.c index 138fe853c4d..36908f96afb 100644 --- a/src/w32select.c +++ b/src/w32select.c @@ -76,7 +76,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "lisp.h" #include "w32common.h" /* os_subtype */ #include "w32term.h" /* for all of the w32 includes */ -#include "keyboard.h" /* for waiting_for_input */ +#include "w32select.h" #include "blockinput.h" #include "coding.h" @@ -256,7 +256,7 @@ render (Lisp_Object oformat) switch (format) { case CF_UNICODETEXT: - htext = convert_to_handle_as_coded (QUNICODE); + htext = convert_to_handle_as_coded (Qutf_16le_dos); break; case CF_TEXT: case CF_OEMTEXT: @@ -1051,6 +1051,113 @@ frame's display, or the first available X display. */) return Qnil; } +/* Support enumerating available clipboard selection formats. */ + +DEFUN ("w32-selection-targets", Fw32_selection_targets, Sw32_selection_targets, + 0, 2, 0, + doc: /* Return a vector of data formats available in the specified SELECTION. +SELECTION should be the name of the selection in question, typically +one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. +The symbol nil is the same as `PRIMARY', and t is the same as `SECONDARY'. + +TERMINAL should be a terminal object or a frame specifying the X +server to query. If omitted or nil, that stands for the selected +frame's display, or the first available X display. + +This function currently ignores TERMINAL, and only returns non-nil +for `CLIPBOARD'. The return value is a vector of symbols, each symbol +representing a data format that is currently available in the clipboard. */) + (Lisp_Object selection, Lisp_Object terminal) +{ + /* Xlib-like names for standard Windows clipboard data formats. + They are in upper-case to mimic xselect.c. A couple of the names + were changed to be more like their X counterparts. */ + static const char *stdfmt_name[] = { + "UNDEFINED", + "STRING", + "BITMAP", + "METAFILE", + "SYMLINK", + "DIF", + "TIFF", + "OEM_STRING", + "DIB", + "PALETTE", + "PENDATA", + "RIFF", + "WAVE", + "UTF8_STRING", + "ENHMETAFILE", + "FILE_NAMES", /* DND */ + "LOCALE", /* not used */ + "DIBV5" + }; + CHECK_SYMBOL (selection); + + /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check + if the clipboard currently has valid text format contents. */ + + if (EQ (selection, QCLIPBOARD)) + { + Lisp_Object val = Qnil; + + setup_config (); + + if (OpenClipboard (NULL)) + { + UINT format = 0; + + /* Count how many formats are available. We ignore the + CF_LOCALE format, and don't put it into the vector we + return, because CF_LOCALE is automatically created by + Windows for any text in the clipboard, so its presence in + the value will simply confuse. */ + int fmtcount = 0; + while ((format = EnumClipboardFormats (format))) + if (format != CF_LOCALE) + fmtcount++; + + if (fmtcount > 0) + { + int i; + + /* We generate a vector because that's what xselect.c + does in this case. */ + val = Fmake_vector (make_number (fmtcount), Qnil); + /* Note: when stepping with GDB through this code, the + loop below terminates immediately because + EnumClipboardFormats for some reason returns with + "Thread does not have a clipboard open" error. */ + for (i = 0, format = 0; + (format = EnumClipboardFormats (format)) != 0; ) + { + const char *name; + + if (format == CF_LOCALE) + continue; + else if (format < CF_MAX) + name = stdfmt_name[format]; + else + { + char fmt_name[256]; + + if (!GetClipboardFormatName (format, fmt_name, + sizeof (fmt_name))) + continue; + name = fmt_name; + } + ASET (val, i, intern (name)); + i++; + } + } + CloseClipboard (); + } + return val; + } + /* For PRIMARY and SECONDARY we cons the values in w32--get-selection. */ + return Qnil; +} + /* One-time init. Called in the un-dumped Emacs, but not in the dumped version. */ @@ -1060,6 +1167,7 @@ syms_of_w32select (void) defsubr (&Sw32_set_clipboard_data); defsubr (&Sw32_get_clipboard_data); defsubr (&Sw32_selection_exists_p); + defsubr (&Sw32_selection_targets); DEFVAR_LISP ("selection-coding-system", Vselection_coding_system, doc: /* Coding system for communicating with other programs. @@ -1109,7 +1217,7 @@ After the communication, this variable is set to nil. */); current_text = Qnil; staticpro (¤t_text); current_coding_system = Qnil; staticpro (¤t_coding_system); - DEFSYM (QUNICODE, "utf-16le-dos"); + DEFSYM (Qutf_16le_dos, "utf-16le-dos"); QANSICP = Qnil; staticpro (&QANSICP); QOEMCP = Qnil; staticpro (&QOEMCP); } @@ -1132,7 +1240,7 @@ globals_of_w32select (void) QOEMCP = coding_from_cp (OEMCP); if (os_subtype == OS_NT) - Vselection_coding_system = QUNICODE; + Vselection_coding_system = Qutf_16le_dos; else if (inhibit_window_system) Vselection_coding_system = QOEMCP; else diff --git a/src/w32term.c b/src/w32term.c index 7b74ae03ad0..23475445e07 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -83,8 +83,6 @@ static int any_help_event_p; extern unsigned int msh_mousewheel; -extern void free_frame_menubar (struct frame *); - extern int w32_codepage_for_font (char *fontname); extern Cursor w32_load_cursor (LPCTSTR name); @@ -178,9 +176,7 @@ static void w32_define_cursor (Window, Cursor); void x_lower_frame (struct frame *); void x_scroll_bar_clear (struct frame *); -void x_wm_set_size_hint (struct frame *, long, bool); void x_raise_frame (struct frame *); -void x_set_window_size (struct frame *, bool, int, int, bool); void x_wm_set_window_state (struct frame *, int); void x_wm_set_icon_pixmap (struct frame *, int); static void w32_initialize (void); @@ -248,7 +244,7 @@ record_event (char *locus, int type) #endif /* 0 */ -void +static void XChangeGC (void *ignore, XGCValues *gc, unsigned long mask, XGCValues *xgcv) { @@ -261,7 +257,7 @@ XChangeGC (void *ignore, XGCValues *gc, unsigned long mask, } XGCValues * -XCreateGC (void *ignore, Window window, unsigned long mask, XGCValues *xgcv) +XCreateGC (void *ignore, HWND wignore, unsigned long mask, XGCValues *xgcv) { XGCValues *gc = xzalloc (sizeof (XGCValues)); @@ -270,12 +266,14 @@ XCreateGC (void *ignore, Window window, unsigned long mask, XGCValues *xgcv) return gc; } -void +#if 0 /* unused for now, see x_draw_image_glyph_string below */ +static void XGetGCValues (void *ignore, XGCValues *gc, unsigned long mask, XGCValues *xgcv) { XChangeGC (ignore, xgcv, mask, gc); } +#endif static void w32_set_clip_rectangle (HDC hdc, RECT *rect) @@ -321,7 +319,7 @@ w32_restore_glyph_string_clip (struct glyph_string *s) */ -void +static void w32_draw_underwave (struct glyph_string *s, COLORREF color) { int wave_height = 3, wave_length = 2; @@ -384,7 +382,7 @@ w32_draw_underwave (struct glyph_string *s, COLORREF color) } /* Draw a hollow rectangle at the specified position. */ -void +static void w32_draw_rectangle (HDC hdc, XGCValues *gc, int x, int y, int width, int height) { @@ -613,7 +611,7 @@ w32_draw_vertical_window_border (struct window *w, int x, int y0, int y1) r.bottom = y1; hdc = get_frame_dc (f); - face = FACE_FROM_ID (f, VERTICAL_BORDER_FACE_ID); + face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); if (face) w32_fill_rect (f, hdc, face->foreground, &r); else @@ -630,9 +628,11 @@ w32_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) { struct frame *f = XFRAME (WINDOW_FRAME (w)); HDC hdc = get_frame_dc (f); - struct face *face = FACE_FROM_ID (f, WINDOW_DIVIDER_FACE_ID); - struct face *face_first = FACE_FROM_ID (f, WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID); - struct face *face_last = FACE_FROM_ID (f, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); + struct face *face = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FACE_ID); + struct face *face_first + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID); + struct face *face_last + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); unsigned long color = face ? face->foreground : FRAME_FOREGROUND_PIXEL (f); unsigned long color_first = (face_first ? face_first->foreground @@ -974,7 +974,7 @@ x_set_cursor_gc (struct glyph_string *s) mask, &xgcv); else FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc - = XCreateGC (NULL, s->window, mask, &xgcv); + = XCreateGC (NULL, FRAME_W32_WINDOW (s->f), mask, &xgcv); s->gc = FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc; } @@ -991,7 +991,7 @@ x_set_mouse_face_gc (struct glyph_string *s) /* What face has to be used last for the mouse face? */ face_id = MOUSE_HL_INFO (s->f)->mouse_face_face_id; - face = FACE_FROM_ID (s->f, face_id); + face = FACE_FROM_ID_OR_NULL (s->f, face_id); if (face == NULL) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); @@ -1023,7 +1023,7 @@ x_set_mouse_face_gc (struct glyph_string *s) mask, &xgcv); else FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc - = XCreateGC (NULL, s->window, mask, &xgcv); + = XCreateGC (NULL, FRAME_W32_WINDOW (s->f), mask, &xgcv); s->gc = FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc; } @@ -1204,7 +1204,7 @@ x_draw_glyph_string_background (struct glyph_string *s, bool force_p) { /* Fill background with a stipple pattern. */ XSetFillStyle (s->display, s->gc, FillOpaqueStippled); - XFillRectangle (s->display, s->window, s->gc, s->x, + XFillRectangle (s->display, FRAME_W32_WINDOW (s->f), s->gc, s->x, s->y + box_line_width, s->background_width, s->height - 2 * box_line_width); @@ -1434,7 +1434,7 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) { sprintf ((char *) buf, "%0*X", glyph->u.glyphless.ch < 0x10000 ? 4 : 6, - glyph->u.glyphless.ch); + (unsigned int) glyph->u.glyphless.ch); str = buf; } @@ -2061,7 +2061,7 @@ x_draw_glyph_string_bg_rect (struct glyph_string *s, int x, int y, int w, int h) { /* Fill background with a stipple pattern. */ XSetFillStyle (s->display, s->gc, FillOpaqueStippled); - XFillRectangle (s->display, s->window, s->gc, x, y, w, h); + XFillRectangle (s->display, FRAME_W32_WINDOW (s->f), s->gc, x, y, w, h); XSetFillStyle (s->display, s->gc, FillSolid); } else @@ -2133,7 +2133,7 @@ x_draw_image_glyph_string (struct glyph_string *s) int depth = DefaultDepthOfScreen (screen); /* Create a pixmap as large as the glyph string. */ - pixmap = XCreatePixmap (s->display, s->window, + pixmap = XCreatePixmap (s->display, FRAME_W32_WINDOW (s->f), s->background_width, s->height, depth); @@ -2275,7 +2275,7 @@ x_draw_stretch_glyph_string (struct glyph_string *s) { /* Fill background with a stipple pattern. */ XSetFillStyle (s->display, gc, FillOpaqueStippled); - XFillRectangle (s->display, s->window, gc, x, y, w, h); + XFillRectangle (s->display, FRAME_W32_WINDOW (s->f), gc, x, y, w, h); XSetFillStyle (s->display, gc, FillSolid); } else @@ -2577,7 +2577,7 @@ x_draw_glyph_string (struct glyph_string *s) /* Shift display to make room for inserted glyphs. */ -void +static void w32_shift_glyphs_for_insert (struct frame *f, int x, int y, int width, int height, int shift_by) { @@ -2874,13 +2874,15 @@ w32_detect_focus_change (struct w32_display_info *dpyinfo, W32Msg *event, } +#if 0 /* unused */ /* Handle an event saying the mouse has moved out of an Emacs frame. */ -void +static void x_mouse_leave (struct w32_display_info *dpyinfo) { x_new_focus_frame (dpyinfo, dpyinfo->w32_focus_event_frame); } +#endif /* The focus has changed, or we have redirected a frame's focus to another frame (this happens when a frame uses a surrogate @@ -3211,71 +3213,85 @@ static void queue_notifications (struct input_event *event, W32Msg *msg, struct frame *f, int *evcount) { - BYTE *p = file_notifications; - FILE_NOTIFY_INFORMATION *fni = (PFILE_NOTIFY_INFORMATION)p; - const DWORD min_size - = offsetof (FILE_NOTIFY_INFORMATION, FileName) + sizeof(wchar_t); + struct notifications_set *ns = NULL; Lisp_Object frame; + int done = 0; /* We cannot process notification before Emacs is fully initialized, since we need the UTF-16LE coding-system to be set up. */ if (!initialized) - { - notification_buffer_in_use = 0; - return; - } + return; XSETFRAME (frame, f); - enter_crit (); - if (notification_buffer_in_use) + while (!done) { - DWORD info_size = notifications_size; - Lisp_Object cs = Qutf_16le; - Lisp_Object obj = w32_get_watch_object (notifications_desc); - - /* notifications_size could be zero when the buffer of - notifications overflowed on the OS level, or when the - directory being watched was itself deleted. Do nothing in - that case. */ - if (info_size - && !NILP (obj) && CONSP (obj)) + ns = NULL; + + /* Find out if there is a record available in the linked list of + notifications sets. If so, unlink the set from the linked + list. Use critical section. */ + enter_crit (); + if (notifications_set_head->next != notifications_set_head) { - Lisp_Object callback = XCDR (obj); + ns = notifications_set_head->next; + ns->prev->next = ns->next; + ns->next->prev = ns->prev; + } + else + done = 1; + leave_crit(); - while (info_size >= min_size) + if (ns) + { + BYTE *p = ns->notifications; + FILE_NOTIFY_INFORMATION *fni = (PFILE_NOTIFY_INFORMATION)p; + const DWORD min_size + = offsetof (FILE_NOTIFY_INFORMATION, FileName) + sizeof(wchar_t); + DWORD info_size = ns->size; + Lisp_Object cs = Qutf_16le; + Lisp_Object obj = w32_get_watch_object (ns->desc); + + /* notifications size could be zero when the buffer of + notifications overflowed on the OS level, or when the + directory being watched was itself deleted. Do nothing in + that case. */ + if (info_size + && !NILP (obj) && CONSP (obj)) { - Lisp_Object utf_16_fn - = make_unibyte_string ((char *)fni->FileName, - fni->FileNameLength); - /* Note: mule-conf is preloaded, so utf-16le must - already be defined at this point. */ - Lisp_Object fname - = code_convert_string_norecord (utf_16_fn, cs, 0); - Lisp_Object action = lispy_file_action (fni->Action); - - event->kind = FILE_NOTIFY_EVENT; - event->timestamp = msg->msg.time; - event->modifiers = 0; - event->frame_or_window = callback; - event->arg = list3 (make_pointer_integer (notifications_desc), - action, fname); - kbd_buffer_store_event (event); - (*evcount)++; - - if (!fni->NextEntryOffset) - break; - p += fni->NextEntryOffset; - fni = (PFILE_NOTIFY_INFORMATION)p; - info_size -= fni->NextEntryOffset; + Lisp_Object callback = XCDR (obj); + + while (info_size >= min_size) + { + Lisp_Object utf_16_fn + = make_unibyte_string ((char *)fni->FileName, + fni->FileNameLength); + /* Note: mule-conf is preloaded, so utf-16le must + already be defined at this point. */ + Lisp_Object fname + = code_convert_string_norecord (utf_16_fn, cs, 0); + Lisp_Object action = lispy_file_action (fni->Action); + + event->kind = FILE_NOTIFY_EVENT; + event->timestamp = msg->msg.time; + event->modifiers = 0; + event->frame_or_window = callback; + event->arg = list3 (make_pointer_integer (ns->desc), + action, fname); + kbd_buffer_store_event (event); + (*evcount)++; + if (!fni->NextEntryOffset) + break; + p += fni->NextEntryOffset; + fni = (PFILE_NOTIFY_INFORMATION)p; + info_size -= fni->NextEntryOffset; + } } + /* Free this notifications set. */ + xfree (ns->notifications); + xfree (ns); } - notification_buffer_in_use = 0; } - else - DebPrint (("We were promised notifications, but in-use flag is zero!\n")); - leave_crit (); - /* We've stuffed all the events ourselves, so w32_read_socket shouldn't. */ event->kind = NO_EVENT; } @@ -4182,6 +4198,7 @@ w32_scroll_bar_handle_click (struct scroll_bar *bar, W32Msg *msg, y = si.nPos; bar->dragging = 0; + struct frame *f; /* Value is not used. */ FRAME_DISPLAY_INFO (f)->last_mouse_scroll_bar_pos = msg->msg.wParam; switch (sb_event) @@ -4297,6 +4314,7 @@ w32_horizontal_scroll_bar_handle_click (struct scroll_bar *bar, W32Msg *msg, y = si.nMax - si.nPage; bar->dragging = 0; + struct frame *f; /* Value is not used. */ FRAME_DISPLAY_INFO (f)->last_mouse_scroll_bar_pos = msg->msg.wParam; switch (sb_event) @@ -4534,6 +4552,8 @@ static char dbcs_lead = 0; recursively with different messages by the system. */ +extern void menubar_selection_callback (struct frame *, void *); + static int w32_read_socket (struct terminal *terminal, struct input_event *hold_quit) @@ -4608,11 +4628,18 @@ w32_read_socket (struct terminal *terminal, } else { - HDC hdc = get_frame_dc (f); + /* Erase background again for safety. But don't do + that if the frame's 'garbaged' flag is set, since + in that case expose_frame will do nothing, and if + the various redisplay flags happen to be unset, + we are left with a blank frame. */ + if (!FRAME_GARBAGED_P (f)) + { + HDC hdc = get_frame_dc (f); - /* Erase background again for safety. */ - w32_clear_rect (f, hdc, &msg.rect); - release_frame_dc (f, hdc); + w32_clear_rect (f, hdc, &msg.rect); + release_frame_dc (f, hdc); + } expose_frame (f, msg.rect.left, msg.rect.top, @@ -5246,6 +5273,10 @@ w32_read_socket (struct terminal *terminal, } break; + case WM_ENDSESSION: + inev.kind = END_SESSION_EVENT; + break; + case WM_INITMENU: f = x_window_to_frame (dpyinfo, msg.msg.hwnd); @@ -5261,8 +5292,6 @@ w32_read_socket (struct terminal *terminal, if (f) { - extern void menubar_selection_callback - (struct frame *f, void * client_data); menubar_selection_callback (f, (void *)msg.msg.wParam); } @@ -5879,7 +5908,7 @@ xim_close_dpy (dpyinfo) /* Calculate the absolute position in frame F from its current recorded position values and gravity. */ -void +static void x_calc_absolute_position (struct frame *f) { int flags = f->size_hint_flags; @@ -6555,7 +6584,7 @@ x_free_frame_resources (struct frame *f) /* Destroy the window of frame F. */ -void +static void x_destroy_window (struct frame *f) { struct w32_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); @@ -6951,6 +6980,8 @@ w32_init_main_thread (void) DuplicateHandle (GetCurrentProcess (), GetCurrentThread (), GetCurrentProcess (), &hMainThread, 0, TRUE, DUPLICATE_SAME_ACCESS); + + } DWORD WINAPI w32_msg_worker (void * arg); diff --git a/src/w32term.h b/src/w32term.h index 2fed56ed797..e29e99357e8 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -230,25 +230,14 @@ extern struct frame *x_window_to_frame (struct w32_display_info *, HWND); struct w32_display_info *x_display_info_for_name (Lisp_Object); -Lisp_Object display_x_get_resource (struct w32_display_info *, - Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object); - /* also defined in xterm.h XXX: factor out to common header */ extern struct w32_display_info *w32_term_init (Lisp_Object, char *, char *); extern int w32_defined_color (struct frame *f, const char *color, XColor *color_def, bool alloc_p); -extern void x_set_window_size (struct frame *f, bool change_gravity, - int width, int height, bool pixelwise); extern int x_display_pixel_height (struct w32_display_info *); extern int x_display_pixel_width (struct w32_display_info *); -extern Lisp_Object x_get_focus_frame (struct frame *); -extern void x_make_frame_visible (struct frame *f); -extern void x_make_frame_invisible (struct frame *f); -extern void x_iconify_frame (struct frame *f); -extern void x_set_frame_alpha (struct frame *f); extern void x_set_menu_bar_lines (struct frame *, Lisp_Object, Lisp_Object); extern void x_set_tool_bar_lines (struct frame *f, Lisp_Object value, @@ -256,19 +245,12 @@ extern void x_set_tool_bar_lines (struct frame *f, extern void x_set_internal_border_width (struct frame *f, Lisp_Object value, Lisp_Object oldval); -extern void x_activate_menubar (struct frame *); -extern bool x_bitmap_icon (struct frame *, Lisp_Object); extern void initialize_frame_menubar (struct frame *); -extern void x_free_frame_resources (struct frame *); -extern void x_real_positions (struct frame *, int *, int *); /* w32inevt.c */ extern int w32_kbd_patch_key (KEY_EVENT_RECORD *event, int cpId); extern int w32_kbd_mods_to_emacs (DWORD mods, WORD key); - -extern Lisp_Object x_get_focus_frame (struct frame *); - /* w32console.c */ extern void w32con_hide_cursor (void); extern void w32con_show_cursor (void); @@ -417,7 +399,7 @@ extern struct w32_output w32term_display; #define FRAME_BASELINE_OFFSET(f) ((f)->output_data.w32->baseline_offset) /* This gives the w32_display_info structure for the display F is on. */ -#define FRAME_DISPLAY_INFO(f) (&one_w32_display_info) +#define FRAME_DISPLAY_INFO(f) ((void) (f), (&one_w32_display_info)) /* This is the `Display *' which frame F is on. */ #define FRAME_X_DISPLAY(f) (0) @@ -727,10 +709,18 @@ extern void x_delete_display (struct w32_display_info *dpyinfo); extern void x_query_color (struct frame *, XColor *); -extern volatile int notification_buffer_in_use; -extern BYTE file_notifications[16384]; -extern DWORD notifications_size; -extern void *notifications_desc; +#define FILE_NOTIFICATIONS_SIZE 16384 +/* Notifications come in sets. We use a doubly linked list with a + sentinel to communicate those sets from the watching threads to the + main thread. */ +struct notifications_set { + LPBYTE notifications; + DWORD size; + void *desc; + struct notifications_set *next; + struct notifications_set *prev; +}; +extern struct notifications_set *notifications_set_head; extern Lisp_Object w32_get_watch_object (void *); extern Lisp_Object lispy_file_action (DWORD); extern int handle_file_notifications (struct input_event *); @@ -738,6 +728,16 @@ extern int handle_file_notifications (struct input_event *); extern void w32_initialize_display_info (Lisp_Object); extern void initialize_w32_display (struct terminal *, int *, int *); +#ifdef WINDOWSNT +/* Keyboard hooks. */ +extern void setup_w32_kbdhook (void); +extern void remove_w32_kbdhook (void); +extern int check_w32_winkey_state (int); +#define w32_kbdhook_active (os_subtype != OS_9X) +#else +#define w32_kbdhook_active 0 +#endif + /* Keypad command key support. W32 doesn't have virtual keys defined for the function keys on the keypad (they are mapped to the standard function keys), so we define our own. */ @@ -790,7 +790,7 @@ typedef struct tagTRACKMOUSEEVENT struct image; struct face; -XGCValues *XCreateGC (void *, Window, unsigned long, XGCValues *); +XGCValues *XCreateGC (void *, HWND, unsigned long, XGCValues *); typedef DWORD (WINAPI * ClipboardSequence_Proc) (void); typedef BOOL (WINAPI * AppendMenuW_Proc) ( diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c index ddca5f5ef52..960ee068e87 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -50,7 +50,7 @@ static int CALLBACK ALIGN_STACK add_opentype_font_name_to_list (ENUMLOGFONTEX *, NEWTEXTMETRICEX *, DWORD, LPARAM); /* Used by uniscribe_otf_capability. */ -static Lisp_Object otf_features (HDC context, char *table); +static Lisp_Object otf_features (HDC context, const char *table); static int memq_no_quit (Lisp_Object elt, Lisp_Object list) @@ -1042,7 +1042,7 @@ uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec) } static Lisp_Object -otf_features (HDC context, char *table) +otf_features (HDC context, const char *table) { Lisp_Object script_list = Qnil; unsigned short scriptlist_table, n_scripts, feature_table; @@ -1135,7 +1135,7 @@ font_table_error: struct font_driver uniscribe_font_driver = { - LISP_INITIALLY_ZERO, /* Quniscribe */ + LISPSYM_INITIALLY (Quniscribe), 0, /* case insensitive */ w32font_get_cache, uniscribe_list, @@ -1166,6 +1166,8 @@ struct font_driver uniscribe_font_driver = /* Note that this should be called at every startup, not just when dumping, as it needs to test for the existence of the Uniscribe library. */ +void syms_of_w32uniscribe (void); + void syms_of_w32uniscribe (void) { @@ -1180,7 +1182,6 @@ syms_of_w32uniscribe (void) if (!uniscribe) return; - uniscribe_font_driver.type = Quniscribe; uniscribe_available = 1; register_font_driver (&uniscribe_font_driver, NULL); diff --git a/src/w32xfns.c b/src/w32xfns.c index 04bf5ce733e..b5b22c9aa52 100644 --- a/src/w32xfns.c +++ b/src/w32xfns.c @@ -48,6 +48,21 @@ init_crit (void) when the input queue is empty, so make it a manual reset event. */ input_available = CreateEvent (NULL, TRUE, FALSE, NULL); +#if HAVE_W32NOTIFY + /* Initialize the linked list of notifications sets that will be + used to communicate between the watching worker threads and the + main thread. */ + notifications_set_head = malloc (sizeof(struct notifications_set)); + if (notifications_set_head) + { + memset (notifications_set_head, 0, sizeof(struct notifications_set)); + notifications_set_head->next + = notifications_set_head->prev = notifications_set_head; + } + else + DebPrint(("Out of memory: can't initialize notifications sets.")); +#endif + #ifdef WINDOWSNT keyboard_handle = input_available; #endif /* WINDOWSNT */ @@ -76,6 +91,23 @@ delete_crit (void) CloseHandle (interrupt_handle); interrupt_handle = NULL; } + +#if HAVE_W32NOTIFY + if (notifications_set_head) + { + /* Free any remaining notifications set that could be left over. */ + while (notifications_set_head->next != notifications_set_head) + { + struct notifications_set *ns = notifications_set_head->next; + notifications_set_head->next = ns->next; + ns->next->prev = notifications_set_head; + if (ns->notifications) + free (ns->notifications); + free (ns); + } + } + free (notifications_set_head); +#endif } void diff --git a/src/widget.c b/src/widget.c index 28bb475ddfa..97b4196f682 100644 --- a/src/widget.c +++ b/src/widget.c @@ -32,6 +32,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "widget.h" #include <stdio.h> +#include <stdlib.h> #include "lisp.h" #include "xterm.h" @@ -211,16 +212,6 @@ mark_shell_size_user_specified (Widget wmshell) #endif -/* Can't have static frame locals because of some broken compilers. - Normally, initializing a variable like this doesn't work in emacs, - but it's ok in this file because it must come after lastfile (and - thus have its data not go into text space) because Xt needs to - write to initialized data objects too. - */ -#if 0 -static Boolean first_frame_p = True; -#endif - static void set_frame_size (EmacsFrame ew) { diff --git a/src/window.c b/src/window.c index 8d86f7f0815..6cfba084493 100644 --- a/src/window.c +++ b/src/window.c @@ -57,6 +57,7 @@ static bool foreach_window_1 (struct window *, static bool window_resize_check (struct window *, bool); static void window_resize_apply (struct window *, bool); static void select_window_1 (Lisp_Object, bool); +static void run_window_configuration_change_hook (struct frame *); static struct window *set_window_fringes (struct window *, Lisp_Object, Lisp_Object, Lisp_Object); @@ -720,6 +721,36 @@ the height of the screen areas spanned by its children. */) return make_number (decode_valid_window (window)->pixel_height); } +DEFUN ("window-pixel-width-before-size-change", + Fwindow_pixel_width_before_size_change, + Swindow_pixel_width_before_size_change, 0, 1, 0, + doc: /* Return pixel width of window WINDOW before last size changes. +WINDOW must be a valid window and defaults to the selected one. + +The return value is the pixel width of WINDOW at the last time +`window-size-change-functions' was run. It's zero if WINDOW was made +after that. */) + (Lisp_Object window) +{ + return (make_number + (decode_valid_window (window)->pixel_width_before_size_change)); +} + +DEFUN ("window-pixel-height-before-size-change", + Fwindow_pixel_height_before_size_change, + Swindow_pixel_height_before_size_change, 0, 1, 0, + doc: /* Return pixel height of window WINDOW before last size changes. +WINDOW must be a valid window and defaults to the selected one. + +The return value is the pixel height of WINDOW at the last time +`window-size-change-functions' was run. It's zero if WINDOW was made +after that. */) + (Lisp_Object window) +{ + return (make_number + (decode_valid_window (window)->pixel_height_before_size_change)); +} + DEFUN ("window-total-height", Fwindow_total_height, Swindow_total_height, 0, 2, 0, doc: /* Return the height of window WINDOW in lines. WINDOW must be a valid window and defaults to the selected one. @@ -2346,8 +2377,10 @@ candidate_window_p (Lisp_Object window, Lisp_Object owindow, == FRAME_TERMINAL (XFRAME (selected_frame))); } else if (WINDOWP (all_frames)) - candidate_p = (EQ (FRAME_MINIBUF_WINDOW (f), all_frames) - || EQ (XWINDOW (all_frames)->frame, w->frame) + /* To qualify as candidate, it's not sufficient for WINDOW's frame + to just share the minibuffer window - it must be active as well + (see Bug#24500). */ + candidate_p = (EQ (XWINDOW (all_frames)->frame, w->frame) || EQ (XWINDOW (all_frames)->frame, FRAME_FOCUS_FRAME (f))); else if (FRAMEP (all_frames)) candidate_p = EQ (all_frames, w->frame); @@ -2828,32 +2861,27 @@ selected frame and no others. */) static Lisp_Object -resize_root_window (Lisp_Object window, Lisp_Object delta, Lisp_Object horizontal, Lisp_Object ignore, Lisp_Object pixelwise) +resize_root_window (Lisp_Object window, Lisp_Object delta, + Lisp_Object horizontal, Lisp_Object ignore, + Lisp_Object pixelwise) { - return call5 (Qwindow_resize_root_window, window, delta, horizontal, ignore, pixelwise); + return call5 (Qwindow__resize_root_window, window, delta, + horizontal, ignore, pixelwise); } -/* Placeholder used by temacs -nw before window.el is loaded. */ -DEFUN ("window--sanitize-window-sizes", Fwindow__sanitize_window_sizes, - Swindow__sanitize_window_sizes, 2, 2, 0, - doc: /* */ - attributes: const) - (Lisp_Object frame, Lisp_Object horizontal) -{ - return Qnil; -} - -Lisp_Object -sanitize_window_sizes (Lisp_Object frame, Lisp_Object horizontal) +void +sanitize_window_sizes (Lisp_Object horizontal) { - return call2 (Qwindow_sanitize_window_sizes, frame, horizontal); + /* Don't burp in temacs -nw before window.el is loaded. */ + if (!NILP (Fsymbol_function (Qwindow__sanitize_window_sizes))) + call1 (Qwindow__sanitize_window_sizes, horizontal); } static Lisp_Object window_pixel_to_total (Lisp_Object frame, Lisp_Object horizontal) { - return call2 (Qwindow_pixel_to_total, frame, horizontal); + return call2 (Qwindow__pixel_to_total, frame, horizontal); } @@ -2876,9 +2904,12 @@ window-start value is reasonable when this function is called. */) { struct window *w, *r, *s; struct frame *f; - Lisp_Object sibling, pwindow, swindow IF_LINT (= Qnil), delta; - ptrdiff_t startpos IF_LINT (= 0), startbyte IF_LINT (= 0); - int top IF_LINT (= 0), new_top; + Lisp_Object sibling, pwindow, delta; + Lisp_Object swindow UNINIT; + ptrdiff_t startpos UNINIT, startbyte UNINIT; + int top UNINIT; + int new_top; + bool resize_failed = false; w = decode_valid_window (window); XSETWINDOW (window, w); @@ -2978,8 +3009,6 @@ window-start value is reasonable when this function is called. */) fset_redisplay (f); Vwindow_list = Qnil; - FRAME_WINDOW_SIZES_CHANGED (f) = true; - bool resize_failed = false; if (!WINDOW_LEAF_P (w)) { @@ -3157,7 +3186,7 @@ select_frame_norecord (Lisp_Object frame) Fselect_frame (frame, Qt); } -void +static void run_window_configuration_change_hook (struct frame *f) { ptrdiff_t count = SPECPDL_INDEX (); @@ -3229,6 +3258,76 @@ If WINDOW is omitted or nil, it defaults to the selected window. */) return Qnil; } + +/* Compare old and present pixel sizes of windows in tree rooted at W. + Return true iff any of these windows differs in size. */ + +static bool +window_size_changed (struct window *w) +{ + if (w->pixel_width != w->pixel_width_before_size_change + || w->pixel_height != w->pixel_height_before_size_change) + return true; + + if (WINDOW_INTERNAL_P (w)) + { + w = XWINDOW (w->contents); + while (w) + { + if (window_size_changed (w)) + return true; + + w = NILP (w->next) ? 0 : XWINDOW (w->next); + } + } + + return false; +} + +/* Set before size change pixel sizes of windows in tree rooted at W to + their present pixel sizes. */ + +static void +window_set_before_size_change_sizes (struct window *w) +{ + w->pixel_width_before_size_change = w->pixel_width; + w->pixel_height_before_size_change = w->pixel_height; + + if (WINDOW_INTERNAL_P (w)) + { + w = XWINDOW (w->contents); + while (w) + { + window_set_before_size_change_sizes (w); + w = NILP (w->next) ? 0 : XWINDOW (w->next); + } + } +} + + +void +run_window_size_change_functions (Lisp_Object frame) +{ + struct frame *f = XFRAME (frame); + struct window *r = XWINDOW (FRAME_ROOT_WINDOW (f)); + Lisp_Object functions = Vwindow_size_change_functions; + + if (FRAME_WINDOW_CONFIGURATION_CHANGED (f) + || window_size_changed (r)) + { + while (CONSP (functions)) + { + if (!EQ (XCAR (functions), Qt)) + safe_call1 (XCAR (functions), frame); + functions = XCDR (functions); + } + + window_set_before_size_change_sizes (r); + FRAME_WINDOW_CONFIGURATION_CHANGED (f) = false; + } +} + + /* Make WINDOW display BUFFER. RUN_HOOKS_P means it's allowed to run hooks. See make_frame for a case where it's not allowed. KEEP_MARGINS_P means that the current margins, fringes, and @@ -3263,15 +3362,9 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, if (!(keep_margins_p && samebuf)) { /* If we're not actually changing the buffer, don't reset hscroll - and vscroll. This case happens for example when called from - change_frame_size_1, where we use a dummy call to - Fset_window_buffer on the frame's selected window (and no - other) just in order to run window-configuration-change-hook - (no longer true since change_frame_size_1 directly calls - run_window_configuration_change_hook). Resetting hscroll and - vscroll here is problematic for things like image-mode and - doc-view-mode since it resets the image's position whenever we - resize the frame. */ + and vscroll. Resetting hscroll and vscroll here is problematic + for things like image-mode and doc-view-mode since it resets + the image's position whenever we resize the frame. */ w->hscroll = w->min_hscroll = w->hscroll_whole = 0; w->suspend_auto_hscroll = false; w->vscroll = 0; @@ -3283,10 +3376,8 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, w->start_at_line_beg = false; w->force_start = false; } - /* Maybe we could move this into the `if' but it's not obviously safe and - I doubt it's worth the trouble. */ - wset_redisplay (w); + wset_redisplay (w); wset_update_mode_line (w); /* We must select BUFFER to run the window-scroll-functions and to look up @@ -3314,7 +3405,7 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, if (run_hooks_p) { - if (! NILP (Vwindow_scroll_functions)) + if (!NILP (Vwindow_scroll_functions)) run_hook_with_args_2 (Qwindow_scroll_functions, window, Fmarker_position (w->start)); if (!samebuf) @@ -3559,6 +3650,8 @@ make_window (void) w->phys_cursor_width = -1; #endif w->sequence_number = ++sequence_number; + w->pixel_width_before_size_change = 0; + w->pixel_height_before_size_change = 0; w->scroll_bar_width = -1; w->scroll_bar_height = -1; w->column_number_displayed = -1; @@ -3922,7 +4015,6 @@ be applied on the Elisp level. */) window_resize_apply (r, horflag); fset_redisplay (f); - FRAME_WINDOW_SIZES_CHANGED (f) = true; adjust_frame_glyphs (f); unblock_input (); @@ -4089,7 +4181,6 @@ resize_frame_windows (struct frame *f, int size, bool horflag, bool pixelwise) } } - FRAME_WINDOW_SIZES_CHANGED (f) = true; fset_redisplay (f); } @@ -4216,7 +4307,6 @@ set correctly. See the code of `split-window' for how this is done. */) p = XWINDOW (o->parent); fset_redisplay (f); - FRAME_WINDOW_SIZES_CHANGED (f) = true; new = make_window (); n = XWINDOW (new); wset_frame (n, frame); @@ -4385,7 +4475,6 @@ Signal an error when WINDOW is the only window on its frame. */) fset_redisplay (f); Vwindow_list = Qnil; - FRAME_WINDOW_SIZES_CHANGED (f) = true; wset_next (w, Qnil); /* Don't delete w->next too. */ free_window_matrices (w); @@ -4453,9 +4542,6 @@ Signal an error when WINDOW is the only window on its frame. */) } else unblock_input (); - - /* Must be run by the caller: - run_window_configuration_change_hook (f); */ } else /* We failed: Relink WINDOW into window tree. */ @@ -4498,7 +4584,7 @@ grow_mini_window (struct window *w, int delta, bool pixelwise) { root = FRAME_ROOT_WINDOW (f); r = XWINDOW (root); - height = call3 (Qwindow_resize_root_window_vertically, + height = call3 (Qwindow__resize_root_window_vertically, root, make_number (- delta), pixelwise ? Qt : Qnil); if (INTEGERP (height) && window_resize_check (r, false)) { @@ -4529,10 +4615,12 @@ grow_mini_window (struct window *w, int delta, bool pixelwise) /* Enforce full redisplay of the frame. */ /* FIXME: Shouldn't window--resize-root-window-vertically do it? */ fset_redisplay (f); - FRAME_WINDOW_SIZES_CHANGED (f) = true; adjust_frame_glyphs (f); unblock_input (); } + else + error ("Failed to grow minibuffer window"); + } } @@ -4553,7 +4641,7 @@ shrink_mini_window (struct window *w, bool pixelwise) { root = FRAME_ROOT_WINDOW (f); r = XWINDOW (root); - delta = call3 (Qwindow_resize_root_window_vertically, + delta = call3 (Qwindow__resize_root_window_vertically, root, make_number (height - unit), pixelwise ? Qt : Qnil); if (INTEGERP (delta) && window_resize_check (r, false)) @@ -4569,7 +4657,6 @@ shrink_mini_window (struct window *w, bool pixelwise) /* Enforce full redisplay of the frame. */ /* FIXME: Shouldn't window--resize-root-window-vertically do it? */ fset_redisplay (f); - FRAME_WINDOW_SIZES_CHANGED (f) = true; adjust_frame_glyphs (f); unblock_input (); } @@ -4577,6 +4664,8 @@ shrink_mini_window (struct window *w, bool pixelwise) one window frame here. The same routine will be needed when shrinking the frame (and probably when making the initial *scratch* window). For the moment leave things as they are. */ + else + error ("Failed to shrink minibuffer window"); } } @@ -4612,7 +4701,6 @@ DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal, Sresize_mini w->top_line = r->top_line + r->total_lines; fset_redisplay (f); - FRAME_WINDOW_SIZES_CHANGED (f) = true; adjust_frame_glyphs (f); unblock_input (); return Qt; @@ -4727,8 +4815,9 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) SET_TEXT_POS_FROM_MARKER (start, w->start); /* Scrolling a minibuffer window via scroll bar when the echo area shows long text sometimes resets the minibuffer contents behind - our backs. */ - if (CHARPOS (start) > ZV) + our backs. Also, someone might narrow-to-region and immediately + call a scroll function. */ + if (CHARPOS (start) > ZV || CHARPOS (start) < BEGV) SET_TEXT_POS (start, BEGV, BEGV_BYTE); /* If PT is not visible in WINDOW, move back one half of @@ -5557,21 +5646,14 @@ displayed_window_lines (struct window *w) bottom_y = line_bottom_y (&it); bidi_unshelve_cache (itdata, false); - /* rms: On a non-window display, - the value of it.vpos at the bottom of the screen - seems to be 1 larger than window_box_height (w). - This kludge fixes a bug whereby (move-to-window-line -1) - when ZV is on the last screen line - moves to the previous screen line instead of the last one. */ - if (! FRAME_WINDOW_P (XFRAME (w->frame))) - height++; - /* Add in empty lines at the bottom of the window. */ if (bottom_y < height) { int uy = FRAME_LINE_HEIGHT (it.f); it.vpos += (height - bottom_y + uy - 1) / uy; } + else if (bottom_y == height) + it.vpos++; if (old_buffer) set_buffer_internal (old_buffer); @@ -5601,7 +5683,7 @@ and redisplay normally--don't erase and redraw the frame. */) struct buffer *buf = XBUFFER (w->contents); bool center_p = false; ptrdiff_t charpos, bytepos; - EMACS_INT iarg IF_LINT (= 0); + EMACS_INT iarg UNINIT; int this_scroll_margin; if (buf != current_buffer) @@ -5846,7 +5928,12 @@ DEFUN ("move-to-window-line", Fmove_to_window_line, Smove_to_window_line, doc: /* Position point relative to window. ARG nil means position point at center of window. Else, ARG specifies vertical position within the window; -zero means top of window, negative means relative to bottom of window. */) +zero means top of window, negative means relative to bottom +of window, -1 meaning the last fully visible display line +of the window. + +Value is the screen line of the window point moved to, counting +from the top of the window. */) (Lisp_Object arg) { struct window *w = XWINDOW (selected_window); @@ -5921,7 +6008,7 @@ struct save_window_data struct vectorlike_header header; Lisp_Object selected_frame; Lisp_Object current_window; - Lisp_Object current_buffer; + Lisp_Object f_current_buffer; Lisp_Object minibuf_scroll_window; Lisp_Object minibuf_selected_window; Lisp_Object root_window; @@ -5950,6 +6037,7 @@ struct saved_window Lisp_Object window, buffer, start, pointm, old_pointm; Lisp_Object pixel_left, pixel_top, pixel_height, pixel_width; + Lisp_Object pixel_height_before_size_change, pixel_width_before_size_change; Lisp_Object left_col, top_line, total_cols, total_lines; Lisp_Object normal_cols, normal_lines; Lisp_Object hscroll, min_hscroll, hscroll_whole, suspend_auto_hscroll; @@ -6010,7 +6098,7 @@ the return value is nil. Otherwise the value is t. */) data = (struct save_window_data *) XVECTOR (configuration); saved_windows = XVECTOR (data->saved_windows); - new_current_buffer = data->current_buffer; + new_current_buffer = data->f_current_buffer; if (!BUFFER_LIVE_P (XBUFFER (new_current_buffer))) new_current_buffer = Qnil; else @@ -6065,6 +6153,12 @@ the return value is nil. Otherwise the value is t. */) struct window *root_window; struct window **leaf_windows; ptrdiff_t i, k, n_leaf_windows; + /* Records whether a window has been added or removed wrt the + original configuration. */ + bool window_changed = false; + /* Records whether a window has changed its buffer wrt the + original configuration. */ + bool buffer_changed = false; /* Don't do this within the main loop below: This may call Lisp code and is thus potentially unsafe while input is blocked. */ @@ -6073,6 +6167,12 @@ the return value is nil. Otherwise the value is t. */) p = SAVED_WINDOW_N (saved_windows, k); window = p->window; w = XWINDOW (window); + + if (NILP (w->contents)) + /* A dead window that will be resurrected, the window + configuration will change. */ + window_changed = true; + if (BUFFERP (w->contents) && !EQ (w->contents, p->buffer) && BUFFER_LIVE_P (XBUFFER (p->buffer))) @@ -6102,7 +6202,6 @@ the return value is nil. Otherwise the value is t. */) } fset_redisplay (f); - FRAME_WINDOW_SIZES_CHANGED (f) = true; /* Problem: Freeing all matrices and later allocating them again is a serious redisplay flickering problem. What we would @@ -6158,6 +6257,10 @@ the return value is nil. Otherwise the value is t. */) w->pixel_top = XFASTINT (p->pixel_top); w->pixel_width = XFASTINT (p->pixel_width); w->pixel_height = XFASTINT (p->pixel_height); + w->pixel_width_before_size_change + = XFASTINT (p->pixel_width_before_size_change); + w->pixel_height_before_size_change + = XFASTINT (p->pixel_height_before_size_change); w->left_col = XFASTINT (p->left_col); w->top_line = XFASTINT (p->top_line); w->total_cols = XFASTINT (p->total_cols); @@ -6205,6 +6308,9 @@ the return value is nil. Otherwise the value is t. */) if (BUFFERP (p->buffer) && BUFFER_LIVE_P (XBUFFER (p->buffer))) /* If saved buffer is alive, install it. */ { + if (!EQ (w->contents, p->buffer)) + /* Record buffer configuration change. */ + buffer_changed = true; wset_buffer (w, p->buffer); w->start_at_line_beg = !NILP (p->start_at_line_beg); set_marker_restricted (w->start, p->start, w->contents); @@ -6238,6 +6344,8 @@ the return value is nil. Otherwise the value is t. */) else if (!NILP (w->start)) /* Leaf window has no live buffer, get one. */ { + /* Record buffer configuration change. */ + buffer_changed = true; /* Get the buffer via other_buffer_safely in order to avoid showing an unimportant buffer and, if necessary, to recreate *scratch* in the course (part of Juanma's bs-show @@ -6285,7 +6393,10 @@ the return value is nil. Otherwise the value is t. */) /* Now, free glyph matrices in windows that were not reused. */ for (i = 0; i < n_leaf_windows; i++) if (NILP (leaf_windows[i]->contents)) - free_window_matrices (leaf_windows[i]); + { + free_window_matrices (leaf_windows[i]); + window_changed = true; + } /* Allow x_set_window_size again and apply frame size changes if needed. */ @@ -6305,7 +6416,8 @@ the return value is nil. Otherwise the value is t. */) /* Record the selected window's buffer here. The window should already be the selected one from the call above. */ - select_window (data->current_window, Qnil, false); + if (WINDOW_LIVE_P (data->current_window)) + select_window (data->current_window, Qnil, false); /* Fselect_window will have made f the selected frame, so we reselect the proper frame here. Fhandle_switch_frame will change the @@ -6315,7 +6427,32 @@ the return value is nil. Otherwise the value is t. */) if (FRAME_LIVE_P (XFRAME (data->selected_frame))) do_switch_frame (data->selected_frame, 0, 0, Qnil); - run_window_configuration_change_hook (f); + if (window_changed) + /* At least one window has been added or removed. Run + `window-configuration-change-hook' and make sure + `window-size-change-functions' get run later. + + We have to do this in order to capture the following + scenario: Suppose our frame contains two live windows W1 and + W2 and ‘set-window-configuration’ replaces them by two + windows W3 and W4 that were dead the last time + run_window_size_change_functions was run. If W3 and W4 have + the same values for their old and new pixel sizes but these + values differ from those of W1 and W2, the sizes of our + frame's two live windows changed but window_size_changed has + no means to detect that fact. + + Obviously, this will get us false positives, for example, + when we restore the original configuration with W1 and W2 + before run_window_size_change_functions gets called. */ + { + run_window_configuration_change_hook (f); + FRAME_WINDOW_CONFIGURATION_CHANGED (f) = true; + } + else if (buffer_changed) + /* At least one window has changed its buffer. Run + `window-configuration-change-hook' only. */ + run_window_configuration_change_hook (f); } if (!NILP (new_current_buffer)) @@ -6466,6 +6603,10 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i) p->pixel_top = make_number (w->pixel_top); p->pixel_width = make_number (w->pixel_width); p->pixel_height = make_number (w->pixel_height); + p->pixel_width_before_size_change + = make_number (w->pixel_width_before_size_change); + p->pixel_height_before_size_change + = make_number (w->pixel_height_before_size_change); p->left_col = make_number (w->left_col); p->top_line = make_number (w->top_line); p->total_cols = make_number (w->total_cols); @@ -6609,7 +6750,7 @@ saved by this function. */) data->frame_tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f); data->selected_frame = selected_frame; data->current_window = FRAME_SELECTED_WINDOW (f); - XSETBUFFER (data->current_buffer, current_buffer); + XSETBUFFER (data->f_current_buffer, current_buffer); data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window : Qnil; data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil; data->root_window = FRAME_ROOT_WINDOW (f); @@ -7064,7 +7205,7 @@ compare_window_configurations (Lisp_Object configuration1, || d1->frame_lines != d2->frame_lines || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines || !EQ (d1->selected_frame, d2->selected_frame) - || !EQ (d1->current_buffer, d2->current_buffer) + || !EQ (d1->f_current_buffer, d2->f_current_buffer) || (!ignore_positions && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window))) @@ -7166,10 +7307,11 @@ syms_of_window (void) DEFSYM (Qwindow_valid_p, "window-valid-p"); DEFSYM (Qwindow_deletable_p, "window-deletable-p"); DEFSYM (Qdelete_window, "delete-window"); - DEFSYM (Qwindow_resize_root_window, "window--resize-root-window"); - DEFSYM (Qwindow_resize_root_window_vertically, "window--resize-root-window-vertically"); - DEFSYM (Qwindow_sanitize_window_sizes, "window--sanitize-window-sizes"); - DEFSYM (Qwindow_pixel_to_total, "window--pixel-to-total"); + DEFSYM (Qwindow__resize_root_window, "window--resize-root-window"); + DEFSYM (Qwindow__resize_root_window_vertically, + "window--resize-root-window-vertically"); + DEFSYM (Qwindow__sanitize_window_sizes, "window--sanitize-window-sizes"); + DEFSYM (Qwindow__pixel_to_total, "window--pixel-to-total"); DEFSYM (Qsafe, "safe"); DEFSYM (Qdisplay_buffer, "display-buffer"); DEFSYM (Qreplace_buffer_in_windows, "replace-buffer-in-windows"); @@ -7248,6 +7390,16 @@ selected; while the global part is run only once for the modified frame, with the relevant frame selected. */); Vwindow_configuration_change_hook = Qnil; + DEFVAR_LISP ("window-size-change-functions", Vwindow_size_change_functions, + doc: /* Functions called during redisplay, if window sizes have changed. +The value should be a list of functions that take one argument. +During the first part of redisplay, for each frame, if any of its windows +have changed size since the last redisplay, or have been split or deleted, +all the functions in the list are called, with the frame as argument. +If redisplay decides to resize the minibuffer window, it calls these +functions on behalf of that as well. */); + Vwindow_size_change_functions = Qnil; + DEFVAR_LISP ("recenter-redisplay", Vrecenter_redisplay, doc: /* Non-nil means `recenter' redraws entire frame. If this option is non-nil, then the `recenter' command with a nil @@ -7376,6 +7528,8 @@ displayed after a scrolling operation to be somewhat inaccurate. */); defsubr (&Swindow_use_time); defsubr (&Swindow_pixel_width); defsubr (&Swindow_pixel_height); + defsubr (&Swindow_pixel_width_before_size_change); + defsubr (&Swindow_pixel_height_before_size_change); defsubr (&Swindow_total_width); defsubr (&Swindow_total_height); defsubr (&Swindow_normal_size); @@ -7417,7 +7571,6 @@ displayed after a scrolling operation to be somewhat inaccurate. */); defsubr (&Sset_window_display_table); defsubr (&Snext_window); defsubr (&Sprevious_window); - defsubr (&Swindow__sanitize_window_sizes); defsubr (&Sget_buffer_window); defsubr (&Sdelete_other_windows_internal); defsubr (&Sdelete_window_internal); diff --git a/src/window.h b/src/window.h index 4845f757e3b..717f972b630 100644 --- a/src/window.h +++ b/src/window.h @@ -214,6 +214,11 @@ struct window int pixel_width; int pixel_height; + /* The pixel sizes of the window at the last time + `window-size-change-functions' was run. */ + int pixel_width_before_size_change; + int pixel_height_before_size_change; + /* The size of the window. */ int total_cols; int total_lines; @@ -392,6 +397,25 @@ struct window ptrdiff_t window_end_bytepos; }; +INLINE bool +WINDOWP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_WINDOW); +} + +INLINE void +CHECK_WINDOW (Lisp_Object x) +{ + CHECK_TYPE (WINDOWP (x), Qwindowp, x); +} + +INLINE struct window * +XWINDOW (Lisp_Object a) +{ + eassert (WINDOWP (a)); + return XUNTAG (a, Lisp_Vectorlike); +} + /* Most code should use these functions to set Lisp fields in struct window. */ INLINE void @@ -499,15 +523,17 @@ wset_next_buffers (struct window *w, Lisp_Object val) #define WINDOW_LEAF_P(W) \ (BUFFERP ((W)->contents)) -/* True if W is a member of horizontal combination. */ +/* Non-nil if W is internal. */ +#define WINDOW_INTERNAL_P(W) \ + (WINDOWP ((W)->contents)) +/* True if W is a member of horizontal combination. */ #define WINDOW_HORIZONTAL_COMBINATION_P(W) \ - (WINDOWP ((W)->contents) && (W)->horizontal) + (WINDOW_INTERNAL_P (W) && (W)->horizontal) /* True if W is a member of vertical combination. */ - #define WINDOW_VERTICAL_COMBINATION_P(W) \ - (WINDOWP ((W)->contents) && !(W)->horizontal) + (WINDOW_INTERNAL_P (W) && !(W)->horizontal) /* WINDOW's XFRAME. */ #define WINDOW_XFRAME(W) (XFRAME (WINDOW_FRAME ((W)))) @@ -786,7 +812,7 @@ wset_next_buffers (struct window *w, Lisp_Object val) || WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_RIGHT (W)) #if (defined (HAVE_WINDOW_SYSTEM) \ - && ((defined (USE_TOOLKIT_SCROLL_BARS) && !defined (HAVE_NS)) \ + && ((defined (USE_TOOLKIT_SCROLL_BARS)) \ || defined (HAVE_NTGUI))) # define USE_HORIZONTAL_SCROLL_BARS true #else @@ -1013,7 +1039,7 @@ extern void grow_mini_window (struct window *, int, bool); extern void shrink_mini_window (struct window *, bool); extern int window_relative_x_coord (struct window *, enum window_part, int); -void run_window_configuration_change_hook (struct frame *f); +void run_window_size_change_functions (Lisp_Object); /* Make WINDOW display BUFFER. RUN_HOOKS_P means it's allowed to run hooks. See make_frame for a case where it's not allowed. */ @@ -1056,7 +1082,6 @@ extern void wset_redisplay (struct window *w); extern void fset_redisplay (struct frame *f); extern void bset_redisplay (struct buffer *b); extern void bset_update_mode_line (struct buffer *b); -extern void maybe_set_redisplay (Lisp_Object); /* Call this to tell redisplay to look for other windows than selected-window that need to be redisplayed. Calling one of the *set_redisplay functions above already does it, so it's only needed in unusual cases. */ @@ -1098,7 +1123,7 @@ extern int window_body_width (struct window *w, bool); extern void temp_output_buffer_show (Lisp_Object); extern void replace_buffer_in_windows (Lisp_Object); extern void replace_buffer_in_windows_safely (Lisp_Object); -extern Lisp_Object sanitize_window_sizes (Lisp_Object, Lisp_Object); +extern void sanitize_window_sizes (Lisp_Object horizontal); /* This looks like a setter, but it is a bit special. */ extern void wset_buffer (struct window *, Lisp_Object); extern bool window_outdated (struct window *); diff --git a/src/xdisp.c b/src/xdisp.c index f575b27fec5..aced59e1b8e 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -288,6 +288,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include <limits.h> #include "lisp.h" @@ -621,15 +622,15 @@ bset_update_mode_line (struct buffer *b) b->text->redisplay = true; } -void -maybe_set_redisplay (Lisp_Object symbol) +DEFUN ("set-buffer-redisplay", Fset_buffer_redisplay, + Sset_buffer_redisplay, 4, 4, 0, + doc: /* Mark the current buffer for redisplay. +This function may be passed to `add-variable-watcher'. */) + (Lisp_Object symbol, Lisp_Object newval, Lisp_Object op, Lisp_Object where) { - if (HASH_TABLE_P (Vredisplay__variables) - && hash_lookup (XHASH_TABLE (Vredisplay__variables), symbol, NULL) >= 0) - { - bset_update_mode_line (current_buffer); - current_buffer->prevent_redisplay_optimizations_p = true; - } + bset_update_mode_line (current_buffer); + current_buffer->prevent_redisplay_optimizations_p = true; + return Qnil; } #ifdef GLYPH_DEBUG @@ -817,6 +818,8 @@ static void iterate_out_of_display_property (struct it *); static void pop_it (struct it *); static void redisplay_internal (void); static void echo_area_display (bool); +static void block_buffer_flips (void); +static void unblock_buffer_flips (void); static void redisplay_windows (Lisp_Object); static void redisplay_window (Lisp_Object, bool); static Lisp_Object redisplay_window_error (Lisp_Object); @@ -1247,27 +1250,18 @@ default_line_pixel_height (struct window *w) static Lisp_Object string_from_display_spec (Lisp_Object spec) { - if (CONSP (spec)) + if (VECTORP (spec)) { - while (CONSP (spec)) - { - if (STRINGP (XCAR (spec))) - return XCAR (spec); - spec = XCDR (spec); - } + for (ptrdiff_t i = 0; i < ASIZE (spec); i++) + if (STRINGP (AREF (spec, i))) + return AREF (spec, i); } - else if (VECTORP (spec)) + else { - ptrdiff_t i; - - for (i = 0; i < ASIZE (spec); i++) - { - if (STRINGP (AREF (spec, i))) - return AREF (spec, i); - } - return Qnil; + for (; CONSP (spec); spec = XCDR (spec)) + if (STRINGP (XCAR (spec))) + return XCAR (spec); } - return spec; } @@ -1317,10 +1311,16 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, SET_TEXT_POS_FROM_MARKER (top, w->start); /* Scrolling a minibuffer window via scroll bar when the echo area shows long text sometimes resets the minibuffer contents behind - our backs. */ - if (CHARPOS (top) > ZV) + our backs. Also, someone might narrow-to-region and immediately + call a scroll function. */ + if (CHARPOS (top) > ZV || CHARPOS (top) < BEGV) SET_TEXT_POS (top, BEGV, BEGV_BYTE); + /* If the top of the window is after CHARPOS, the latter is surely + not visible. */ + if (charpos >= 0 && CHARPOS (top) > charpos) + return visible_p; + /* Compute exact mode line heights. */ if (WINDOW_WANTS_MODELINE_P (w)) w->mode_line_height @@ -1813,7 +1813,7 @@ estimate_mode_line_height (struct frame *f, enum face_id face_id) cache and mode line face are not yet initialized. */ if (FRAME_FACE_CACHE (f)) { - struct face *face = FACE_FROM_ID (f, face_id); + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); if (face) { if (face->font) @@ -2232,7 +2232,7 @@ get_phys_cursor_geometry (struct window *w, struct glyph_row *row, ascent = row->ascent; if (row->ascent < glyph->ascent) { - y =- glyph->ascent - row->ascent; + y -= glyph->ascent - row->ascent; ascent = glyph->ascent; } @@ -2494,7 +2494,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect) /* Visible feedback for debugging. */ #if false && defined HAVE_X_WINDOWS - XDrawRectangle (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawRectangle (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), f->output_data.x->normal_gc, gx, gy, width, height); #endif @@ -2918,7 +2918,7 @@ init_iterator (struct it *it, struct window *w, /* If we have a boxed mode line, make the first character appear with a left box line. */ - face = FACE_FROM_ID (it->f, remapped_base_face_id); + face = FACE_FROM_ID_OR_NULL (it->f, remapped_base_face_id); if (face && face->box != FACE_NO_BOX) it->start_of_box_run_p = true; } @@ -3877,9 +3877,9 @@ handle_face_prop (struct it *it) { struct face *new_face = FACE_FROM_ID (it->f, new_face_id); /* If it->face_id is -1, old_face below will be NULL, see - the definition of FACE_FROM_ID. This will happen if this - is the initial call that gets the face. */ - struct face *old_face = FACE_FROM_ID (it->f, it->face_id); + the definition of FACE_FROM_ID_OR_NULL. This will happen + if this is the initial call that gets the face. */ + struct face *old_face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); /* If the value of face_id of the iterator is -1, we have to look in front of IT's position and see whether there is a @@ -3888,7 +3888,7 @@ handle_face_prop (struct it *it) { int prev_face_id = face_before_it_pos (it); - old_face = FACE_FROM_ID (it->f, prev_face_id); + old_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); } /* If the new face has a box, but the old face does not, @@ -3988,7 +3988,7 @@ handle_face_prop (struct it *it) if (new_face_id != it->face_id) { struct face *new_face = FACE_FROM_ID (it->f, new_face_id); - struct face *old_face = FACE_FROM_ID (it->f, it->face_id); + struct face *old_face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); /* If new face has a box but old face hasn't, this is the start of a run of characters with box, i.e. it has a @@ -4847,7 +4847,6 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, it->font_height = XCAR (XCDR (spec)); if (!NILP (it->font_height)) { - struct face *face = FACE_FROM_ID (it->f, it->face_id); int new_height = -1; if (CONSP (it->font_height) @@ -4866,6 +4865,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, { /* Call function with current height as argument. Value is the new height. */ + struct face *face = FACE_FROM_ID (it->f, it->face_id); Lisp_Object height; height = safe_call1 (it->font_height, face->lface[LFACE_HEIGHT_INDEX]); @@ -4887,6 +4887,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, /* Evaluate IT->font_height with `height' bound to the current specified height to get the new height. */ ptrdiff_t count = SPECPDL_INDEX (); + struct face *face = FACE_FROM_ID (it->f, it->face_id); specbind (Qheight, face->lface[LFACE_HEIGHT_INDEX]); value = safe_eval (it->font_height); @@ -5016,8 +5017,6 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, || EQ (XCAR (spec), Qright_fringe)) && CONSP (XCDR (spec))) { - int fringe_bitmap; - if (it) { if (!FRAME_WINDOW_P (it->f)) @@ -5042,8 +5041,8 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, #ifdef HAVE_WINDOW_SYSTEM value = XCAR (XCDR (spec)); - if (!SYMBOLP (value) - || !(fringe_bitmap = lookup_fringe_bitmap (value))) + int fringe_bitmap = SYMBOLP (value) ? lookup_fringe_bitmap (value) : 0; + if (! fringe_bitmap) /* If we return here, POSITION has been advanced across the text with this property. */ { @@ -6096,7 +6095,7 @@ pop_it (struct it *it) break; case GET_FROM_STRING: { - struct face *face = FACE_FROM_ID (it->f, it->face_id); + struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); /* Restore the face_box_p flag, since it could have been overwritten by the face of the object that we just finished @@ -6778,7 +6777,8 @@ static next_element_function const get_next_element[NUM_IT_METHODS] = || ((IT)->cmp_it.stop_pos == (CHARPOS) \ && composition_reseat_it (&(IT)->cmp_it, CHARPOS, BYTEPOS, \ END_CHARPOS, (IT)->w, \ - FACE_FROM_ID ((IT)->f, (IT)->face_id), \ + FACE_FROM_ID_OR_NULL ((IT)->f, \ + (IT)->face_id), \ (IT)->string))) @@ -7081,6 +7081,19 @@ get_next_display_element (struct it *it) goto display_control; } + /* Handle non-ascii hyphens in the mode where it only + gets highlighting. */ + + if (nonascii_hyphen_p && EQ (Vnobreak_char_display, Qt)) + { + /* Merge `nobreak-space' into the current face. */ + face_id = merge_faces (it->f, Qnobreak_hyphen, 0, + it->face_id); + XSETINT (it->ctl_chars[0], '-'); + ctl_len = 1; + goto display_control; + } + /* Handle sequences that start with the "escape glyph". */ /* the default escape glyph is \. */ @@ -7097,15 +7110,6 @@ get_next_display_element (struct it *it) ? merge_faces (it->f, Qt, lface_id, it->face_id) : merge_escape_glyph_face (it)); - /* Draw non-ASCII hyphen with just highlighting: */ - - if (nonascii_hyphen_p && EQ (Vnobreak_char_display, Qt)) - { - XSETINT (it->ctl_chars[0], '-'); - ctl_len = 1; - goto display_control; - } - /* Draw non-ASCII space/hyphen with escape glyph: */ if (nonascii_space_p || nonascii_hyphen_p) @@ -7203,7 +7207,7 @@ get_next_display_element (struct it *it) if (it->method == GET_FROM_STRING && it->sp) { int face_id = underlying_face_id (it); - struct face *face = FACE_FROM_ID (it->f, face_id); + struct face *face = FACE_FROM_ID_OR_NULL (it->f, face_id); if (face) { @@ -7736,8 +7740,8 @@ next_element_from_display_vector (struct it *it) /* Glyphs in the display vector could have the box face, so we need to set the related flags in the iterator, as appropriate. */ - this_face = FACE_FROM_ID (it->f, it->face_id); - prev_face = FACE_FROM_ID (it->f, prev_face_id); + this_face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); + prev_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); /* Is this character the first character of a box-face run? */ it->start_of_box_run_p = (this_face && this_face->box != FACE_NO_BOX @@ -7762,7 +7766,7 @@ next_element_from_display_vector (struct it *it) it->saved_face_id); } } - next_face = FACE_FROM_ID (it->f, next_face_id); + next_face = FACE_FROM_ID_OR_NULL (it->f, next_face_id); it->end_of_box_run_p = (this_face && this_face->box != FACE_NO_BOX && (!next_face || next_face->box == FACE_NO_BOX)); @@ -8554,7 +8558,8 @@ move_it_in_display_line_to (struct it *it, void *ppos_data = NULL; bool may_wrap = false; enum it_method prev_method = it->method; - ptrdiff_t closest_pos IF_LINT (= 0), prev_pos = IT_CHARPOS (*it); + ptrdiff_t closest_pos UNINIT; + ptrdiff_t prev_pos = IT_CHARPOS (*it); bool saw_smaller_pos = prev_pos < to_charpos; /* Don't produce glyphs in produce_glyphs. */ @@ -8605,8 +8610,7 @@ move_it_in_display_line_to (struct it *it, && it->dpvec + it->current.dpvec_index + 1 >= it->dpend))) /* If there's a line-/wrap-prefix, handle it. */ - if (it->hpos == 0 && it->method == GET_FROM_BUFFER - && it->current_y < it->last_visible_y) + if (it->hpos == 0 && it->method == GET_FROM_BUFFER) handle_line_prefix (it); if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos)) @@ -9033,6 +9037,11 @@ move_it_in_display_line_to (struct it *it, } else result = MOVE_NEWLINE_OR_CR; + /* If we've processed the newline, make sure this flag is + reset, as it must only be set when the newline itself is + processed. */ + if (result == MOVE_NEWLINE_OR_CR) + it->constrain_row_ascent_descent_p = false; break; } @@ -9868,26 +9877,28 @@ the maximum pixel-height of all text lines. The optional argument FROM, if non-nil, specifies the first text position and defaults to the minimum accessible position of the buffer. -If FROM is t, use the minimum accessible position that is not a newline -character. TO, if non-nil, specifies the last text position and +If FROM is t, use the minimum accessible position that starts a +non-empty line. TO, if non-nil, specifies the last text position and defaults to the maximum accessible position of the buffer. If TO is t, -use the maximum accessible position that is not a newline character. +use the maximum accessible position that ends a non-empty line. The optional argument X-LIMIT, if non-nil, specifies the maximum text width that can be returned. X-LIMIT nil or omitted, means to use the -pixel-width of WINDOW's body; use this if you do not intend to change -the width of WINDOW. Use the maximum width WINDOW may assume if you -intend to change WINDOW's width. In any case, text whose x-coordinate -is beyond X-LIMIT is ignored. Since calculating the width of long lines -can take some time, it's always a good idea to make this argument as -small as possible; in particular, if the buffer contains long lines that -shall be truncated anyway. +pixel-width of WINDOW's body; use this if you want to know how high +WINDOW should be become in order to fit all of its buffer's text with +the width of WINDOW unaltered. Use the maximum width WINDOW may assume +if you intend to change WINDOW's width. In any case, text whose +x-coordinate is beyond X-LIMIT is ignored. Since calculating the width +of long lines can take some time, it's always a good idea to make this +argument as small as possible; in particular, if the buffer contains +long lines that shall be truncated anyway. The optional argument Y-LIMIT, if non-nil, specifies the maximum text -height that can be returned. Text lines whose y-coordinate is beyond -Y-LIMIT are ignored. Since calculating the text height of a large -buffer can take some time, it makes sense to specify this argument if -the size of the buffer is unknown. +height (excluding the height of the mode- or header-line, if any) that +can be returned. Text lines whose y-coordinate is beyond Y-LIMIT are +ignored. Since calculating the text height of a large buffer can take +some time, it makes sense to specify this argument if the size of the +buffer is large or unknown. Optional argument MODE-AND-HEADER-LINE nil or omitted means do not include the height of the mode- or header-line of WINDOW in the return @@ -9905,7 +9916,7 @@ include the height of both, if present, in the return value. */) ptrdiff_t start, end, pos; struct text_pos startp; void *itdata = NULL; - int c, max_y = -1, x = 0, y = 0; + int c, max_x = 0, max_y = 0, x = 0, y = 0; CHECK_BUFFER (buffer); b = XBUFFER (buffer); @@ -9950,11 +9961,13 @@ include the height of both, if present, in the return value. */) end = max (start, min (XINT (to), ZV)); } - if (!NILP (y_limit)) - { - CHECK_NUMBER (y_limit); - max_y = min (XINT (y_limit), INT_MAX); - } + if (!NILP (x_limit) && RANGED_INTEGERP (0, x_limit, INT_MAX)) + max_x = XINT (x_limit); + + if (NILP (y_limit)) + max_y = INT_MAX; + else if (RANGED_INTEGERP (0, y_limit, INT_MAX)) + max_y = XINT (y_limit); itdata = bidi_shelve_cache (); SET_TEXT_POS (startp, start, CHAR_TO_BYTE (start)); @@ -9964,27 +9977,33 @@ include the height of both, if present, in the return value. */) x = move_it_to (&it, end, -1, max_y, -1, MOVE_TO_POS | MOVE_TO_Y); else { - CHECK_NUMBER (x_limit); - it.last_visible_x = min (XINT (x_limit), INFINITY); + it.last_visible_x = max_x; /* Actually, we never want move_it_to stop at to_x. But to make sure that move_it_in_display_line_to always moves far enough, we set it to INT_MAX and specify MOVE_TO_X. */ x = move_it_to (&it, end, INT_MAX, max_y, -1, MOVE_TO_POS | MOVE_TO_X | MOVE_TO_Y); + /* Don't return more than X-LIMIT. */ + if (x > max_x) + x = max_x; } - y = it.current_y + it.max_ascent + it.max_descent; + /* Subtract height of header-line which was counted automatically by + start_display. */ + y = it.current_y + it.max_ascent + it.max_descent + - WINDOW_HEADER_LINE_HEIGHT (w); + /* Don't return more than Y-LIMIT. */ + if (y > max_y) + y = max_y; - if (!EQ (mode_and_header_line, Qheader_line) - && !EQ (mode_and_header_line, Qt)) - /* Do not count the header-line which was counted automatically by - start_display. */ - y = y - WINDOW_HEADER_LINE_HEIGHT (w); + if (EQ (mode_and_header_line, Qheader_line) + || EQ (mode_and_header_line, Qt)) + /* Re-add height of header-line as requested. */ + y = y + WINDOW_HEADER_LINE_HEIGHT (w); if (EQ (mode_and_header_line, Qmode_line) || EQ (mode_and_header_line, Qt)) - /* Do count the mode-line which is not included automatically by - start_display. */ + /* Add height of mode-line as requested. */ y = y + WINDOW_MODE_LINE_HEIGHT (w); bidi_unshelve_cache (itdata, false); @@ -10562,25 +10581,21 @@ update_echo_area (void) static void ensure_echo_area_buffers (void) { - int i; - - for (i = 0; i < 2; ++i) + for (int i = 0; i < 2; i++) if (!BUFFERP (echo_buffer[i]) || !BUFFER_LIVE_P (XBUFFER (echo_buffer[i]))) { - char name[30]; - Lisp_Object old_buffer; - int j; - - old_buffer = echo_buffer[i]; - echo_buffer[i] = Fget_buffer_create - (make_formatted_string (name, " *Echo Area %d*", i)); + Lisp_Object old_buffer = echo_buffer[i]; + static char const name_fmt[] = " *Echo Area %d*"; + char name[sizeof name_fmt + INT_STRLEN_BOUND (int)]; + AUTO_STRING_WITH_LEN (lname, name, sprintf (name, name_fmt, i)); + echo_buffer[i] = Fget_buffer_create (lname); bset_truncate_lines (XBUFFER (echo_buffer[i]), Qnil); /* to force word wrap in echo area - it was decided to postpone this*/ /* XBUFFER (echo_buffer[i])->word_wrap = Qt; */ - for (j = 0; j < 2; ++j) + for (int j = 0; j < 2; j++) if (EQ (old_buffer, echo_area_buffer[j])) echo_area_buffer[j] = echo_buffer[i]; } @@ -11327,7 +11342,7 @@ clear_garbaged_frames (void) fset_redisplay (f); f->garbaged = false; f->resized_p = false; - } + } } frame_garbaged = false; @@ -11725,6 +11740,12 @@ x_consider_frame_title (Lisp_Object frame) record_unwind_protect (unwind_format_mode_line, format_mode_line_unwind_data (f, current_buffer, selected_window, false)); + /* select-frame calls resize_mini_window, which could resize the + mini-window and by that undo the effect of this redisplay + cycle wrt minibuffer and echo-area display. Binding + inhibit-redisplay to t makes the call to resize_mini_window a + no-op, thus avoiding the adverse side effects. */ + specbind (Qinhibit_redisplay, Qt); Fselect_window (f->selected_window, Qt); set_buffer_internal_1 @@ -11867,24 +11888,7 @@ prepare_menu_bars (void) && !XBUFFER (w->contents)->text->redisplay) continue; - /* If a window on this frame changed size, report that to - the user and clear the size-change flag. */ - if (FRAME_WINDOW_SIZES_CHANGED (f)) - { - Lisp_Object functions; - - /* Clear flag first in case we get an error below. */ - FRAME_WINDOW_SIZES_CHANGED (f) = false; - functions = Vwindow_size_change_functions; - - while (CONSP (functions)) - { - if (!EQ (XCAR (functions), Qt)) - call1 (XCAR (functions), frame); - functions = XCDR (functions); - } - } - + run_window_size_change_functions (frame); menu_bar_hooks_run = update_menu_bar (f, false, menu_bar_hooks_run); #ifdef HAVE_WINDOW_SYSTEM update_tool_bar (f, false); @@ -13036,6 +13040,17 @@ hscroll_window_tree (Lisp_Object window) init_to_row_start (&it, w, cursor_row); it.last_visible_x = INFINITY; move_it_in_display_line_to (&it, pt, -1, MOVE_TO_POS); + /* If the line ends in an overlay string with a newline, + we might infloop, because displaying the window will + want to put the cursor after the overlay, i.e. at X + coordinate of zero on the next screen line. So we + use the buffer position prior to the overlay string + instead. */ + if (it.method == GET_FROM_STRING && pt > 1) + { + init_to_row_start (&it, w, cursor_row); + move_it_in_display_line_to (&it, pt - 1, -1, MOVE_TO_POS); + } current_buffer = saved_current_buffer; /* Position cursor in window. */ @@ -13517,6 +13532,12 @@ redisplay_internal (void) bool polling_stopped_here = false; Lisp_Object tail, frame; + /* Set a limit to the number of retries we perform due to horizontal + scrolling, this avoids getting stuck in an uninterruptible + infinite loop (Bug #24633). */ + enum { MAX_HSCROLL_RETRIES = 16 }; + int hscroll_retries = 0; + /* True means redisplay has to consider all windows on all frames. False, only selected_window is considered. */ bool consider_all_windows_p; @@ -13556,10 +13577,11 @@ redisplay_internal (void) count = SPECPDL_INDEX (); record_unwind_protect_void (unwind_redisplay); redisplaying_p = true; + block_buffer_flips (); specbind (Qinhibit_free_realized_faces, Qnil); /* Record this function, so it appears on the profiler's backtraces. */ - record_in_backtrace (Qredisplay_internal, 0, 0); + record_in_backtrace (Qredisplay_internal_xC_functionx, 0, 0); FOR_EACH_FRAME (tail, frame) XFRAME (frame)->already_hscrolled_p = false; @@ -13680,24 +13702,12 @@ redisplay_internal (void) it's too late for the hooks in window-size-change-functions, which have been examined already in prepare_menu_bars. So in that case we call the hooks here only for the selected frame. */ - if (sf->redisplay && FRAME_WINDOW_SIZES_CHANGED (sf)) + if (sf->redisplay) { - Lisp_Object functions; ptrdiff_t count1 = SPECPDL_INDEX (); record_unwind_save_match_data (); - - /* Clear flag first in case we get an error below. */ - FRAME_WINDOW_SIZES_CHANGED (sf) = false; - functions = Vwindow_size_change_functions; - - while (CONSP (functions)) - { - if (!EQ (XCAR (functions), Qt)) - call1 (XCAR (functions), selected_frame); - functions = XCDR (functions); - } - + run_window_size_change_functions (selected_frame); unbind_to (count1, Qnil); } @@ -13719,22 +13729,10 @@ redisplay_internal (void) { if (sf->redisplay) { - Lisp_Object functions; ptrdiff_t count1 = SPECPDL_INDEX (); record_unwind_save_match_data (); - - /* Clear flag first in case we get an error below. */ - FRAME_WINDOW_SIZES_CHANGED (sf) = false; - functions = Vwindow_size_change_functions; - - while (CONSP (functions)) - { - if (!EQ (XCAR (functions), Qt)) - call1 (XCAR (functions), selected_frame); - functions = XCDR (functions); - } - + run_window_size_change_functions (selected_frame); unbind_to (count1, Qnil); } @@ -14057,8 +14055,12 @@ redisplay_internal (void) if (!f->already_hscrolled_p) { f->already_hscrolled_p = true; - if (hscroll_windows (f->root_window)) - goto retry_frame; + if (hscroll_retries <= MAX_HSCROLL_RETRIES + && hscroll_windows (f->root_window)) + { + hscroll_retries++; + goto retry_frame; + } } /* If the frame's redisplay flag was not set before @@ -14073,7 +14075,23 @@ redisplay_internal (void) use them in update_frame will segfault. Therefore, we must redisplay this frame. */ if (!f_redisplay_flag && f->redisplay) - goto retry_frame; + goto retry_frame; + + /* In some case (e.g., window resize), we notice + only during window updating that the window + content changed unpredictably (e.g., a GTK + scrollbar moved) and that our previous estimation + of the frame content was garbage. We have to + start over. These cases should be rare, so going + all the way back to the top of redisplay should + be good enough. + + Why FRAME_WINDOW_P? See + https://lists.gnu.org/archive/html/emacs-devel/2016-10/msg00957.html + + */ + if (FRAME_GARBAGED_P (f) && FRAME_WINDOW_P (f)) + goto retry; /* Prevent various kinds of signals during display update. stdio is not robust about handling @@ -14102,6 +14120,7 @@ redisplay_internal (void) if (f->updated_p) { f->redisplay = false; + f->garbaged = false; mark_window_display_accurate (f->root_window, true); if (FRAME_TERMINAL (f)->frame_up_to_date_hook) FRAME_TERMINAL (f)->frame_up_to_date_hook (f); @@ -14111,9 +14130,6 @@ redisplay_internal (void) } else if (FRAME_VISIBLE_P (sf) && !FRAME_OBSCURED_P (sf)) { - Lisp_Object mini_window = FRAME_MINIBUF_WINDOW (sf); - struct frame *mini_frame; - displayed_buffer = XBUFFER (XWINDOW (selected_window)->contents); /* Use list_of_error, not Qerror, so that we catch only errors and don't run the debugger. */ @@ -14121,8 +14137,8 @@ redisplay_internal (void) list_of_error, redisplay_window_error); if (update_miniwindow_p) - internal_condition_case_1 (redisplay_window_1, mini_window, - list_of_error, + internal_condition_case_1 (redisplay_window_1, + FRAME_MINIBUF_WINDOW (sf), list_of_error, redisplay_window_error); /* Compare desired and current matrices, perform output. */ @@ -14159,8 +14175,12 @@ redisplay_internal (void) if (FRAME_VISIBLE_P (sf) && !FRAME_OBSCURED_P (sf)) { - if (hscroll_windows (selected_window)) - goto retry; + if (hscroll_retries <= MAX_HSCROLL_RETRIES + && hscroll_windows (selected_window)) + { + hscroll_retries++; + goto retry; + } XWINDOW (selected_window)->must_be_updated_p = true; pending = update_frame (sf, false, false); @@ -14172,16 +14192,20 @@ redisplay_internal (void) have put text on a frame other than the selected one, so the above call to update_frame would not have caught it. Catch it here. */ - mini_window = FRAME_MINIBUF_WINDOW (sf); - mini_frame = XFRAME (WINDOW_FRAME (XWINDOW (mini_window))); + Lisp_Object mini_window = FRAME_MINIBUF_WINDOW (sf); + struct frame *mini_frame = XFRAME (WINDOW_FRAME (XWINDOW (mini_window))); if (mini_frame != sf && FRAME_WINDOW_P (mini_frame)) { XWINDOW (mini_window)->must_be_updated_p = true; pending |= update_frame (mini_frame, false, false); mini_frame->cursor_type_changed = false; - if (!pending && hscroll_windows (mini_window)) - goto retry; + if (!pending && hscroll_retries <= MAX_HSCROLL_RETRIES + && hscroll_windows (mini_window)) + { + hscroll_retries++; + goto retry; + } } } @@ -14295,6 +14319,11 @@ redisplay_internal (void) RESUME_POLLING; } +static void +unwind_redisplay_preserve_echo_area (void) +{ + unblock_buffer_flips (); +} /* Redisplay, but leave alone any recent echo area message unless another message has been requested in its place. @@ -14312,6 +14341,12 @@ redisplay_preserve_echo_area (int from_where) { TRACE ((stderr, "redisplay_preserve_echo_area (%d)\n", from_where)); + block_input (); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_void (unwind_redisplay_preserve_echo_area); + block_buffer_flips (); + unblock_input (); + if (!NILP (echo_area_buffer[1])) { /* We have a previously displayed message, but no current @@ -14324,6 +14359,7 @@ redisplay_preserve_echo_area (int from_where) redisplay_internal (); flush_frame (SELECTED_FRAME ()); + unbind_to (count, Qnil); } @@ -14333,6 +14369,7 @@ static void unwind_redisplay (void) { redisplaying_p = false; + unblock_buffer_flips (); } @@ -14442,6 +14479,38 @@ disp_char_vector (struct Lisp_Char_Table *dp, int c) return val; } +static int buffer_flip_blocked_depth; + +static void +block_buffer_flips (void) +{ + eassert (buffer_flip_blocked_depth >= 0); + buffer_flip_blocked_depth++; +} + +static void +unblock_buffer_flips (void) +{ + eassert (buffer_flip_blocked_depth > 0); + if (--buffer_flip_blocked_depth == 0) + { + Lisp_Object tail, frame; + block_input (); + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + if (FRAME_TERMINAL (f)->buffer_flipping_unblocked_hook) + (*FRAME_TERMINAL (f)->buffer_flipping_unblocked_hook) (f); + } + unblock_input (); + } +} + +bool +buffer_flipping_blocked_p (void) +{ + return buffer_flip_blocked_depth > 0; +} /*********************************************************************** @@ -15338,6 +15407,40 @@ try_scrolling (Lisp_Object window, bool just_this_one_p, if (dy > 0) scroll_down_p = true; } + else if (PT == IT_CHARPOS (it) + && IT_CHARPOS (it) < ZV + && it.method == GET_FROM_STRING + && arg_scroll_conservatively > scroll_limit + && it.current_x == 0) + { + enum move_it_result skip; + int y1 = it.current_y; + int vpos; + + /* A before-string that includes newlines and is displayed + on the last visible screen line could fail us under + scroll-conservatively > 100, because we will be unable to + position the cursor on that last visible line. Try to + recover by finding the first screen line that has some + glyphs coming from the buffer text. */ + do { + skip = move_it_in_display_line_to (&it, ZV, -1, MOVE_TO_POS); + if (skip != MOVE_NEWLINE_OR_CR + || IT_CHARPOS (it) != PT + || it.method == GET_FROM_BUFFER) + break; + vpos = it.vpos; + move_it_to (&it, -1, -1, -1, vpos + 1, MOVE_TO_VPOS); + } while (it.vpos > vpos); + + dy = it.current_y - y1; + + if (dy > scroll_max) + return SCROLLING_FAILED; + + if (dy > 0) + scroll_down_p = true; + } } if (scroll_down_p) @@ -15542,12 +15645,14 @@ try_scrolling (Lisp_Object window, bool just_this_one_p, The new window start will be computed, based on W's width, starting from the start of the continued line. It is the start of the - screen line with the minimum distance from the old start W->start. */ + screen line with the minimum distance from the old start W->start, + which is still before point (otherwise point will definitely not + be visible in the window). */ static bool compute_window_start_on_continuation_line (struct window *w) { - struct text_pos pos, start_pos; + struct text_pos pos, start_pos, pos_before_pt; bool window_start_changed_p = false; SET_TEXT_POS_FROM_MARKER (start_pos, w->start); @@ -15575,10 +15680,14 @@ compute_window_start_on_continuation_line (struct window *w) reseat_at_previous_visible_line_start (&it); /* If the line start is "too far" away from the window start, - say it takes too much time to compute a new window start. */ - if (CHARPOS (start_pos) - IT_CHARPOS (it) - /* PXW: Do we need upper bounds here? */ - < WINDOW_TOTAL_LINES (w) * WINDOW_TOTAL_COLS (w)) + say it takes too much time to compute a new window start. + Also, give up if the line start is after point, as in that + case point will not be visible with any window start we + compute. */ + if (IT_CHARPOS (it) <= PT + || (CHARPOS (start_pos) - IT_CHARPOS (it) + /* PXW: Do we need upper bounds here? */ + < WINDOW_TOTAL_LINES (w) * WINDOW_TOTAL_COLS (w))) { int min_distance, distance; @@ -15588,12 +15697,14 @@ compute_window_start_on_continuation_line (struct window *w) decreased, the new window start will be < the old start. So, we're looking for the display line start with the minimum distance from the old window start. */ - pos = it.current.pos; + pos_before_pt = pos = it.current.pos; min_distance = INFINITY; while ((distance = eabs (CHARPOS (start_pos) - IT_CHARPOS (it))), distance < min_distance) { min_distance = distance; + if (CHARPOS (pos) <= PT) + pos_before_pt = pos; pos = it.current.pos; if (it.line_wrap == WORD_WRAP) { @@ -15616,6 +15727,13 @@ compute_window_start_on_continuation_line (struct window *w) move_it_by_lines (&it, 1); } + /* It makes very little sense to make the new window start + after point, as point won't be visible. If that's what + the loop above finds, fall back on the candidate before + or at point that is closest to the old window start. */ + if (CHARPOS (pos) > PT) + pos = pos_before_pt; + /* Set the window start there. */ SET_MARKER_FROM_TEXT_POS (w->start, pos); window_start_changed_p = true; @@ -16163,6 +16281,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) bool last_line_misfit = false; ptrdiff_t beg_unchanged, end_unchanged; int frame_line_height; + bool use_desired_matrix; void *itdata = NULL; SET_TEXT_POS (lpoint, PT, PT_BYTE); @@ -16891,7 +17010,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) itdata = bidi_shelve_cache (); /* Redisplay the window. */ - bool use_desired_matrix = false; + use_desired_matrix = false; if (!current_matrix_up_to_date_p || windows_or_buffers_changed || f->cursor_type_changed @@ -16931,6 +17050,27 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) move_it_by_lines (&it, -1); try_window (window, it.current.pos, 0); } + else if (scroll_conservatively > SCROLL_LIMIT + && (it.method == GET_FROM_STRING + || overlay_touches_p (IT_CHARPOS (it))) + && IT_CHARPOS (it) < ZV) + { + /* If the window starts with a before-string that spans more + than one screen line, using that position to display the + window might fail to bring point into the view, because + start_display will always start by displaying the string, + whereas the code above determines where to set w->start + by the buffer position of the place where it takes screen + coordinates. Try to recover by finding the next screen + line that displays buffer text. */ + ptrdiff_t pos0 = IT_CHARPOS (it); + + clear_glyph_matrix (w->desired_matrix); + do { + move_it_by_lines (&it, 1); + } while (IT_CHARPOS (it) == pos0); + try_window (window, it.current.pos, 0); + } else { /* Not much we can do about it. */ @@ -17131,16 +17271,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) ignore_mouse_drag_p = true; #endif } - ptrdiff_t count1 = SPECPDL_INDEX (); - /* x_consider_frame_title calls select-frame, which calls - resize_mini_window, which could resize the mini-window and by - that undo the effect of this redisplay cycle wrt minibuffer - and echo-area display. Binding inhibit-redisplay to t makes - the call to resize_mini_window a no-op, thus avoiding the - adverse side effects. */ - specbind (Qinhibit_redisplay, Qt); x_consider_frame_title (w->frame); - unbind_to (count1, Qnil); #endif } @@ -18747,7 +18878,7 @@ try_window_id (struct window *w) eassert (MATRIX_ROW_DISPLAYS_TEXT_P (first_unchanged_at_end_row)); row = find_last_row_displaying_text (w->current_matrix, &it, first_unchanged_at_end_row); - eassert (row && MATRIX_ROW_DISPLAYS_TEXT_P (row)); + eassume (row && MATRIX_ROW_DISPLAYS_TEXT_P (row)); adjust_window_ends (w, row, true); eassert (w->window_end_bytepos >= 0); IF_DEBUG (debug_method_add (w, "A")); @@ -18777,10 +18908,9 @@ try_window_id (struct window *w) struct glyph_row *current_row = current_matrix->rows + vpos; struct glyph_row *desired_row = desired_matrix->rows + vpos; - for (row = NULL; - row == NULL && vpos >= first_vpos; - --vpos, --current_row, --desired_row) + for (row = NULL; !row; --vpos, --current_row, --desired_row) { + eassert (first_vpos <= vpos); if (desired_row->enabled_p) { if (MATRIX_ROW_DISPLAYS_TEXT_P (desired_row)) @@ -18790,7 +18920,6 @@ try_window_id (struct window *w) row = current_row; } - eassert (row != NULL); w->window_end_vpos = vpos + 1; w->window_end_pos = Z - MATRIX_ROW_END_CHARPOS (row); w->window_end_bytepos = Z_BYTE - MATRIX_ROW_END_BYTEPOS (row); @@ -19554,7 +19683,6 @@ append_space_for_newline (struct it *it, bool default_face_p) struct text_pos saved_pos; Lisp_Object saved_object; struct face *face; - struct glyph *g; saved_object = it->object; saved_pos = it->position; @@ -19590,7 +19718,7 @@ append_space_for_newline (struct it *it, bool default_face_p) /* Make sure this space glyph has the right ascent and descent values, or else cursor at end of line will look funny, and height of empty lines will be incorrect. */ - g = it->glyph_row->glyphs[TEXT_AREA] + n; + struct glyph *g = it->glyph_row->glyphs[TEXT_AREA] + n; struct font *font = face->font ? face->font : FRAME_FONT (it->f); if (n == 0) { @@ -19715,15 +19843,15 @@ extend_face_to_end_of_line (struct it *it) return; /* The default face, possibly remapped. */ - default_face = FACE_FROM_ID (f, lookup_basic_face (f, DEFAULT_FACE_ID)); + default_face = FACE_FROM_ID_OR_NULL (f, + lookup_basic_face (f, DEFAULT_FACE_ID)); /* Face extension extends the background and box of IT->face_id to the end of the line. If the background equals the background of the frame, we don't have to do anything. */ - if (it->face_before_selective_p) - face = FACE_FROM_ID (f, it->saved_face_id); - else - face = FACE_FROM_ID (f, it->face_id); + face = FACE_FROM_ID (f, (it->face_before_selective_p + ? it->saved_face_id + : it->face_id)); if (FRAME_WINDOW_P (f) && MATRIX_ROW_DISPLAYS_TEXT_P (it->glyph_row) @@ -20463,16 +20591,16 @@ display_line (struct it *it) struct it wrap_it; void *wrap_data = NULL; bool may_wrap = false; - int wrap_x IF_LINT (= 0); + int wrap_x UNINIT; int wrap_row_used = -1; - int wrap_row_ascent IF_LINT (= 0), wrap_row_height IF_LINT (= 0); - int wrap_row_phys_ascent IF_LINT (= 0), wrap_row_phys_height IF_LINT (= 0); - int wrap_row_extra_line_spacing IF_LINT (= 0); - ptrdiff_t wrap_row_min_pos IF_LINT (= 0), wrap_row_min_bpos IF_LINT (= 0); - ptrdiff_t wrap_row_max_pos IF_LINT (= 0), wrap_row_max_bpos IF_LINT (= 0); + int wrap_row_ascent UNINIT, wrap_row_height UNINIT; + int wrap_row_phys_ascent UNINIT, wrap_row_phys_height UNINIT; + int wrap_row_extra_line_spacing UNINIT; + ptrdiff_t wrap_row_min_pos UNINIT, wrap_row_min_bpos UNINIT; + ptrdiff_t wrap_row_max_pos UNINIT, wrap_row_max_bpos UNINIT; int cvpos; ptrdiff_t min_pos = ZV + 1, max_pos = 0; - ptrdiff_t min_bpos IF_LINT (= 0), max_bpos IF_LINT (= 0); + ptrdiff_t min_bpos UNINIT, max_bpos UNINIT; bool pending_handle_line_prefix = false; /* We always start displaying at hpos zero even if hscrolled. */ @@ -21889,7 +22017,6 @@ Value is the new character position of point. */) } /* Move to the target X coordinate. */ -#ifdef HAVE_WINDOW_SYSTEM /* On GUI frames, as we don't know the X coordinate of the character to the left of point, moving point to the left requires walking, one grapheme cluster at a time, until we @@ -21946,9 +22073,7 @@ Value is the new character position of point. */) new_pos.bytepos = CHAR_TO_BYTE (new_pos.charpos); it.current.pos = new_pos; } - else -#endif - if (it.current_x != target_x) + else if (it.current_x != target_x) move_it_in_display_line_to (&it, ZV, target_x, MOVE_TO_POS | MOVE_TO_X); /* If we ended up in a display string that covers point, move to @@ -23410,6 +23535,16 @@ decode_mode_spec_coding (Lisp_Object coding_system, char *buf, bool eol_flag) return buf; } +/* Return the approximate percentage N is of D (rounding upward), or 99, + whichever is less. Assume 0 < D and 0 <= N <= D * INT_MAX / 100. */ + +static int +percent99 (ptrdiff_t n, ptrdiff_t d) +{ + int percent = (d - 1 + 100.0 * n) / d; + return min (percent, 99); +} + /* Return a string for the output of a mode line %-spec for window W, generated by character C. FIELD_WIDTH > 0 means pad the string returned with spaces to that value. Return a Lisp string in @@ -23697,29 +23832,17 @@ decode_mode_spec (struct window *w, register int c, int field_width, case 'p': { ptrdiff_t pos = marker_position (w->start); - ptrdiff_t total = BUF_ZV (b) - BUF_BEGV (b); + ptrdiff_t begv = BUF_BEGV (b); + ptrdiff_t zv = BUF_ZV (b); - if (w->window_end_pos <= BUF_Z (b) - BUF_ZV (b)) - { - if (pos <= BUF_BEGV (b)) - return "All"; - else - return "Bottom"; - } - else if (pos <= BUF_BEGV (b)) + if (w->window_end_pos <= BUF_Z (b) - zv) + return pos <= begv ? "All" : "Bottom"; + else if (pos <= begv) return "Top"; else { - if (total > 1000000) - /* Do it differently for a large value, to avoid overflow. */ - total = ((pos - BUF_BEGV (b)) + (total / 100) - 1) / (total / 100); - else - total = ((pos - BUF_BEGV (b)) * 100 + total - 1) / total; - /* We can't normally display a 3-digit number, - so get us a 2-digit number that is close. */ - if (total == 100) - total = 99; - sprintf (decode_mode_spec_buf, "%2"pD"d%%", total); + sprintf (decode_mode_spec_buf, "%2d%%", + percent99 (pos - begv, zv - begv)); return decode_mode_spec_buf; } } @@ -23729,30 +23852,16 @@ decode_mode_spec (struct window *w, register int c, int field_width, { ptrdiff_t toppos = marker_position (w->start); ptrdiff_t botpos = BUF_Z (b) - w->window_end_pos; - ptrdiff_t total = BUF_ZV (b) - BUF_BEGV (b); + ptrdiff_t begv = BUF_BEGV (b); + ptrdiff_t zv = BUF_ZV (b); - if (botpos >= BUF_ZV (b)) - { - if (toppos <= BUF_BEGV (b)) - return "All"; - else - return "Bottom"; - } + if (zv <= botpos) + return toppos <= begv ? "All" : "Bottom"; else { - if (total > 1000000) - /* Do it differently for a large value, to avoid overflow. */ - total = ((botpos - BUF_BEGV (b)) + (total / 100) - 1) / (total / 100); - else - total = ((botpos - BUF_BEGV (b)) * 100 + total - 1) / total; - /* We can't normally display a 3-digit number, - so get us a 2-digit number that is close. */ - if (total == 100) - total = 99; - if (toppos <= BUF_BEGV (b)) - sprintf (decode_mode_spec_buf, "Top%2"pD"d%%", total); - else - sprintf (decode_mode_spec_buf, "%2"pD"d%%", total); + sprintf (decode_mode_spec_buf, + &"Top%2d%%"[begv < toppos ? sizeof "Top" - 1 : 0], + percent99 (botpos - begv, zv - begv)); return decode_mode_spec_buf; } } @@ -24584,7 +24693,6 @@ init_glyph_string (struct glyph_string *s, s->hdc = hdc; #endif s->display = FRAME_X_DISPLAY (s->f); - s->window = FRAME_X_WINDOW (s->f); s->char2b = char2b; s->hl = hl; s->row = row; @@ -24697,7 +24805,6 @@ get_glyph_face_and_encoding (struct frame *f, struct glyph *glyph, face = FACE_FROM_ID (f, glyph->face_id); /* Make sure X resources of the face are allocated. */ - eassert (face != NULL); prepare_face_for_display (f, face); if (face->font) @@ -25422,7 +25529,7 @@ compute_overhangs_and_x (struct glyph_string *s, int x, bool backward_p) #define BUILD_COMPOSITE_GLYPH_STRING(START, END, HEAD, TAIL, HL, X, LAST_X) \ do { \ int face_id = (row)->glyphs[area][START].face_id; \ - struct face *base_face = FACE_FROM_ID (f, face_id); \ + struct face *base_face = FACE_FROM_ID (f, face_id); \ ptrdiff_t cmp_id = (row)->glyphs[area][START].u.cmp.id; \ struct composition *cmp = composition_table[cmp_id]; \ XChar2b *char2b; \ @@ -25643,7 +25750,7 @@ draw_glyphs (struct window *w, int x, struct glyph_row *row, { struct glyph_string *h, *t; Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); - int mouse_beg_col IF_LINT (= 0), mouse_end_col IF_LINT (= 0); + int mouse_beg_col UNINIT, mouse_end_col UNINIT; bool check_mouse_face = false; int dummy_x = 0; @@ -26045,7 +26152,6 @@ produce_image_glyph (struct it *it) eassert (it->what == IT_IMAGE); face = FACE_FROM_ID (it->f, it->face_id); - eassert (face); /* Make sure X resources of the face is loaded. */ prepare_face_for_display (it->f, face); @@ -26060,7 +26166,6 @@ produce_image_glyph (struct it *it) } img = IMAGE_FROM_ID (it->f, it->image_id); - eassert (img); /* Make sure X resources of the image is loaded. */ prepare_image_for_display (it->f, img); @@ -26216,7 +26321,6 @@ produce_xwidget_glyph (struct it *it) eassert (it->what == IT_XWIDGET); struct face *face = FACE_FROM_ID (it->f, it->face_id); - eassert (face); /* Make sure X resources of the face is loaded. */ prepare_face_for_display (it->f, face); @@ -26742,12 +26846,8 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font, struct face *face; face_id = lookup_named_face (it->f, face_name, false); - if (face_id < 0) - return make_number (-1); - - face = FACE_FROM_ID (it->f, face_id); - font = face->font; - if (font == NULL) + face = FACE_FROM_ID_OR_NULL (it->f, face_id); + if (face == NULL || ((font = face->font) == NULL)) return make_number (-1); boff = font->baseline_offset; if (font->vertical_centering) @@ -26897,7 +26997,7 @@ produce_glyphless_glyph (struct it *it, bool for_no_font, Lisp_Object acronym) } else if (it->glyphless_method == GLYPHLESS_DISPLAY_EMPTY_BOX) { - width = CHAR_WIDTH (it->c); + width = CHARACTER_WIDTH (it->c); if (width == 0) width = 1; else if (width > 4) @@ -27393,18 +27493,21 @@ x_produce_glyphs (struct it *it) int leftmost, rightmost, lowest, highest; int lbearing, rbearing; int i, width, ascent, descent; - int c IF_LINT (= 0); /* cmp->glyph_len can't be zero; see Bug#8512 */ + int c; XChar2b char2b; struct font_metrics *pcm; ptrdiff_t pos; - for (glyph_len = cmp->glyph_len; glyph_len > 0; glyph_len--) - if ((c = COMPOSITION_GLYPH (cmp, glyph_len - 1)) != '\t') - break; + eassume (0 < glyph_len); /* See Bug#8512. */ + do + c = COMPOSITION_GLYPH (cmp, glyph_len - 1); + while (c == '\t' && 0 < --glyph_len); + bool right_padded = glyph_len < cmp->glyph_len; for (i = 0; i < glyph_len; i++) { - if ((c = COMPOSITION_GLYPH (cmp, i)) != '\t') + c = COMPOSITION_GLYPH (cmp, i); + if (c != '\t') break; cmp->offsets[i * 2] = cmp->offsets[i * 2 + 1] = 0; } @@ -28103,7 +28206,7 @@ get_window_cursor_type (struct window *w, struct glyph *glyph, int *width, /* Using a block cursor on large images can be very annoying. So use a hollow cursor for "large" images. If image is not transparent (no mask), also use hollow cursor. */ - struct image *img = IMAGE_FROM_ID (f, glyph->u.img_id); + struct image *img = IMAGE_OPT_FROM_ID (f, glyph->u.img_id); if (img != NULL && IMAGEP (img->spec)) { /* Arbitrarily, interpret "Large" as >32x32 and >NxN @@ -28727,12 +28830,12 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw) } } -#ifdef HAVE_WINDOW_SYSTEM /* When we've written over the cursor, arrange for it to be displayed again. */ if (FRAME_WINDOW_P (f) && phys_cursor_on_p && !w->phys_cursor_on_p) { +#ifdef HAVE_WINDOW_SYSTEM int hpos = w->phys_cursor.hpos; /* When the window is hscrolled, cursor hpos can legitimately be @@ -28747,8 +28850,8 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw) display_and_set_cursor (w, true, hpos, w->phys_cursor.vpos, w->phys_cursor.x, w->phys_cursor.y); unblock_input (); - } #endif /* HAVE_WINDOW_SYSTEM */ + } } #ifdef HAVE_WINDOW_SYSTEM @@ -29688,12 +29791,17 @@ Returns the alist element for the first matching AREA in MAP. */) clip_to_bounds (INT_MIN, XINT (x), INT_MAX), clip_to_bounds (INT_MIN, XINT (y), INT_MAX)); } +#endif /* HAVE_WINDOW_SYSTEM */ /* Display frame CURSOR, optionally using shape defined by POINTER. */ static void define_frame_cursor1 (struct frame *f, Cursor cursor, Lisp_Object pointer) { +#ifdef HAVE_WINDOW_SYSTEM + if (!FRAME_WINDOW_P (f)) + return; + /* Do not change cursor shape while dragging mouse. */ if (EQ (do_mouse_tracking, Qdragging)) return; @@ -29710,10 +29818,10 @@ define_frame_cursor1 (struct frame *f, Cursor cursor, Lisp_Object pointer) cursor = FRAME_X_OUTPUT (f)->horizontal_drag_cursor; else if (EQ (pointer, intern ("nhdrag"))) cursor = FRAME_X_OUTPUT (f)->vertical_drag_cursor; -#ifdef HAVE_X_WINDOWS +# ifdef HAVE_X_WINDOWS else if (EQ (pointer, intern ("vdrag"))) cursor = FRAME_DISPLAY_INFO (f)->vertical_scroll_bar_cursor; -#endif +# endif else if (EQ (pointer, intern ("hourglass"))) cursor = FRAME_X_OUTPUT (f)->hourglass_cursor; else if (EQ (pointer, Qmodeline)) @@ -29724,10 +29832,9 @@ define_frame_cursor1 (struct frame *f, Cursor cursor, Lisp_Object pointer) if (cursor != No_Cursor) FRAME_RIF (f)->define_frame_cursor (f, cursor); +#endif } -#endif /* HAVE_WINDOW_SYSTEM */ - /* Take proper action when mouse has moved to the mode or header line or marginal area AREA of window W, x-position X and y-position Y. X is relative to the start of the text display area of W, so the @@ -29749,12 +29856,11 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, int dx, dy, width, height; ptrdiff_t charpos; Lisp_Object string, object = Qnil; - Lisp_Object pos IF_LINT (= Qnil), help; - + Lisp_Object pos UNINIT; Lisp_Object mouse_face; int original_x_pixel = x; struct glyph * glyph = NULL, * row_start_glyph = NULL; - struct glyph_row *row IF_LINT (= 0); + struct glyph_row *row UNINIT; if (area == ON_MODE_LINE || area == ON_HEADER_LINE) { @@ -29794,7 +29900,7 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, &object, &dx, &dy, &width, &height); } - help = Qnil; + Lisp_Object help = Qnil; #ifdef HAVE_WINDOW_SYSTEM if (IMAGEP (object)) @@ -30042,10 +30148,7 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, if ((area == ON_MODE_LINE || area == ON_HEADER_LINE) && !mouse_face_shown) clear_mouse_face (hlinfo); -#ifdef HAVE_WINDOW_SYSTEM - if (FRAME_WINDOW_P (f)) - define_frame_cursor1 (f, cursor, pointer); -#endif + define_frame_cursor1 (f, cursor, pointer); } @@ -30189,7 +30292,7 @@ note_mouse_highlight (struct frame *f, int x, int y) /* Look for :pointer property on image. */ if (glyph != NULL && glyph->type == IMAGE_GLYPH) { - struct image *img = IMAGE_FROM_ID (f, glyph->u.img_id); + struct image *img = IMAGE_OPT_FROM_ID (f, glyph->u.img_id); if (img != NULL && IMAGEP (img->spec)) { Lisp_Object image_map, hotspot; @@ -30250,15 +30353,15 @@ note_mouse_highlight (struct frame *f, int x, int y) { if (clear_mouse_face (hlinfo)) cursor = No_Cursor; -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (f) && NILP (pointer)) { +#ifdef HAVE_WINDOW_SYSTEM if (area != TEXT_AREA) cursor = FRAME_X_OUTPUT (f)->nontext_cursor; else pointer = Vvoid_text_area_pointer; - } #endif + } goto set_cursor; } @@ -30369,8 +30472,8 @@ note_mouse_highlight (struct frame *f, int x, int y) { /* The mouse-highlighting, if any, comes from an overlay or text property in the buffer. */ - Lisp_Object buffer IF_LINT (= Qnil); - Lisp_Object disp_string IF_LINT (= Qnil); + Lisp_Object buffer UNINIT; + Lisp_Object disp_string UNINIT; if (STRINGP (object)) { @@ -30570,15 +30673,7 @@ note_mouse_highlight (struct frame *f, int x, int y) } set_cursor: - -#ifdef HAVE_WINDOW_SYSTEM - if (FRAME_WINDOW_P (f)) - define_frame_cursor1 (f, cursor, pointer); -#else - /* This is here to prevent a compiler error, about "label at end of - compound statement". */ - return; -#endif + define_frame_cursor1 (f, cursor, pointer); } @@ -31215,7 +31310,7 @@ syms_of_xdisp (void) /* Non-nil means don't actually do any redisplay. */ DEFSYM (Qinhibit_redisplay, "inhibit-redisplay"); - DEFSYM (Qredisplay_internal, "redisplay_internal (C function)"); + DEFSYM (Qredisplay_internal_xC_functionx, "redisplay_internal (C function)"); DEFVAR_BOOL("inhibit-message", inhibit_message, doc: /* Non-nil means calls to `message' are not displayed. @@ -31229,6 +31324,7 @@ They are still logged to the *Messages* buffer. */); message_dolog_marker3 = Fmake_marker (); staticpro (&message_dolog_marker3); + defsubr (&Sset_buffer_redisplay); #ifdef GLYPH_DEBUG defsubr (&Sdump_frame_glyph_matrix); defsubr (&Sdump_glyph_matrix); @@ -31286,8 +31382,10 @@ They are still logged to the *Messages* buffer. */); /* Name and number of the face used to highlight escape glyphs. */ DEFSYM (Qescape_glyph, "escape-glyph"); - /* Name and number of the face used to highlight non-breaking spaces. */ + /* Name and number of the face used to highlight non-breaking + spaces/hyphens. */ DEFSYM (Qnobreak_space, "nobreak-space"); + DEFSYM (Qnobreak_hyphen, "nobreak-hyphen"); /* The symbol 'image' which is the car of the lists used to represent images in Lisp. Also a tool bar style. */ @@ -31399,7 +31497,7 @@ The face used for trailing whitespace is `trailing-whitespace'. */); doc: /* Control highlighting of non-ASCII space and hyphen chars. If the value is t, Emacs highlights non-ASCII chars which have the same appearance as an ASCII space or hyphen, using the `nobreak-space' -or `escape-glyph' face respectively. +or `nobreak-hyphen' face respectively. U+00A0 (no-break space), U+00AD (soft hyphen), U+2010 (hyphen), and U+2011 (non-breaking hyphen) are affected. @@ -31552,16 +31650,6 @@ If nil, disable message logging. If t, log messages but don't truncate the buffer when it becomes large. */); Vmessage_log_max = make_number (1000); - DEFVAR_LISP ("window-size-change-functions", Vwindow_size_change_functions, - doc: /* Functions called during redisplay, if window sizes have changed. -The value should be a list of functions that take one argument. -During the first part of redisplay, for each frame, if any of its windows -have changed size since the last redisplay, or have been split or deleted, -all the functions in the list are called, with the frame as argument. -If redisplay decides to resize the minibuffer window, it calls these -functions on behalf of that as well. */); - Vwindow_size_change_functions = Qnil; - DEFVAR_LISP ("window-scroll-functions", Vwindow_scroll_functions, doc: /* List of functions to call before redisplaying a window with scrolling. Each function is called with two arguments, the window and its new @@ -31906,10 +31994,6 @@ display table takes effect; in this case, Emacs does not consult doc: /* */); Vredisplay__mode_lines_cause = Fmake_hash_table (0, NULL); - DEFVAR_LISP ("redisplay--variables", Vredisplay__variables, - doc: /* A hash-table of variables changing which triggers a thorough redisplay. */); - Vredisplay__variables = Qnil; - DEFVAR_BOOL ("redisplay--inhibit-bidi", redisplay__inhibit_bidi, doc: /* Non-nil means it is not safe to attempt bidi reordering for display. */); /* Initialize to t, since we need to disable reordering until diff --git a/src/xfaces.c b/src/xfaces.c index 5077cb2d944..accb98bf4c7 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -200,6 +200,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ used to fill in unspecified attributes of the default face. */ #include <config.h> +#include <stdlib.h> #include "sysstdio.h" #include <sys/types.h> #include <sys/stat.h> @@ -221,7 +222,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include TERM_HEADER #include "fontset.h" #ifdef HAVE_NTGUI -#define x_display_info w32_display_info #define GCGraphicsExposures 0 #endif /* HAVE_NTGUI */ @@ -495,7 +495,7 @@ x_create_gc (struct frame *f, unsigned long mask, XGCValues *xgcv) { GC gc; block_input (); - gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), mask, xgcv); + gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), mask, xgcv); unblock_input (); IF_DEBUG (++ngcs); return gc; @@ -738,8 +738,7 @@ the pixmap. Bits are stored row by row, each row occupies && RANGED_INTEGERP (1, width, INT_MAX) && RANGED_INTEGERP (1, height, INT_MAX)) { - int bytes_per_row = ((XINT (width) + BITS_PER_CHAR - 1) - / BITS_PER_CHAR); + int bytes_per_row = (XINT (width) + CHAR_BIT - 1) / CHAR_BIT; if (XINT (height) <= SBYTES (data) / bytes_per_row) pixmap_p = true; } @@ -1520,7 +1519,7 @@ the WIDTH times as wide as FACE on FRAME. */) Lisp_Object maximum, Lisp_Object width) { struct frame *f; - int size, avgwidth IF_LINT (= 0); + int size, avgwidth; check_window_system (NULL); CHECK_STRING (pattern); @@ -1553,9 +1552,7 @@ the WIDTH times as wide as FACE on FRAME. */) /* This is of limited utility since it works with character widths. Keep it for compatibility. --gerd. */ int face_id = lookup_named_face (f, face, false); - struct face *width_face = (face_id < 0 - ? NULL - : FACE_FROM_ID (f, face_id)); + struct face *width_face = FACE_FROM_ID_OR_NULL (f, face_id); if (width_face && width_face->font) { @@ -3695,7 +3692,7 @@ Default face attributes override any local face attributes. */) if (EQ (face, Qdefault)) { struct face_cache *c = FRAME_FACE_CACHE (f); - struct face *newface, *oldface = FACE_FROM_ID (f, DEFAULT_FACE_ID); + struct face *newface, *oldface = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); Lisp_Object attrs[LFACE_VECTOR_SIZE]; /* This can be NULL (e.g., in batch mode). */ @@ -3778,7 +3775,7 @@ return the font name used for CHARACTER. */) { struct frame *f = decode_live_frame (frame); int face_id = lookup_named_face (f, face, true); - struct face *fface = FACE_FROM_ID (f, face_id); + struct face *fface = FACE_FROM_ID_OR_NULL (f, face_id); if (! fface) return Qnil; @@ -3787,9 +3784,9 @@ return the font name used for CHARACTER. */) { CHECK_CHARACTER (character); face_id = FACE_FOR_CHAR (f, fface, XINT (character), -1, Qnil); - fface = FACE_FROM_ID (f, face_id); + fface = FACE_FROM_ID_OR_NULL (f, face_id); } - return (fface->font + return ((fface && fface->font) ? fface->font->props[FONT_NAME_INDEX] : Qnil); #else /* !HAVE_WINDOW_SYSTEM */ @@ -4377,7 +4374,7 @@ lookup_face (struct frame *f, Lisp_Object *attr) face = realize_face (cache, attr, -1); #ifdef GLYPH_DEBUG - eassert (face == FACE_FROM_ID (f, face->id)); + eassert (face == FACE_FROM_ID_OR_NULL (f, face->id)); #endif /* GLYPH_DEBUG */ return face->id; @@ -4430,15 +4427,13 @@ lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p) { Lisp_Object attrs[LFACE_VECTOR_SIZE]; Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE]; - struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); + struct face *default_face = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); if (default_face == NULL) { if (!realize_basic_faces (f)) return -1; default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); - if (default_face == NULL) - emacs_abort (); /* realize_basic_faces must have set it up */ } if (! get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0)) @@ -4599,14 +4594,12 @@ lookup_derived_face (struct frame *f, Lisp_Object symbol, int face_id, { Lisp_Object attrs[LFACE_VECTOR_SIZE]; Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE]; - struct face *default_face = FACE_FROM_ID (f, face_id); - - if (!default_face) - emacs_abort (); + struct face *default_face; if (!get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0)) return -1; + default_face = FACE_FROM_ID (f, face_id); memcpy (attrs, default_face->lface, sizeof attrs); merge_face_vectors (f, symbol_attrs, attrs, 0); return lookup_face (f, attrs); @@ -4707,7 +4700,7 @@ x_supports_face_attributes_p (struct frame *f, merge_face_vectors (f, attrs, merged_attrs, 0); face_id = lookup_face (f, merged_attrs); - face = FACE_FROM_ID (f, face_id); + face = FACE_FROM_ID_OR_NULL (f, face_id); if (! face) error ("Cannot make face"); @@ -4977,14 +4970,12 @@ face for italic. */) attrs[i] = Qunspecified; merge_face_ref (f, attributes, attrs, true, 0); - def_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); + def_face = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); if (def_face == NULL) { if (! realize_basic_faces (f)) error ("Cannot realize default face"); def_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); - if (def_face == NULL) - emacs_abort (); /* realize_basic_faces must have set it up */ } /* Dispatch to the appropriate handler. */ @@ -5206,7 +5197,6 @@ realize_default_face (struct frame *f) struct face_cache *c = FRAME_FACE_CACHE (f); Lisp_Object lface; Lisp_Object attrs[LFACE_VECTOR_SIZE]; - struct face *face; /* If the `default' face is not yet known, create it. */ lface = lface_from_face_name (f, Qdefault, false); @@ -5296,10 +5286,11 @@ realize_default_face (struct frame *f) eassert (lface_fully_specified_p (XVECTOR (lface)->contents)); check_lface (lface); memcpy (attrs, XVECTOR (lface)->contents, sizeof attrs); - face = realize_face (c, attrs, DEFAULT_FACE_ID); + struct face *face = realize_face (c, attrs, DEFAULT_FACE_ID); -#ifdef HAVE_WINDOW_SYSTEM -#ifdef HAVE_X_WINDOWS +#ifndef HAVE_WINDOW_SYSTEM + (void) face; +#else if (FRAME_X_P (f) && face->font != FRAME_FONT (f)) { /* This can happen when making a frame on a display that does @@ -5313,8 +5304,7 @@ realize_default_face (struct frame *f) font. */ x_set_font (f, LFACE_FONT (lface), Qnil); } -#endif /* HAVE_X_WINDOWS */ -#endif /* HAVE_WINDOW_SYSTEM */ +#endif return true; } @@ -5454,7 +5444,7 @@ realize_x_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE]) /* Determine the font to use. Most of the time, the font will be the same as the font of the default face, so try that first. */ - default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); + default_face = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); if (default_face && lface_same_font_attributes_p (default_face->lface, attrs)) { @@ -6094,7 +6084,6 @@ face_at_string_position (struct window *w, Lisp_Object string, *endptr = -1; base_face = FACE_FROM_ID (f, base_face_id); - eassert (base_face); /* Optimize the default case that there is no face property. */ if (NILP (prop) @@ -6103,7 +6092,7 @@ face_at_string_position (struct window *w, Lisp_Object string, if we don't have fonts, so we can stop here if not working on a window-system frame. */ || !FRAME_WINDOW_P (f) - || FACE_SUITABLE_FOR_ASCII_CHAR_P (base_face, 0))) + || FACE_SUITABLE_FOR_ASCII_CHAR_P (base_face))) return base_face->id; /* Begin with attributes from the base face. */ @@ -6141,7 +6130,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id, Lisp_Object attrs[LFACE_VECTOR_SIZE]; struct face *base_face; - base_face = FACE_FROM_ID (f, base_face_id); + base_face = FACE_FROM_ID_OR_NULL (f, base_face_id); if (!base_face) return base_face_id; @@ -6169,7 +6158,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id, struct face *face; if (face_id < 0) return base_face_id; - face = FACE_FROM_ID (f, face_id); + face = FACE_FROM_ID_OR_NULL (f, face_id); if (!face) return base_face_id; merge_face_vectors (f, face->lface, attrs, 0); @@ -6289,7 +6278,7 @@ DEFUN ("dump-face", Fdump_face, Sdump_face, 0, 1, 0, doc: /* */) { struct face *face; CHECK_NUMBER (n); - face = FACE_FROM_ID (SELECTED_FRAME (), XINT (n)); + face = FACE_FROM_ID_OR_NULL (SELECTED_FRAME (), XINT (n)); if (face == NULL) error ("Not a valid face"); dump_realized_face (face); diff --git a/src/xfns.c b/src/xfns.c index 7c1bb1c2819..3438c8ef5b4 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -19,6 +19,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include <math.h> #include <unistd.h> @@ -52,6 +53,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "gtkutil.h" #endif +#ifdef HAVE_XDBE +#include <X11/extensions/Xdbe.h> +#endif + #ifdef USE_X_TOOLKIT #include <X11/Shell.h> @@ -91,11 +96,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "../lwlib/xlwmenu.h" #endif -#if !defined (NO_EDITRES) -#define HACK_EDITRES -extern void _XEditResCheckMessages (Widget, XtPointer, XEvent *, Boolean *); -#endif /* not defined NO_EDITRES */ - /* Unique id counter for widgets created by the Lucid Widget Library. */ extern LWLIB_ID widget_id_tick; @@ -118,6 +118,7 @@ static int dpyinfo_refcount; #endif static struct x_display_info *x_display_info_for_name (Lisp_Object); +static void set_up_x_back_buffer (struct frame *f); /* Let the user specify an X display with a Lisp object. OBJECT may be nil, a frame or a terminal object. @@ -705,6 +706,35 @@ x_set_tool_bar_position (struct frame *f, wrong_choice (choice, new_value); } +static void +x_set_inhibit_double_buffering (struct frame *f, + Lisp_Object new_value, + Lisp_Object old_value) +{ + block_input (); + if (FRAME_X_WINDOW (f) && !EQ (new_value, old_value)) + { + bool want_double_buffering = NILP (new_value); + bool was_double_buffered = FRAME_X_DOUBLE_BUFFERED_P (f); + /* font_drop_xrender_surfaces in xftfont does something only if + we're double-buffered, so call font_drop_xrender_surfaces before + and after any potential change. One of the calls will end up + being a no-op. */ + if (want_double_buffering != was_double_buffered) + font_drop_xrender_surfaces (f); + if (FRAME_X_DOUBLE_BUFFERED_P (f) && !want_double_buffering) + tear_down_x_back_buffer (f); + else if (!FRAME_X_DOUBLE_BUFFERED_P (f) && want_double_buffering) + set_up_x_back_buffer (f); + if (FRAME_X_DOUBLE_BUFFERED_P (f) != was_double_buffered) + { + SET_FRAME_GARBAGED (f); + font_drop_xrender_surfaces (f); + } + } + unblock_input (); +} + #ifdef USE_GTK /* Set icon from FILE for frame F. By using GTK functions the icon @@ -1313,7 +1343,6 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) } #endif /* not USE_X_TOOLKIT && not USE_GTK */ adjust_frame_glyphs (f); - run_window_configuration_change_hook (f); } @@ -1435,7 +1464,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { - FRAME_INTERNAL_BORDER_WIDTH (f) = border; + f->internal_border_width = border; #ifdef USE_X_TOOLKIT if (FRAME_X_OUTPUT (f)->edit_widget) @@ -2488,6 +2517,72 @@ xic_set_xfontset (struct frame *f, const char *base_fontname) + +void +x_mark_frame_dirty (struct frame *f) +{ + if (FRAME_X_DOUBLE_BUFFERED_P (f) && !FRAME_X_NEED_BUFFER_FLIP (f)) + FRAME_X_NEED_BUFFER_FLIP (f) = true; +} + +static void +set_up_x_back_buffer (struct frame *f) +{ +#ifdef HAVE_XDBE + block_input (); + if (FRAME_X_WINDOW (f) && !FRAME_X_DOUBLE_BUFFERED_P (f)) + { + FRAME_X_RAW_DRAWABLE (f) = FRAME_X_WINDOW (f); + if (FRAME_DISPLAY_INFO (f)->supports_xdbe) + { + /* If allocating a back buffer fails, either because the + server ran out of memory or we don't have the right kind + of visual, just use single-buffered rendering. */ + x_catch_errors (FRAME_X_DISPLAY (f)); + FRAME_X_RAW_DRAWABLE (f) = XdbeAllocateBackBufferName ( + FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + XdbeCopied); + if (x_had_errors_p (FRAME_X_DISPLAY (f))) + FRAME_X_RAW_DRAWABLE (f) = FRAME_X_WINDOW (f); + x_uncatch_errors_after_check (); + } + } + unblock_input (); +#endif +} + +void +tear_down_x_back_buffer (struct frame *f) +{ +#ifdef HAVE_XDBE + block_input (); + if (FRAME_X_WINDOW (f) && FRAME_X_DOUBLE_BUFFERED_P (f)) + { + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + { + XdbeDeallocateBackBufferName (FRAME_X_DISPLAY (f), + FRAME_X_DRAWABLE (f)); + FRAME_X_RAW_DRAWABLE (f) = FRAME_X_WINDOW (f); + } + } + unblock_input (); +#endif +} + +/* Set up double buffering if the frame parameters don't prohibit + it. */ +void +initial_set_up_x_back_buffer (struct frame *f) +{ + block_input (); + eassert (FRAME_X_WINDOW (f)); + FRAME_X_RAW_DRAWABLE (f) = FRAME_X_WINDOW (f); + if (NILP (CDR (Fassq (Qinhibit_double_buffering, f->param_alist)))) + set_up_x_back_buffer (f); + unblock_input (); +} + #ifdef USE_X_TOOLKIT /* Create and set up the X widget for frame F. */ @@ -2643,7 +2738,7 @@ x_window (struct frame *f, long window_prompting) f->output_data.x->parent_desc, 0, 0); FRAME_X_WINDOW (f) = XtWindow (frame_widget); - + initial_set_up_x_back_buffer (f); validate_x_resource_name (); class_hints.res_name = SSDATA (Vx_resource_name); @@ -2663,7 +2758,7 @@ x_window (struct frame *f, long window_prompting) hack_wm_protocols (f, shell_widget); -#ifdef HACK_EDITRES +#ifdef X_TOOLKIT_EDITRES XtAddEventHandler (shell_widget, 0, True, _XEditResCheckMessages, 0); #endif @@ -2789,7 +2884,8 @@ x_window (struct frame *f) CopyFromParent, /* depth */ InputOutput, /* class */ FRAME_X_VISUAL (f), - attribute_mask, &attributes); + attribute_mask, &attributes); + initial_set_up_x_back_buffer (f); #ifdef HAVE_X_I18N if (use_xim) @@ -2943,7 +3039,7 @@ x_make_gc (struct frame *f) gc_values.line_width = 0; /* Means 1 using fast algorithm. */ f->output_data.x->normal_gc = XCreateGC (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), + FRAME_X_DRAWABLE (f), GCLineWidth | GCForeground | GCBackground, &gc_values); @@ -2952,7 +3048,7 @@ x_make_gc (struct frame *f) gc_values.background = FRAME_FOREGROUND_PIXEL (f); f->output_data.x->reverse_gc = XCreateGC (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), + FRAME_X_DRAWABLE (f), GCForeground | GCBackground | GCLineWidth, &gc_values); @@ -2961,7 +3057,7 @@ x_make_gc (struct frame *f) gc_values.background = f->output_data.x->cursor_pixel; gc_values.fill_style = FillOpaqueStippled; f->output_data.x->cursor_gc - = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), (GCForeground | GCBackground | GCFillStyle | GCLineWidth), &gc_values); @@ -3129,7 +3225,7 @@ x_default_font_parameter (struct frame *f, Lisp_Object parms) { /* Remember the explicit font parameter, so we can re-apply it after we've applied the `default' face settings. */ - AUTO_FRAME_ARG (arg, Qfont_param, font_param); + AUTO_FRAME_ARG (arg, Qfont_parameter, font_param); x_set_frame_parameters (f, arg); } @@ -3468,6 +3564,9 @@ This function is an internal primitive--use `make-frame' instead. */) "waitForWM", "WaitForWM", RES_TYPE_BOOLEAN); x_default_parameter (f, parms, Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f), 0, 0, RES_TYPE_SYMBOL); + x_default_parameter (f, parms, Qinhibit_double_buffering, Qnil, + "inhibitDoubleBuffering", "InhibitDoubleBuffering", + RES_TYPE_BOOLEAN); /* Compute the size of the X window. */ window_prompting = x_figure_window_size (f, parms, true, &x_width, &x_height); @@ -4296,8 +4395,8 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) { XRROutputInfo *info = XRRGetOutputInfo (dpy, resources, resources->outputs[i]); - Connection conn = info ? info->connection : RR_Disconnected; - RRCrtc id = info ? info->crtc : None; + if (!info) + continue; if (strcmp (info->name, "default") == 0) { @@ -4308,9 +4407,9 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) return Qnil; } - if (conn != RR_Disconnected && id != None) + if (info->connection != RR_Disconnected && info->crtc != None) { - XRRCrtcInfo *crtc = XRRGetCrtcInfo (dpy, resources, id); + XRRCrtcInfo *crtc = XRRGetCrtcInfo (dpy, resources, info->crtc); struct MonitorInfo *mi = &monitors[i]; XRectangle workarea_r; @@ -4632,7 +4731,9 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute) } #else tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f); - tool_bar_width = tool_bar_height ? native_width : 0; + tool_bar_width = (tool_bar_height + ? native_width - 2 * internal_border_width + : 0); inner_top += tool_bar_height; #endif @@ -5112,11 +5213,18 @@ FRAME. Default is to change on the edit X window. */) } else { + ptrdiff_t elsize; + CHECK_STRING (value); data = SDATA (value); if (INT_MAX < SBYTES (value)) error ("VALUE too long"); - nelements = SBYTES (value); + + /* See comment above about longs and format=32 */ + elsize = element_format == 32 ? sizeof (long) : element_format >> 3; + if (SBYTES (value) % elsize != 0) + error ("VALUE must contain an integral number of octets for FORMAT"); + nelements = SBYTES (value) / elsize; } block_input (); @@ -5216,7 +5324,7 @@ x_window_property_intern (struct frame *f, property and those are indeed in 32 bit quantities if format is 32. */ - if (BITS_PER_LONG > 32 && actual_format == 32) + if (LONG_WIDTH > 32 && actual_format == 32) { unsigned long i; int *idata = (int *) tmp_data; @@ -5227,7 +5335,8 @@ x_window_property_intern (struct frame *f, } if (NILP (vector_ret_p)) - prop_value = make_string ((char *) tmp_data, actual_size); + prop_value = make_string ((char *) tmp_data, + (actual_format >> 3) * actual_size); else prop_value = x_property_data_to_lisp (f, tmp_data, @@ -5314,12 +5423,81 @@ no value of TYPE (always string in the MS Windows case). */) return prop_value; } +DEFUN ("x-window-property-attributes", Fx_window_property_attributes, Sx_window_property_attributes, + 1, 3, 0, + doc: /* Retrieve metadata about window property PROP on FRAME. +If FRAME is nil or omitted, use the selected frame. +If SOURCE is non-nil, get the property on that window instead of from +FRAME. The number 0 denotes the root window. + +Return value is nil if FRAME hasn't a property with name PROP. +Otherwise, the return value is a vector with the following fields: + +0. The property type, as an integer. The symbolic name of + the type can be obtained with `x-get-atom-name'. +1. The format of each element; one of 8, 16, or 32. +2. The length of the property, in number of elements. */) + (Lisp_Object prop, Lisp_Object frame, Lisp_Object source) +{ + struct frame *f = decode_window_system_frame (frame); + Window target_window = FRAME_X_WINDOW (f); + Atom prop_atom; + Lisp_Object prop_attr = Qnil; + Atom actual_type; + int actual_format; + unsigned long actual_size, bytes_remaining; + unsigned char *tmp_data = NULL; + int rc; + + CHECK_STRING (prop); + + if (! NILP (source)) + { + CONS_TO_INTEGER (source, Window, target_window); + if (! target_window) + target_window = FRAME_DISPLAY_INFO (f)->root_window; + } + + block_input (); + + prop_atom = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (prop), False); + rc = XGetWindowProperty (FRAME_X_DISPLAY (f), target_window, + prop_atom, 0, 0, False, AnyPropertyType, + &actual_type, &actual_format, &actual_size, + &bytes_remaining, &tmp_data); + if (rc == Success /* no invalid params */ + && actual_format == 0 /* but prop not found */ + && NILP (source) + && target_window != FRAME_OUTER_WINDOW (f)) + { + /* analogous behavior to x-window-property: if property isn't found + on the frame's inner window and no alternate window id was + provided, try the frame's outer window. */ + target_window = FRAME_OUTER_WINDOW (f); + rc = XGetWindowProperty (FRAME_X_DISPLAY (f), target_window, + prop_atom, 0, 0, False, AnyPropertyType, + &actual_type, &actual_format, &actual_size, + &bytes_remaining, &tmp_data); + } + + if (rc == Success && actual_format != 0) + { + XFree (tmp_data); + + prop_attr = make_uninit_vector (3); + ASET (prop_attr, 0, make_number (actual_type)); + ASET (prop_attr, 1, make_number (actual_format)); + ASET (prop_attr, 2, make_number (bytes_remaining / (actual_format >> 3))); + } + + unblock_input (); + return prop_attr; +} + /*********************************************************************** Tool tips ***********************************************************************/ -static Lisp_Object x_create_tip_frame (struct x_display_info *, - Lisp_Object, Lisp_Object); static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object, Lisp_Object, int, int, int *, int *); @@ -5363,9 +5541,7 @@ unwind_create_tip_frame (Lisp_Object frame) when this happens. */ static Lisp_Object -x_create_tip_frame (struct x_display_info *dpyinfo, - Lisp_Object parms, - Lisp_Object text) +x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) { struct frame *f; Lisp_Object frame; @@ -5373,8 +5549,6 @@ x_create_tip_frame (struct x_display_info *dpyinfo, int width, height; ptrdiff_t count = SPECPDL_INDEX (); bool face_change_before = face_change; - Lisp_Object buffer; - struct buffer *old_buffer; int x_width = 0, x_height = 0; if (!dpyinfo->terminal->name) @@ -5390,23 +5564,9 @@ x_create_tip_frame (struct x_display_info *dpyinfo, error ("Invalid frame name--not a string or nil"); frame = Qnil; - f = make_frame (true); + f = make_frame (false); + f->wants_modeline = false; XSETFRAME (frame, f); - - AUTO_STRING (tip, " *tip*"); - buffer = Fget_buffer_create (tip); - /* Use set_window_buffer instead of Fset_window_buffer (see - discussion of bug#11984, bug#12025, bug#12026). */ - set_window_buffer (FRAME_ROOT_WINDOW (f), buffer, false, false); - old_buffer = current_buffer; - set_buffer_internal_1 (XBUFFER (buffer)); - bset_truncate_lines (current_buffer, Qnil); - specbind (Qinhibit_read_only, Qt); - specbind (Qinhibit_modification_hooks, Qt); - Ferase_buffer (); - Finsert (1, &text); - set_buffer_internal_1 (old_buffer); - record_unwind_protect (unwind_create_tip_frame, frame); f->terminal = dpyinfo->terminal; @@ -5580,7 +5740,8 @@ x_create_tip_frame (struct x_display_info *dpyinfo, /* Border. */ f->border_width, CopyFromParent, InputOutput, CopyFromParent, - mask, &attrs); + mask, &attrs); + initial_set_up_x_back_buffer (f); XChangeProperty (FRAME_X_DISPLAY (f), tip_window, FRAME_DISPLAY_INFO (f)->Xatom_net_window_type, XA_ATOM, 32, PropModeReplace, @@ -5648,8 +5809,6 @@ x_create_tip_frame (struct x_display_info *dpyinfo, { Lisp_Object bg = Fframe_parameter (frame, Qbackground_color); - /* Set tip_frame here, so that */ - tip_frame = frame; call2 (Qface_set_after_frame_default, frame, Qnil); if (!EQ (bg, Fframe_parameter (frame, Qbackground_color))) @@ -5788,6 +5947,85 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object } +/* Hide tooltip. Delete its frame if DELETE is true. */ +static Lisp_Object +x_hide_tip (bool delete) +{ + if (!NILP (tip_timer)) + { + call1 (Qcancel_timer, tip_timer); + tip_timer = Qnil; + } + + + if (NILP (tip_frame) + || (!delete && FRAMEP (tip_frame) + && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) + return Qnil; + else + { + ptrdiff_t count; + Lisp_Object was_open = Qnil; + + count = SPECPDL_INDEX (); + specbind (Qinhibit_redisplay, Qt); + specbind (Qinhibit_quit, Qt); + +#ifdef USE_GTK + { + /* When using system tooltip, tip_frame is the Emacs frame on + which the tip is shown. */ + struct frame *f = XFRAME (tip_frame); + + if (FRAME_LIVE_P (f) && xg_hide_tooltip (f)) + { + tip_frame = Qnil; + was_open = Qt; + } + } +#endif + + if (FRAMEP (tip_frame)) + { + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (XFRAME (tip_frame)); + + was_open = Qt; + +#ifdef USE_LUCID + /* Bloodcurdling hack alert: The Lucid menu bar widget's + redisplay procedure is not called when a tip frame over + menu items is unmapped. Redisplay the menu manually... */ + { + Widget w; + struct frame *f = SELECTED_FRAME (); + if (FRAME_X_P (f) && FRAME_LIVE_P (f)) + { + w = f->output_data.x->menubar_widget; + + if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen) + && w != NULL) + { + block_input (); + xlwmenu_redisplay (w); + unblock_input (); + } + } + } +#endif /* USE_LUCID */ + } + else + tip_frame = Qnil; + + return unbind_to (count, was_open); + } +} + DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, doc: /* Show STRING in a "tooltip" window on frame FRAME. A tooltip window is a small X window displaying a string. @@ -5820,15 +6058,17 @@ A tooltip's maximum size is specified by `x-max-tooltip-size'. Text larger than the specified size is clipped. */) (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) { - struct frame *f; + struct frame *f, *tip_f; struct window *w; int root_x, root_y; struct buffer *old_buffer; struct text_pos pos; - int i, width, height; - bool seen_reversed_p; + int width, height; int old_windows_or_buffers_changed = windows_or_buffers_changed; ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t count_1; + Lisp_Object window, size; + AUTO_STRING (tip, " *tip*"); specbind (Qinhibit_redisplay, Qt); @@ -5877,22 +6117,23 @@ Text larger than the specified size is clipped. */) if (NILP (last_show_tip_args)) last_show_tip_args = Fmake_vector (make_number (3), Qnil); - if (!NILP (tip_frame)) + if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { Lisp_Object last_string = AREF (last_show_tip_args, 0); Lisp_Object last_frame = AREF (last_show_tip_args, 1); Lisp_Object last_parms = AREF (last_show_tip_args, 2); - if (EQ (frame, last_frame) - && !NILP (Fequal (last_string, string)) + if (FRAME_VISIBLE_P (XFRAME (tip_frame)) + && EQ (frame, last_frame) + && !NILP (Fequal_including_properties (last_string, string)) && !NILP (Fequal (last_parms, parms))) { - struct frame *tip_f = XFRAME (tip_frame); - /* Only DX and DY have changed. */ + tip_f = XFRAME (tip_frame); if (!NILP (tip_timer)) { Lisp_Object timer = tip_timer; + tip_timer = Qnil; call1 (Qcancel_timer, timer); } @@ -5903,41 +6144,102 @@ Text larger than the specified size is clipped. */) XMoveWindow (FRAME_X_DISPLAY (tip_f), FRAME_X_WINDOW (tip_f), root_x, root_y); unblock_input (); + goto start_timer; } - } + else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame)) + { + bool delete = false; + Lisp_Object tail, elt, parm, last; + + /* Check if every parameter in PARMS has the same value in + last_parms unless it should be ignored by means of + Vtooltip_reuse_hidden_frame_parameters. This may destruct + last_parms which, however, will be recreated below. */ + for (tail = parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + /* The left, top, right and bottom parameters are handled + by compute_tip_xy so they can be ignored here. */ + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) + && !EQ (parm, Qright) && !EQ (parm, Qbottom)) + { + last = Fassq (parm, last_parms); + if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + else + last_parms = call2 (Qassq_delete_all, parm, last_parms); + } + else + last_parms = call2 (Qassq_delete_all, parm, last_parms); + } - /* Hide a previous tip, if any. */ - Fx_hide_tip (); + /* Now check if every parameter in what is left of last_parms + with a non-nil value has an association in PARMS unless it + should be ignored by means of + Vtooltip_reuse_hidden_frame_parameters. */ + for (tail = last_parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) + && !EQ (parm, Qbottom) && !NILP (Fcdr (elt))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + } + + x_hide_tip (delete); + } + else + x_hide_tip (true); + } + else + x_hide_tip (true); ASET (last_show_tip_args, 0, string); ASET (last_show_tip_args, 1, frame); ASET (last_show_tip_args, 2, parms); - /* Add default values to frame parameters. */ - if (NILP (Fassq (Qname, parms))) - parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms); - if (NILP (Fassq (Qinternal_border_width, parms))) - parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms); - if (NILP (Fassq (Qborder_width, parms))) - parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); - if (NILP (Fassq (Qbottom_divider_width, parms))) - parms = Fcons (Fcons (Qbottom_divider_width, make_number (0)), parms); - if (NILP (Fassq (Qright_divider_width, parms))) - parms = Fcons (Fcons (Qright_divider_width, make_number (0)), parms); - if (NILP (Fassq (Qborder_color, parms))) - parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms); - if (NILP (Fassq (Qbackground_color, parms))) - parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), - parms); - - /* Create a frame for the tooltip, and record it in the global - variable tip_frame. */ - frame = x_create_tip_frame (FRAME_DISPLAY_INFO (f), parms, string); - f = XFRAME (frame); - - /* Set up the frame's root window. */ - w = XWINDOW (FRAME_ROOT_WINDOW (f)); + if (!FRAMEP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame))) + { + /* Add default values to frame parameters. */ + if (NILP (Fassq (Qname, parms))) + parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms); + if (NILP (Fassq (Qinternal_border_width, parms))) + parms = Fcons (Fcons (Qinternal_border_width, make_number (3)), parms); + if (NILP (Fassq (Qborder_width, parms))) + parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); + if (NILP (Fassq (Qborder_color, parms))) + parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms); + if (NILP (Fassq (Qbackground_color, parms))) + parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), + parms); + + /* Create a frame for the tooltip, and record it in the global + variable tip_frame. */ + if (NILP (tip_frame = x_create_tip_frame (FRAME_DISPLAY_INFO (f), parms))) + /* Creating the tip frame failed. */ + return unbind_to (count, Qnil); + } + + tip_f = XFRAME (tip_frame); + window = FRAME_ROOT_WINDOW (tip_f); + set_window_buffer (window, Fget_buffer_create (tip), false, false); + w = XWINDOW (window); + w->pseudo_window_p = true; + + /* Set up the frame's root window. Note: The following code does not + try to size the window or its frame correctly. Its only purpose is + to make the subsequent text size calculations work. The right + sizes should get installed when the toolkit gets back to us. */ w->left_col = 0; w->top_line = 0; w->pixel_left = 0; @@ -5956,130 +6258,47 @@ Text larger than the specified size is clipped. */) w->total_lines = 40; } - w->pixel_width = w->total_cols * FRAME_COLUMN_WIDTH (f); - w->pixel_height = w->total_lines * FRAME_LINE_HEIGHT (f); - - FRAME_TOTAL_COLS (f) = w->total_cols; - adjust_frame_glyphs (f); - w->pseudo_window_p = true; + w->pixel_width = w->total_cols * FRAME_COLUMN_WIDTH (tip_f); + w->pixel_height = w->total_lines * FRAME_LINE_HEIGHT (tip_f); + FRAME_TOTAL_COLS (tip_f) = w->total_cols; + adjust_frame_glyphs (tip_f); - /* Display the tooltip text in a temporary buffer. */ + /* Insert STRING into root window's buffer and fit the frame to the + buffer. */ + count_1 = SPECPDL_INDEX (); old_buffer = current_buffer; - set_buffer_internal_1 (XBUFFER (XWINDOW (FRAME_ROOT_WINDOW (f))->contents)); + set_buffer_internal_1 (XBUFFER (w->contents)); bset_truncate_lines (current_buffer, Qnil); + specbind (Qinhibit_read_only, Qt); + specbind (Qinhibit_modification_hooks, Qt); + specbind (Qinhibit_point_motion_hooks, Qt); + Ferase_buffer (); + Finsert (1, &string); clear_glyph_matrix (w->desired_matrix); clear_glyph_matrix (w->current_matrix); SET_TEXT_POS (pos, BEGV, BEGV_BYTE); - try_window (FRAME_ROOT_WINDOW (f), pos, TRY_WINDOW_IGNORE_FONTS_CHANGE); - - /* Compute width and height of the tooltip. */ - width = height = 0; - seen_reversed_p = false; - for (i = 0; i < w->desired_matrix->nrows; ++i) - { - struct glyph_row *row = &w->desired_matrix->rows[i]; - struct glyph *last; - int row_width; - - /* Stop at the first empty row at the end. */ - if (!row->enabled_p || !MATRIX_ROW_DISPLAYS_TEXT_P (row)) - break; - - /* Let the row go over the full width of the frame. */ - row->full_width_p = true; - - row_width = row->pixel_width; - if (row->used[TEXT_AREA]) - { - /* There's a glyph at the end of rows that is used to place - the cursor there. Don't include the width of this glyph. */ - if (!row->reversed_p) - { - last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1]; - if (NILP (last->object)) - row_width -= last->pixel_width; - } - else - { - /* There could be a stretch glyph at the beginning of R2L - rows that is produced by extend_face_to_end_of_line. - Don't count that glyph. */ - struct glyph *g = row->glyphs[TEXT_AREA]; - - if (g->type == STRETCH_GLYPH && NILP (g->object)) - { - row_width -= g->pixel_width; - seen_reversed_p = true; - } - } - } - - height += row->height; - width = max (width, row_width); - } - - /* If we've seen partial-length R2L rows, we need to re-adjust the - tool-tip frame width and redisplay it again, to avoid over-wide - tips due to the stretch glyph that extends R2L lines to full - width of the frame. */ - if (seen_reversed_p) - { - /* w->total_cols and FRAME_TOTAL_COLS want the width in columns, - not in pixels. */ - w->pixel_width = width; - width /= WINDOW_FRAME_COLUMN_WIDTH (w); - w->total_cols = width; - FRAME_TOTAL_COLS (f) = width; - SET_FRAME_WIDTH (f, width); - adjust_frame_glyphs (f); - clear_glyph_matrix (w->desired_matrix); - clear_glyph_matrix (w->current_matrix); - try_window (FRAME_ROOT_WINDOW (f), pos, 0); - width = height = 0; - /* Recompute width and height of the tooltip. */ - for (i = 0; i < w->desired_matrix->nrows; ++i) - { - struct glyph_row *row = &w->desired_matrix->rows[i]; - struct glyph *last; - int row_width; - - if (!row->enabled_p || !MATRIX_ROW_DISPLAYS_TEXT_P (row)) - break; - row->full_width_p = true; - row_width = row->pixel_width; - if (row->used[TEXT_AREA] && !row->reversed_p) - { - last = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1]; - if (NILP (last->object)) - row_width -= last->pixel_width; - } - - height += row->height; - width = max (width, row_width); - } - } - - /* Add the frame's internal border to the width and height the X - window should have. */ - height += 2 * FRAME_INTERNAL_BORDER_WIDTH (f); - width += 2 * FRAME_INTERNAL_BORDER_WIDTH (f); - - /* Move the tooltip window where the mouse pointer is. Resize and - show it. */ - compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y); - + try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE); + /* Calculate size of tooltip window. */ + size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil, + make_number (w->pixel_height), Qnil); + /* Add the frame's internal border to calculated size. */ + width = XINT (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + height = XINT (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + + /* Calculate position of tooltip frame. */ + compute_tip_xy (tip_f, parms, dx, dy, width, height, &root_x, &root_y); + + /* Show tooltip frame. */ block_input (); - XMoveResizeWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XMoveResizeWindow (FRAME_X_DISPLAY (tip_f), FRAME_X_WINDOW (tip_f), root_x, root_y, width, height); - XMapRaised (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + XMapRaised (FRAME_X_DISPLAY (tip_f), FRAME_X_WINDOW (tip_f)); unblock_input (); - /* Draw into the window. */ w->must_be_updated_p = true; update_single_window (w); - - /* Restore original current buffer. */ set_buffer_internal_1 (old_buffer); + unbind_to (count_1, Qnil); windows_or_buffers_changed = old_windows_or_buffers_changed; start_timer: @@ -6096,65 +6315,17 @@ DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, Value is t if tooltip was open, nil otherwise. */) (void) { - ptrdiff_t count; - Lisp_Object deleted, frame, timer; - - /* Return quickly if nothing to do. */ - if (NILP (tip_timer) && NILP (tip_frame)) - return Qnil; - - frame = tip_frame; - timer = tip_timer; - tip_frame = tip_timer = deleted = Qnil; - - count = SPECPDL_INDEX (); - specbind (Qinhibit_redisplay, Qt); - specbind (Qinhibit_quit, Qt); - - if (!NILP (timer)) - call1 (Qcancel_timer, timer); - -#ifdef USE_GTK - { - /* When using system tooltip, tip_frame is the Emacs frame on which - the tip is shown. */ - struct frame *f = XFRAME (frame); - if (FRAME_LIVE_P (f) && xg_hide_tooltip (f)) - frame = Qnil; - } -#endif - - if (FRAMEP (frame)) - { - delete_frame (frame, Qnil); - deleted = Qt; - -#ifdef USE_LUCID - /* Bloodcurdling hack alert: The Lucid menu bar widget's - redisplay procedure is not called when a tip frame over menu - items is unmapped. Redisplay the menu manually... */ - { - Widget w; - struct frame *f = SELECTED_FRAME (); - if (FRAME_X_P (f) && FRAME_LIVE_P (f)) - { - w = f->output_data.x->menubar_widget; - - if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen) - && w != NULL) - { - block_input (); - xlwmenu_redisplay (w); - unblock_input (); - } - } - } -#endif /* USE_LUCID */ - } - - return unbind_to (count, deleted); + return x_hide_tip (!tooltip_reuse_hidden_frame); } +DEFUN ("x-double-buffered-p", Fx_double_buffered_p, Sx_double_buffered_p, + 0, 1, 0, + doc: /* Return t if FRAME is being double buffered. */) + (Lisp_Object frame) +{ + struct frame *f = decode_live_frame (frame); + return FRAME_X_DOUBLE_BUFFERED_P (f) ? Qt : Qnil; +} /*********************************************************************** @@ -6371,7 +6542,7 @@ value of DIR as in previous invocations; this is standard Windows behavior. */) /* Make "Cancel" equivalent to C-g. */ if (NILP (file)) - Fsignal (Qquit, Qnil); + quit (); decoded_file = DECODE_FILE (file); @@ -6443,7 +6614,7 @@ value of DIR as in previous invocations; this is standard Windows behavior. */) /* Make "Cancel" equivalent to C-g. */ if (NILP (file)) - Fsignal (Qquit, Qnil); + quit (); decoded_file = DECODE_FILE (file); @@ -6483,7 +6654,7 @@ nil, it defaults to the selected frame. */) default_name = xlispstrdup (font_param); else { - font_param = Fframe_parameter (frame, Qfont_param); + font_param = Fframe_parameter (frame, Qfont_parameter); if (STRINGP (font_param)) default_name = xlispstrdup (font_param); } @@ -6494,7 +6665,7 @@ nil, it defaults to the selected frame. */) unblock_input (); if (NILP (font)) - Fsignal (Qquit, Qnil); + quit (); return unbind_to (count, font); } @@ -6807,6 +6978,7 @@ frame_parm_handler x_frame_parm_handlers[] = x_set_alpha, x_set_sticky, x_set_tool_bar_position, + x_set_inhibit_double_buffering, }; void @@ -6815,8 +6987,9 @@ syms_of_xfns (void) DEFSYM (Qundefined_color, "undefined-color"); DEFSYM (Qcompound_text, "compound-text"); DEFSYM (Qcancel_timer, "cancel-timer"); - DEFSYM (Qfont_param, "font-parameter"); + DEFSYM (Qfont_parameter, "font-parameter"); DEFSYM (Qmono, "mono"); + DEFSYM (Qassq_delete_all, "assq-delete-all"); #ifdef USE_CAIRO DEFSYM (Qpdf, "pdf"); @@ -6988,6 +7161,7 @@ When using Gtk+ tooltips, the tooltip face is not used. */); defsubr (&Sx_change_window_property); defsubr (&Sx_delete_window_property); defsubr (&Sx_window_property); + defsubr (&Sx_window_property_attributes); defsubr (&Sxw_display_color_p); defsubr (&Sx_display_grayscale_p); @@ -7021,6 +7195,7 @@ When using Gtk+ tooltips, the tooltip face is not used. */); defsubr (&Sx_show_tip); defsubr (&Sx_hide_tip); + defsubr (&Sx_double_buffered_p); tip_timer = Qnil; staticpro (&tip_timer); tip_frame = Qnil; diff --git a/src/xfont.c b/src/xfont.c index 0ef64bef10e..09ca6282c7f 100644 --- a/src/xfont.c +++ b/src/xfont.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #include <X11/Xlib.h> #include "lisp.h" @@ -112,44 +113,7 @@ xfont_get_pcm (XFontStruct *xfont, XChar2b *char2b) ? NULL : pcm); } -static Lisp_Object xfont_get_cache (struct frame *); -static Lisp_Object xfont_list (struct frame *, Lisp_Object); -static Lisp_Object xfont_match (struct frame *, Lisp_Object); -static Lisp_Object xfont_list_family (struct frame *); -static Lisp_Object xfont_open (struct frame *, Lisp_Object, int); -static void xfont_close (struct font *); -static void xfont_prepare_face (struct frame *, struct face *); -static int xfont_has_char (Lisp_Object, int); -static unsigned xfont_encode_char (struct font *, int); -static void xfont_text_extents (struct font *, unsigned *, int, - struct font_metrics *); -static int xfont_draw (struct glyph_string *, int, int, int, int, bool); -static int xfont_check (struct frame *, struct font *); - -struct font_driver xfont_driver = - { - LISP_INITIALLY_ZERO, /* Qx */ - false, /* case insensitive */ - xfont_get_cache, - xfont_list, - xfont_match, - xfont_list_family, - NULL, - xfont_open, - xfont_close, - xfont_prepare_face, - NULL, - xfont_has_char, - xfont_encode_char, - xfont_text_extents, - xfont_draw, - NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, - xfont_check, - NULL, /* get_variation_glyphs */ - NULL, /* filter_properties */ - }; - -static Lisp_Object +Lisp_Object xfont_get_cache (struct frame *f) { Display_Info *dpyinfo = FRAME_DISPLAY_INFO (f); @@ -635,7 +599,7 @@ xfont_list_family (struct frame *f) char **names; int num_fonts, i; Lisp_Object list; - char *last_family IF_LINT (= 0); + char *last_family UNINIT; int last_len; block_input (); @@ -1056,20 +1020,20 @@ xfont_draw (struct glyph_string *s, int from, int to, int x, int y, { if (s->padding_p) for (i = 0; i < len; i++) - XDrawImageString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawImageString (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x + i, y, str + i, 1); else - XDrawImageString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawImageString (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x, y, str, len); } else { if (s->padding_p) for (i = 0; i < len; i++) - XDrawString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawString (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x + i, y, str + i, 1); else - XDrawString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawString (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x, y, str, len); } unblock_input (); @@ -1082,20 +1046,20 @@ xfont_draw (struct glyph_string *s, int from, int to, int x, int y, { if (s->padding_p) for (i = 0; i < len; i++) - XDrawImageString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawImageString16 (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x + i, y, s->char2b + from + i, 1); else - XDrawImageString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawImageString16 (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x, y, s->char2b + from, len); } else { if (s->padding_p) for (i = 0; i < len; i++) - XDrawString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawString16 (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x + i, y, s->char2b + from + i, 1); else - XDrawString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f), + XDrawString16 (FRAME_X_DISPLAY (s->f), FRAME_X_DRAWABLE (s->f), gc, x, y, s->char2b + from, len); } unblock_input (); @@ -1112,6 +1076,24 @@ xfont_check (struct frame *f, struct font *font) } + +struct font_driver const xfont_driver = + { + .type = LISPSYM_INITIALLY (Qx), + .get_cache = xfont_get_cache, + .list = xfont_list, + .match = xfont_match, + .list_family = xfont_list_family, + .open = xfont_open, + .close = xfont_close, + .prepare_face = xfont_prepare_face, + .has_char = xfont_has_char, + .encode_char = xfont_encode_char, + .text_extents = xfont_text_extents, + .draw = xfont_draw, + .check = xfont_check, + }; + void syms_of_xfont (void) { @@ -1119,6 +1101,5 @@ syms_of_xfont (void) xfont_scripts_cache = CALLN (Fmake_hash_table, QCtest, Qequal); staticpro (&xfont_scratch_props); xfont_scratch_props = Fmake_vector (make_number (8), Qnil); - xfont_driver.type = Qx; register_font_driver (&xfont_driver, NULL); } diff --git a/src/xftfont.c b/src/xftfont.c index 34c6f7d3e42..7f0e3c6ceb5 100644 --- a/src/xftfont.c +++ b/src/xftfont.c @@ -125,15 +125,12 @@ xftfont_get_colors (struct frame *f, struct face *face, GC gc, } } - -struct font_driver xftfont_driver; - static Lisp_Object xftfont_list (struct frame *f, Lisp_Object spec) { - Lisp_Object list = ftfont_driver.list (f, spec), tail; + Lisp_Object list = ftfont_list (f, spec); - for (tail = list; CONSP (tail); tail = XCDR (tail)) + for (Lisp_Object tail = list; CONSP (tail); tail = XCDR (tail)) ASET (XCAR (tail), FONT_TYPE_INDEX, Qxft); return list; } @@ -141,7 +138,7 @@ xftfont_list (struct frame *f, Lisp_Object spec) static Lisp_Object xftfont_match (struct frame *f, Lisp_Object spec) { - Lisp_Object entity = ftfont_driver.match (f, spec); + Lisp_Object entity = ftfont_match (f, spec); if (! NILP (entity)) ASET (entity, FONT_TYPE_INDEX, Qxft); @@ -542,7 +539,7 @@ xftfont_has_char (Lisp_Object font, int c) return (ENCODE_CHAR (cs, c) != CHARSET_INVALID_CODE (cs)); if (FONT_ENTITY_P (font)) - return ftfont_driver.has_char (font, c); + return ftfont_has_char (font, c); xftfont_info = (struct xftfont_info *) XFONT_OBJECT (font); return (XftCharExists (xftfont_info->display, xftfont_info->xftfont, (FcChar32) c) == FcTrue); @@ -586,7 +583,7 @@ xftfont_get_xft_draw (struct frame *f) { block_input (); xft_draw= XftDrawCreate (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), + FRAME_X_DRAWABLE (f), FRAME_X_VISUAL (f), FRAME_X_COLORMAP (f)); unblock_input (); @@ -600,6 +597,8 @@ static int xftfont_draw (struct glyph_string *s, int from, int to, int x, int y, bool with_background) { + block_input (); + struct frame *f = s->f; struct face *face = s->face; struct xftfont_info *xftfont_info = (struct xftfont_info *) s->font; @@ -614,7 +613,6 @@ xftfont_draw (struct glyph_string *s, int from, int to, int x, int y, xftface_info = (struct xftface_info *) face->extra; xftfont_get_colors (f, face, s->gc, xftface_info, &fg, with_background ? &bg : NULL); - block_input (); if (s->num_clips > 0) XftDrawSetClipRectangles (xft_draw, 0, 0, s->clip, s->num_clips); else @@ -652,9 +650,12 @@ xftfont_draw (struct glyph_string *s, int from, int to, int x, int y, x + i, y, code + i, 1); else XftDrawGlyphs (xft_draw, &fg, xftfont_info->xftfont, - x, y, code, len); + x, y, code, len); + /* Need to explicitly mark the frame dirty because we didn't call + FRAME_X_DRAWABLE in order to draw: we cached the drawable in the + XftDraw structure. */ + x_mark_frame_dirty (f); unblock_input (); - return len; } @@ -664,12 +665,9 @@ xftfont_shape (Lisp_Object lgstring) { struct font *font = CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring)); struct xftfont_info *xftfont_info = (struct xftfont_info *) font; - FT_Face ft_face; - Lisp_Object val; - - ft_face = XftLockFace (xftfont_info->xftfont); + FT_Face ft_face = XftLockFace (xftfont_info->xftfont); xftfont_info->ft_size = ft_face->size; - val = ftfont_driver.shape (lgstring); + Lisp_Object val = ftfont_shape (lgstring); XftUnlockFace (xftfont_info->xftfont); return val; } @@ -678,13 +676,10 @@ xftfont_shape (Lisp_Object lgstring) static int xftfont_end_for_frame (struct frame *f) { + block_input (); XftDraw *xft_draw; - /* Don't do anything if display is dead */ - if (FRAME_X_DISPLAY (f) == NULL) return 0; - xft_draw = font_get_frame_data (f, Qxft); - if (xft_draw) { block_input (); @@ -692,9 +687,23 @@ xftfont_end_for_frame (struct frame *f) unblock_input (); font_put_frame_data (f, Qxft, NULL); } + unblock_input (); return 0; } +/* When using X double buffering, the XftDraw structure we build + seems to be useless once a frame is resized, so recreate it on + ConfigureNotify and in some other cases. */ + +static void +xftfont_drop_xrender_surfaces (struct frame *f) +{ + block_input (); + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + xftfont_end_for_frame (f); + unblock_input (); +} + static bool xftfont_cached_font_ok (struct frame *f, Lisp_Object font_object, Lisp_Object entity) @@ -740,6 +749,40 @@ xftfont_cached_font_ok (struct frame *f, Lisp_Object font_object, return ok; } +struct font_driver const xftfont_driver = + { + /* We can't draw a text without device dependent functions. */ + .type = LISPSYM_INITIALLY (Qxft), + .get_cache = xfont_get_cache, + .list = xftfont_list, + .match = xftfont_match, + .list_family = ftfont_list_family, + .open = xftfont_open, + .close = xftfont_close, + .prepare_face = xftfont_prepare_face, + .done_face = xftfont_done_face, + .has_char = xftfont_has_char, + .encode_char = xftfont_encode_char, + .text_extents = xftfont_text_extents, + .draw = xftfont_draw, + .get_bitmap = ftfont_get_bitmap, + .anchor_point = ftfont_anchor_point, +#ifdef HAVE_LIBOTF + .otf_capability = ftfont_otf_capability, +#endif + .end_for_frame = xftfont_end_for_frame, +#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF + .shape = xftfont_shape, +#endif +#ifdef HAVE_OTF_GET_VARIATION_GLYPHS + .get_variation_glyphs = ftfont_variation_glyphs, +#endif + .filter_properties = ftfont_filter_properties, + .cached_font_ok = xftfont_cached_font_ok, + .combining_capability = ftfont_combining_capability, + .drop_xrender_surfaces = xftfont_drop_xrender_surfaces, + }; + void syms_of_xftfont (void) { @@ -759,24 +802,5 @@ This is needed with some fonts to correct vertical overlap of glyphs. */); ascii_printable[0] = 0; - xftfont_driver = ftfont_driver; - xftfont_driver.type = Qxft; - xftfont_driver.get_cache = xfont_driver.get_cache; - xftfont_driver.list = xftfont_list; - xftfont_driver.match = xftfont_match; - xftfont_driver.open = xftfont_open; - xftfont_driver.close = xftfont_close; - xftfont_driver.prepare_face = xftfont_prepare_face; - xftfont_driver.done_face = xftfont_done_face; - xftfont_driver.has_char = xftfont_has_char; - xftfont_driver.encode_char = xftfont_encode_char; - xftfont_driver.text_extents = xftfont_text_extents; - xftfont_driver.draw = xftfont_draw; - xftfont_driver.end_for_frame = xftfont_end_for_frame; - xftfont_driver.cached_font_ok = xftfont_cached_font_ok; -#if defined (HAVE_M17N_FLT) && defined (HAVE_LIBOTF) - xftfont_driver.shape = xftfont_shape; -#endif - register_font_driver (&xftfont_driver, NULL); } diff --git a/src/xgselect.c b/src/xgselect.c index ac88afdd54b..c73ef7ce5f2 100644 --- a/src/xgselect.c +++ b/src/xgselect.c @@ -25,7 +25,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <glib.h> #include <errno.h> -#include <stdbool.h> +#include "lisp.h" #include "blockinput.h" #include "systime.h" @@ -42,11 +42,11 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ int xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, - struct timespec const *timeout, sigset_t const *sigmask) + struct timespec *timeout, sigset_t *sigmask) { fd_set all_rfds, all_wfds; struct timespec tmo; - struct timespec const *tmop = timeout; + struct timespec *tmop = timeout; GMainContext *context; bool have_wfds = wfds != NULL; @@ -55,9 +55,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, int gfds_size = ARRAYELTS (gfds_buf); int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1; bool context_acquired = false; - int i, nfds, tmo_in_millisec; + int i, nfds, tmo_in_millisec, must_free = 0; bool need_to_dispatch; - USE_SAFE_ALLOCA; context = g_main_context_default (); context_acquired = g_main_context_acquire (context); @@ -78,7 +77,11 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, if (gfds_size < n_gfds) { - SAFE_NALLOCA (gfds, sizeof *gfds, n_gfds); + /* Avoid using SAFE_NALLOCA, as that implicitly refers to the + current thread. Using xnmalloc avoids thread-switching + problems here. */ + gfds = xnmalloc (n_gfds, sizeof *gfds); + must_free = 1; gfds_size = n_gfds; n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec, gfds, gfds_size); @@ -99,7 +102,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, } } - SAFE_FREE (); + if (must_free) + xfree (gfds); if (n_gfds >= 0 && tmo_in_millisec >= 0) { @@ -110,9 +114,9 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, } fds_lim = max_fds + 1; - nfds = pselect (fds_lim, &all_rfds, have_wfds ? &all_wfds : NULL, - efds, tmop, sigmask); - + nfds = thread_select (pselect, fds_lim, + &all_rfds, have_wfds ? &all_wfds : NULL, efds, + tmop, sigmask); if (nfds < 0) retval = nfds; else if (nfds > 0) @@ -147,7 +151,7 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, #else need_to_dispatch = true; #endif - if (need_to_dispatch) + if (need_to_dispatch && context_acquired) { int pselect_errno = errno; /* Prevent g_main_dispatch recursion, that would occur without diff --git a/src/xgselect.h b/src/xgselect.h index 4c56633e966..a56694229e5 100644 --- a/src/xgselect.h +++ b/src/xgselect.h @@ -27,7 +27,6 @@ struct timespec; extern int xg_select (int max_fds, fd_set *rfds, fd_set *wfds, fd_set *efds, - struct timespec const *timeout, - sigset_t const *sigmask); + struct timespec *timeout, sigset_t *sigmask); #endif /* XGSELECT_H */ diff --git a/src/xmenu.c b/src/xmenu.c index 9e1a817946a..9ab7bdf971f 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -1649,7 +1649,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, { unblock_input (); /* Make "Cancel" equivalent to C-g. */ - Fsignal (Qquit, Qnil); + quit (); } unblock_input (); @@ -1913,7 +1913,7 @@ x_dialog_show (struct frame *f, Lisp_Object title, } else /* Make "Cancel" equivalent to C-g. */ - Fsignal (Qquit, Qnil); + quit (); return Qnil; } @@ -2304,7 +2304,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, if (!(menuflags & MENU_FOR_CLICK)) { unblock_input (); - Fsignal (Qquit, Qnil); + quit (); } break; } diff --git a/src/xml.c b/src/xml.c index 612b16c4c53..7d61dc7413e 100644 --- a/src/xml.c +++ b/src/xml.c @@ -45,7 +45,7 @@ DEF_DLL_FN (void, xmlCheckVersion, (int)); static bool libxml2_loaded_p (void) { - Lisp_Object found = Fassq (Qlibxml2_dll, Vlibrary_cache); + Lisp_Object found = Fassq (Qlibxml2, Vlibrary_cache); return CONSP (found) && EQ (XCDR (found), Qt); } @@ -96,7 +96,7 @@ init_libxml2_functions (void) { HMODULE library; - if (!(library = w32_delayed_load (Qlibxml2_dll))) + if (!(library = w32_delayed_load (Qlibxml2))) { message1 ("libxml2 library not found"); return false; @@ -105,12 +105,12 @@ init_libxml2_functions (void) if (! load_dll_functions (library)) goto bad_library; - Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qt), Vlibrary_cache); + Vlibrary_cache = Fcons (Fcons (Qlibxml2, Qt), Vlibrary_cache); return true; } bad_library: - Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qnil), Vlibrary_cache); + Vlibrary_cache = Fcons (Fcons (Qlibxml2, Qnil), Vlibrary_cache); return false; #else /* !WINDOWSNT */ diff --git a/src/xselect.c b/src/xselect.c index ff6dc3287cf..b997cc887ef 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -215,7 +215,7 @@ symbol_to_x_atom (struct x_display_info *dpyinfo, Lisp_Object sym) if (EQ (sym, QDELETE)) return dpyinfo->Xatom_DELETE; if (EQ (sym, QMULTIPLE)) return dpyinfo->Xatom_MULTIPLE; if (EQ (sym, QINCR)) return dpyinfo->Xatom_INCR; - if (EQ (sym, QEMACS_TMP)) return dpyinfo->Xatom_EMACS_TMP; + if (EQ (sym, Q_EMACS_TMP_)) return dpyinfo->Xatom_EMACS_TMP; if (EQ (sym, QTARGETS)) return dpyinfo->Xatom_TARGETS; if (EQ (sym, QNULL)) return dpyinfo->Xatom_NULL; if (!SYMBOLP (sym)) emacs_abort (); @@ -273,7 +273,7 @@ x_atom_to_symbol (struct x_display_info *dpyinfo, Atom atom) if (atom == dpyinfo->Xatom_INCR) return QINCR; if (atom == dpyinfo->Xatom_EMACS_TMP) - return QEMACS_TMP; + return Q_EMACS_TMP_; if (atom == dpyinfo->Xatom_TARGETS) return QTARGETS; if (atom == dpyinfo->Xatom_NULL) @@ -1318,7 +1318,7 @@ x_get_window_property (Display *display, Window window, Atom property, data = data1; } - if (BITS_PER_LONG > 32 && *actual_format_ret == 32) + if (LONG_WIDTH > 32 && *actual_format_ret == 32) { unsigned long i; int *idata = (int *) (data + offset); @@ -1613,11 +1613,24 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, /* Convert a single 16-bit number or a small 32-bit number to a Lisp_Int. If the number is 32 bits and won't fit in a Lisp_Int, convert it to a cons of integers, 16 bits in each half. + + INTEGER is a signed type, CARDINAL is unsigned. + Assume any other types are unsigned as well. */ else if (format == 32 && size == sizeof (int)) - return INTEGER_TO_CONS (((int *) data) [0]); + { + if (type == XA_INTEGER) + return INTEGER_TO_CONS (((int *) data) [0]); + else + return INTEGER_TO_CONS (((unsigned int *) data) [0]); + } else if (format == 16 && size == sizeof (short)) - return make_number (((short *) data) [0]); + { + if (type == XA_INTEGER) + return make_number (((short *) data) [0]); + else + return make_number (((unsigned short *) data) [0]); + } /* Convert any other kind of data to a vector of numbers, represented as above (as an integer, or a cons of two 16 bit integers.) @@ -1627,11 +1640,22 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, ptrdiff_t i; Lisp_Object v = make_uninit_vector (size / 2); - for (i = 0; i < size / 2; i++) - { - short j = ((short *) data) [i]; - ASET (v, i, make_number (j)); - } + if (type == XA_INTEGER) + { + for (i = 0; i < size / 2; i++) + { + short j = ((short *) data) [i]; + ASET (v, i, make_number (j)); + } + } + else + { + for (i = 0; i < size / 2; i++) + { + unsigned short j = ((unsigned short *) data) [i]; + ASET (v, i, make_number (j)); + } + } return v; } else @@ -1639,11 +1663,22 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, ptrdiff_t i; Lisp_Object v = make_uninit_vector (size / X_LONG_SIZE); - for (i = 0; i < size / X_LONG_SIZE; i++) - { - int j = ((int *) data) [i]; - ASET (v, i, INTEGER_TO_CONS (j)); - } + if (type == XA_INTEGER) + { + for (i = 0; i < size / X_LONG_SIZE; i++) + { + int j = ((int *) data) [i]; + ASET (v, i, INTEGER_TO_CONS (j)); + } + } + else + { + for (i = 0; i < size / X_LONG_SIZE; i++) + { + unsigned int j = ((unsigned int *) data) [i]; + ASET (v, i, INTEGER_TO_CONS (j)); + } + } return v; } } @@ -2297,13 +2332,13 @@ x_fill_property_data (Display *dpy, Lisp_Object data, void *ret, int format) if (format == 8) { if ((1 << 8) < val && val <= X_ULONG_MAX - (1 << 7)) - error ("Out of 'char' range"); + error ("Out of `char' range"); *d08++ = val; } else if (format == 16) { if ((1 << 16) < val && val <= X_ULONG_MAX - (1 << 15)) - error ("Out of 'short' range"); + error ("Out of `short' range"); *d16++ = val; } else @@ -2439,7 +2474,7 @@ x_handle_dnd_message (struct frame *f, const XClientMessageEvent *event, function expects them to be of size int (i.e. 32). So to be able to use that function, put the data in the form it expects if format is 32. */ - if (BITS_PER_LONG > 32 && event->format == 32) + if (LONG_WIDTH > 32 && event->format == 32) { for (i = 0; i < 5; ++i) /* There are only 5 longs in a ClientMessage. */ idata[i] = event->data.l[i]; @@ -2680,7 +2715,7 @@ A value of 0 means wait as long as necessary. This is initialized from the DEFSYM (QDELETE, "DELETE"); DEFSYM (QMULTIPLE, "MULTIPLE"); DEFSYM (QINCR, "INCR"); - DEFSYM (QEMACS_TMP, "_EMACS_TMP_"); + DEFSYM (Q_EMACS_TMP_, "_EMACS_TMP_"); DEFSYM (QTARGETS, "TARGETS"); DEFSYM (QATOM, "ATOM"); DEFSYM (QCLIPBOARD_MANAGER, "CLIPBOARD_MANAGER"); diff --git a/src/xsmfns.c b/src/xsmfns.c index d54a94df877..95ede642130 100644 --- a/src/xsmfns.c +++ b/src/xsmfns.c @@ -204,7 +204,7 @@ smc_save_yourself_CB (SmcConn smcConn, props[props_idx]->vals[0].value = SDATA (user_login_name); ++props_idx; - char *cwd = get_current_dir_name (); + char *cwd = emacs_get_current_dir_name (); if (cwd) { props[props_idx] = &prop_ptr[props_idx]; @@ -401,7 +401,7 @@ x_session_initialize (struct x_display_info *dpyinfo) ptrdiff_t name_len = 0; /* libSM seems to crash if pwd is missing - see bug#18851. */ - if (! get_current_dir_name ()) + if (! emacs_get_current_dir_name ()) { fprintf (stderr, "Disabling session management due to pwd error: %s\n", emacs_strerror (errno)); diff --git a/src/xterm.c b/src/xterm.c index 213a527d55d..67bd13a042f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <config.h> #include <stdio.h> +#include <stdlib.h> #ifdef USE_CAIRO #include <math.h> #endif @@ -44,6 +45,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <X11/extensions/Xrender.h> #endif +#ifdef HAVE_XDBE +#include <X11/extensions/Xdbe.h> +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -95,10 +100,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #endif #ifdef USE_X_TOOLKIT -#if !defined (NO_EDITRES) -#define HACK_EDITRES -extern void _XEditResCheckMessages (Widget, XtPointer, XEvent *, Boolean *); -#endif /* not NO_EDITRES */ /* Include toolkit specific headers for the scroll bar widget. */ @@ -363,7 +364,7 @@ x_begin_cr_clip (struct frame *f, GC gc) { cairo_surface_t *surface; surface = cairo_xlib_surface_create (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), + FRAME_X_DRAWABLE (f), FRAME_DISPLAY_INFO (f)->visual, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); @@ -725,7 +726,7 @@ x_fill_rectangle (struct frame *f, GC gc, int x, int y, int width, int height) cairo_fill (cr); x_end_cr_clip (f); #else - XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc, x, y, width, height); #endif } @@ -743,7 +744,7 @@ x_draw_rectangle (struct frame *f, GC gc, int x, int y, int width, int height) cairo_stroke (cr); x_end_cr_clip (f); #else - XDrawRectangle (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawRectangle (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc, x, y, width, height); #endif } @@ -759,7 +760,10 @@ x_clear_window (struct frame *f) cairo_paint (cr); x_end_cr_clip (f); #else - XClearWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + x_clear_area (f, 0, 0, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); + else + XClearWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); #endif } @@ -1062,7 +1066,7 @@ x_draw_vertical_window_border (struct window *w, int x, int y0, int y1) struct frame *f = XFRAME (WINDOW_FRAME (w)); struct face *face; - face = FACE_FROM_ID (f, VERTICAL_BORDER_FACE_ID); + face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); if (face) XSetForeground (FRAME_X_DISPLAY (f), f->output_data.x->normal_gc, face->foreground); @@ -1070,7 +1074,7 @@ x_draw_vertical_window_border (struct window *w, int x, int y0, int y1) #ifdef USE_CAIRO x_fill_rectangle (f, f->output_data.x->normal_gc, x, y0, 1, y1 - y0); #else - XDrawLine (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + XDrawLine (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), f->output_data.x->normal_gc, x, y0, x, y1); #endif } @@ -1081,9 +1085,11 @@ static void x_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) { struct frame *f = XFRAME (WINDOW_FRAME (w)); - struct face *face = FACE_FROM_ID (f, WINDOW_DIVIDER_FACE_ID); - struct face *face_first = FACE_FROM_ID (f, WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID); - struct face *face_last = FACE_FROM_ID (f, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); + struct face *face = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FACE_ID); + struct face *face_first + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID); + struct face *face_last + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); unsigned long color = face ? face->foreground : FRAME_FOREGROUND_PIXEL (f); unsigned long color_first = (face_first ? face_first->foreground @@ -1176,6 +1182,41 @@ x_update_window_end (struct window *w, bool cursor_on_p, } } +/* Show the frame back buffer. If frame is double-buffered, + atomically publish to the user's screen graphics updates made since + the last call to show_back_buffer. */ +static void +show_back_buffer (struct frame *f) +{ + block_input (); + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + { +#ifdef HAVE_XDBE + XdbeSwapInfo swap_info; + memset (&swap_info, 0, sizeof (swap_info)); + swap_info.swap_window = FRAME_X_WINDOW (f); + swap_info.swap_action = XdbeCopied; + XdbeSwapBuffers (FRAME_X_DISPLAY (f), &swap_info, 1); +#else + eassert (!"should have back-buffer only with XDBE"); +#endif + } + FRAME_X_NEED_BUFFER_FLIP (f) = false; + unblock_input (); +} + +/* Updates back buffer and flushes changes to display. Called from + minibuf read code. Note that we display the back buffer even if + buffer flipping is blocked. */ +static void +x_flip_and_flush (struct frame *f) +{ + block_input (); + if (FRAME_X_NEED_BUFFER_FLIP (f)) + show_back_buffer (f); + x_flush (f); + unblock_input (); +} /* End update of frame F. This function is installed as a hook in update_end. */ @@ -1208,7 +1249,7 @@ x_update_end (struct frame *f) if (! FRAME_EXTERNAL_MENU_BAR (f)) height += FRAME_MENU_BAR_HEIGHT (f); surface = cairo_xlib_surface_create (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), + FRAME_X_DRAWABLE (f), FRAME_DISPLAY_INFO (f)->visual, width, height); @@ -1221,7 +1262,7 @@ x_update_end (struct frame *f) cairo_destroy (cr); unblock_input (); } -#endif /* USE_CAIRO */ +#endif #ifndef XFlush block_input (); @@ -1230,17 +1271,26 @@ x_update_end (struct frame *f) #endif } - /* This function is called from various places in xdisp.c whenever a complete update has been performed. */ static void XTframe_up_to_date (struct frame *f) { - if (FRAME_X_P (f)) - FRAME_MOUSE_UPDATE (f); + eassert (FRAME_X_P (f)); + block_input (); + FRAME_MOUSE_UPDATE (f); + if (!buffer_flipping_blocked_p () && FRAME_X_NEED_BUFFER_FLIP (f)) + show_back_buffer (f); + unblock_input (); } +static void +XTbuffer_flipping_unblocked_hook (struct frame *f) +{ + if (FRAME_X_NEED_BUFFER_FLIP (f)) + show_back_buffer (f); +} /* Clear under internal border if any (GTK has its own version). */ #ifndef USE_GTK @@ -1355,7 +1405,7 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row, struct draw_fring #else /* not USE_CAIRO */ if (p->which) { - Window window = FRAME_X_WINDOW (f); + Drawable drawable = FRAME_X_DRAWABLE (f); char *bits; Pixmap pixmap, clipmask = (Pixmap) 0; int depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f)); @@ -1368,7 +1418,7 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row, struct draw_fring /* Draw the bitmap. I believe these small pixmaps can be cached by the server. */ - pixmap = XCreatePixmapFromBitmapData (display, window, bits, p->wd, p->h, + pixmap = XCreatePixmapFromBitmapData (display, drawable, bits, p->wd, p->h, (p->cursor_p ? (p->overlay_p ? face->background : f->output_data.x->cursor_pixel) @@ -1387,7 +1437,7 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row, struct draw_fring XChangeGC (display, gc, GCClipMask | GCClipXOrigin | GCClipYOrigin, &gcv); } - XCopyArea (display, pixmap, window, gc, 0, 0, + XCopyArea (display, pixmap, drawable, gc, 0, 0, p->wd, p->h, p->x, p->y); XFreePixmap (display, pixmap); @@ -1488,7 +1538,7 @@ x_set_cursor_gc (struct glyph_string *s) mask, &xgcv); else FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc - = XCreateGC (s->display, s->window, mask, &xgcv); + = XCreateGC (s->display, FRAME_X_DRAWABLE (s->f), mask, &xgcv); s->gc = FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc; } @@ -1505,7 +1555,7 @@ x_set_mouse_face_gc (struct glyph_string *s) /* What face has to be used last for the mouse face? */ face_id = MOUSE_HL_INFO (s->f)->mouse_face_face_id; - face = FACE_FROM_ID (s->f, face_id); + face = FACE_FROM_ID_OR_NULL (s->f, face_id); if (face == NULL) face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); @@ -1535,7 +1585,7 @@ x_set_mouse_face_gc (struct glyph_string *s) mask, &xgcv); else FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc - = XCreateGC (s->display, s->window, mask, &xgcv); + = XCreateGC (s->display, FRAME_X_DRAWABLE (s->f), mask, &xgcv); s->gc = FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc; @@ -2156,6 +2206,7 @@ static const XColor * x_color_cells (Display *dpy, int *ncells) { struct x_display_info *dpyinfo = x_display_info_for_display (dpy); + eassume (dpyinfo); if (dpyinfo->color_cells == NULL) { @@ -2352,17 +2403,19 @@ x_alloc_nearest_color_1 (Display *dpy, Colormap cmap, XColor *color) equal to a cached pixel color recorded earlier, there was a change in the colormap, so clear the color cache. */ struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - XColor *cached_color; + eassume (dpyinfo); - if (dpyinfo->color_cells - && (cached_color = &dpyinfo->color_cells[color->pixel], - (cached_color->red != color->red - || cached_color->blue != color->blue - || cached_color->green != color->green))) + if (dpyinfo->color_cells) { - xfree (dpyinfo->color_cells); - dpyinfo->color_cells = NULL; - dpyinfo->ncolor_cells = 0; + XColor *cached_color = &dpyinfo->color_cells[color->pixel]; + if (cached_color->red != color->red + || cached_color->blue != color->blue + || cached_color->green != color->green) + { + xfree (dpyinfo->color_cells); + dpyinfo->color_cells = NULL; + dpyinfo->ncolor_cells = 0; + } } } @@ -2563,7 +2616,7 @@ x_setup_relief_color (struct frame *f, struct relief *relief, double factor, { xgcv.stipple = dpyinfo->gray; mask |= GCStipple; - relief->gc = XCreateGC (dpy, FRAME_X_WINDOW (f), mask, &xgcv); + relief->gc = XCreateGC (dpy, FRAME_X_DRAWABLE (f), mask, &xgcv); } else XChangeGC (dpy, relief->gc, mask, &xgcv); @@ -2694,7 +2747,7 @@ x_draw_relief_rect (struct frame *f, x_reset_clip_rectangles (f, bottom_right_gc); #else Display *dpy = FRAME_X_DISPLAY (f); - Window window = FRAME_X_WINDOW (f); + Drawable drawable = FRAME_X_DRAWABLE (f); int i; GC gc; @@ -2713,12 +2766,12 @@ x_draw_relief_rect (struct frame *f, if (top_p) { if (width == 1) - XDrawLine (dpy, window, gc, + XDrawLine (dpy, drawable, gc, left_x + left_p, top_y, right_x + !right_p, top_y); for (i = 1; i < width; ++i) - XDrawLine (dpy, window, gc, + XDrawLine (dpy, drawable, gc, left_x + i * left_p, top_y + i, right_x + 1 - i * right_p, top_y + i); } @@ -2727,13 +2780,13 @@ x_draw_relief_rect (struct frame *f, if (left_p) { if (width == 1) - XDrawLine (dpy, window, gc, left_x, top_y + 1, left_x, bottom_y); + XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); - XClearArea (dpy, window, left_x, top_y, 1, 1, False); - XClearArea (dpy, window, left_x, bottom_y, 1, 1, False); + x_clear_area(f, left_x, top_y, 1, 1); + x_clear_area(f, left_x, bottom_y, 1, 1); for (i = (width > 1 ? 1 : 0); i < width; ++i) - XDrawLine (dpy, window, gc, + XDrawLine (dpy, drawable, gc, left_x + i, top_y + (i + 1) * top_p, left_x + i, bottom_y + 1 - (i + 1) * bot_p); } @@ -2749,23 +2802,23 @@ x_draw_relief_rect (struct frame *f, { /* Outermost top line. */ if (top_p) - XDrawLine (dpy, window, gc, + XDrawLine (dpy, drawable, gc, left_x + left_p, top_y, right_x + !right_p, top_y); /* Outermost left line. */ if (left_p) - XDrawLine (dpy, window, gc, left_x, top_y + 1, left_x, bottom_y); + XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); } /* Bottom. */ if (bot_p) { - XDrawLine (dpy, window, gc, + XDrawLine (dpy, drawable, gc, left_x + left_p, bottom_y, right_x + !right_p, bottom_y); for (i = 1; i < width; ++i) - XDrawLine (dpy, window, gc, + XDrawLine (dpy, drawable, gc, left_x + i * left_p, bottom_y - i, right_x + 1 - i * right_p, bottom_y - i); } @@ -2773,10 +2826,10 @@ x_draw_relief_rect (struct frame *f, /* Right. */ if (right_p) { - XClearArea (dpy, window, right_x, top_y, 1, 1, False); - XClearArea (dpy, window, right_x, bottom_y, 1, 1, False); + x_clear_area(f, right_x, top_y, 1, 1); + x_clear_area(f, right_x, bottom_y, 1, 1); for (i = 0; i < width; ++i) - XDrawLine (dpy, window, gc, + XDrawLine (dpy, drawable, gc, right_x - i, top_y + (i + 1) * top_p, right_x - i, bottom_y + 1 - (i + 1) * bot_p); } @@ -2928,7 +2981,8 @@ x_draw_image_foreground (struct glyph_string *s) image_rect.width = s->slice.width; image_rect.height = s->slice.height; if (x_intersect_rectangles (&clip_rect, &image_rect, &r)) - XCopyArea (s->display, s->img->pixmap, s->window, s->gc, + XCopyArea (s->display, s->img->pixmap, + FRAME_X_DRAWABLE (s->f), s->gc, s->slice.x + r.x - x, s->slice.y + r.y - y, r.width, r.height, r.x, r.y); } @@ -2942,7 +2996,8 @@ x_draw_image_foreground (struct glyph_string *s) image_rect.width = s->slice.width; image_rect.height = s->slice.height; if (x_intersect_rectangles (&clip_rect, &image_rect, &r)) - XCopyArea (s->display, s->img->pixmap, s->window, s->gc, + XCopyArea (s->display, s->img->pixmap, + FRAME_X_DRAWABLE (s->f), s->gc, s->slice.x + r.x - x, s->slice.y + r.y - y, r.width, r.height, r.x, r.y); @@ -3182,7 +3237,7 @@ x_draw_image_glyph_string (struct glyph_string *s) int depth = DefaultDepthOfScreen (screen); /* Create a pixmap as large as the glyph string. */ - pixmap = XCreatePixmap (s->display, s->window, + pixmap = XCreatePixmap (s->display, FRAME_X_DRAWABLE (s->f), s->background_width, s->height, depth); @@ -3257,7 +3312,7 @@ x_draw_image_glyph_string (struct glyph_string *s) { x_draw_image_foreground_1 (s, pixmap); x_set_glyph_string_clipping (s); - XCopyArea (s->display, pixmap, s->window, s->gc, + XCopyArea (s->display, pixmap, FRAME_X_DRAWABLE (s->f), s->gc, 0, 0, s->background_width, s->height, s->x, s->y); XFreePixmap (s->display, pixmap); } @@ -3436,7 +3491,7 @@ x_draw_underwave (struct glyph_string *s) while (x1 <= xmax) { - XDrawLine (s->display, s->window, s->gc, x1, y1, x2, y2); + XDrawLine (s->display, FRAME_X_DRAWABLE (s->f), s->gc, x1, y1, x2, y2); x1 = x2, y1 = y2; x2 += dx, y2 = y0 + odd*dy; odd = !odd; @@ -3739,7 +3794,7 @@ x_shift_glyphs_for_insert (struct frame *f, int x, int y, int width, int height, /* Never called on a GUI frame, see http://lists.gnu.org/archive/html/emacs-devel/2015-05/msg00456.html */ - XCopyArea (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), FRAME_X_WINDOW (f), + XCopyArea (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), FRAME_X_DRAWABLE (f), f->output_data.x->normal_gc, x, y, width, height, x + shift_by, y); @@ -3780,8 +3835,14 @@ x_clear_area (struct frame *f, int x, int y, int width, int height) cairo_fill (cr); x_end_cr_clip (f); #else - x_clear_area1 (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - x, y, width, height, False); + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + XFillRectangle (FRAME_X_DISPLAY (f), + FRAME_X_DRAWABLE (f), + f->output_data.x->reverse_gc, + x, y, width, height); + else + x_clear_area1 (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + x, y, width, height, False); #endif } @@ -3797,19 +3858,13 @@ x_clear_frame (struct frame *f) block_input (); + font_drop_xrender_surfaces (f); x_clear_window (f); /* We have to clear the scroll bars. If we have changed colors or something like that, then they should be notified. */ x_scroll_bar_clear (f); -#if defined (USE_GTK) && defined (USE_TOOLKIT_SCROLL_BARS) - /* Make sure scroll bars are redrawn. As they aren't redrawn by - redisplay, do it here. */ - if (FRAME_GTK_WIDGET (f)) - gtk_widget_queue_draw (FRAME_GTK_WIDGET (f)); -#endif - XFlush (FRAME_X_DISPLAY (f)); unblock_input (); @@ -4107,7 +4162,7 @@ x_scroll_run (struct window *w, struct run *run) SET_FRAME_GARBAGED (f); #else XCopyArea (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), FRAME_X_WINDOW (f), + FRAME_X_DRAWABLE (f), FRAME_X_DRAWABLE (f), f->output_data.x->normal_gc, x, from_y, width, height, @@ -4646,12 +4701,15 @@ x_find_modifier_meanings (struct x_display_info *dpyinfo) int x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state) { + int mod_ctrl = ctrl_modifier; int mod_meta = meta_modifier; int mod_alt = alt_modifier; int mod_hyper = hyper_modifier; int mod_super = super_modifier; Lisp_Object tem; + tem = Fget (Vx_ctrl_keysym, Qmodifier_value); + if (INTEGERP (tem)) mod_ctrl = XINT (tem) & INT_MAX; tem = Fget (Vx_alt_keysym, Qmodifier_value); if (INTEGERP (tem)) mod_alt = XINT (tem) & INT_MAX; tem = Fget (Vx_meta_keysym, Qmodifier_value); @@ -4662,7 +4720,7 @@ x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state) if (INTEGERP (tem)) mod_super = XINT (tem) & INT_MAX; return ( ((state & (ShiftMask | dpyinfo->shift_lock_mask)) ? shift_modifier : 0) - | ((state & ControlMask) ? ctrl_modifier : 0) + | ((state & ControlMask) ? mod_ctrl : 0) | ((state & dpyinfo->meta_mod_mask) ? mod_meta : 0) | ((state & dpyinfo->alt_mod_mask) ? mod_alt : 0) | ((state & dpyinfo->super_mod_mask) ? mod_super : 0) @@ -4672,6 +4730,7 @@ x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state) static int x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, EMACS_INT state) { + EMACS_INT mod_ctrl = ctrl_modifier; EMACS_INT mod_meta = meta_modifier; EMACS_INT mod_alt = alt_modifier; EMACS_INT mod_hyper = hyper_modifier; @@ -4679,6 +4738,8 @@ x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, EMACS_INT state) Lisp_Object tem; + tem = Fget (Vx_ctrl_keysym, Qmodifier_value); + if (INTEGERP (tem)) mod_ctrl = XINT (tem); tem = Fget (Vx_alt_keysym, Qmodifier_value); if (INTEGERP (tem)) mod_alt = XINT (tem); tem = Fget (Vx_meta_keysym, Qmodifier_value); @@ -4693,7 +4754,7 @@ x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, EMACS_INT state) | ((state & mod_super) ? dpyinfo->super_mod_mask : 0) | ((state & mod_hyper) ? dpyinfo->hyper_mod_mask : 0) | ((state & shift_modifier) ? ShiftMask : 0) - | ((state & ctrl_modifier) ? ControlMask : 0) + | ((state & mod_ctrl) ? ControlMask : 0) | ((state & mod_meta) ? dpyinfo->meta_mod_mask : 0)); } @@ -5244,9 +5305,8 @@ x_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part, struct window *w = XWINDOW (window); struct frame *f = XFRAME (w->frame); intptr_t iw = (intptr_t) w; - enum { BITS_PER_INTPTR = CHAR_BIT * sizeof iw }; - verify (BITS_PER_INTPTR <= 64); - int sign_shift = BITS_PER_INTPTR - 32; + verify (INTPTR_WIDTH <= 64); + int sign_shift = INTPTR_WIDTH - 32; block_input (); @@ -7447,6 +7507,26 @@ x_net_wm_state (struct frame *f, Window window) /** store_frame_param (f, Qsticky, sticky ? Qt : Qnil); **/ } +/* Flip back buffers on any frames with undrawn content. */ +static void +flush_dirty_back_buffers (void) +{ + block_input (); + Lisp_Object tail, frame; + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + if (FRAME_LIVE_P (f) && + FRAME_X_P (f) && + FRAME_X_WINDOW (f) && + !FRAME_GARBAGED_P (f) && + !buffer_flipping_blocked_p () && + FRAME_X_NEED_BUFFER_FLIP (f)) + show_back_buffer (f); + } + unblock_input (); +} + /* Handles the XEvent EVENT on display DPYINFO. *FINISH is X_EVENT_GOTO_OUT if caller should stop reading events. @@ -7605,7 +7685,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto done; } -#ifdef HACK_EDITRES +#ifdef X_TOOLKIT_EDITRES if (event->xclient.message_type == dpyinfo->Xatom_editres) { f = any; @@ -7614,7 +7694,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, NULL, (XEvent *) event, NULL); goto done; } -#endif /* HACK_EDITRES */ +#endif /* X_TOOLKIT_EDITRES */ if (event->xclient.message_type == dpyinfo->Xatom_DONE || event->xclient.message_type == dpyinfo->Xatom_PAGE) @@ -7765,23 +7845,49 @@ handle_one_xevent (struct x_display_info *dpyinfo, { if (!FRAME_VISIBLE_P (f)) { + block_input (); SET_FRAME_VISIBLE (f, 1); SET_FRAME_ICONIFIED (f, false); + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + font_drop_xrender_surfaces (f); f->output_data.x->has_been_visible = true; SET_FRAME_GARBAGED (f); + unblock_input (); } - else - { + else if (FRAME_GARBAGED_P (f)) + { #ifdef USE_GTK - /* This seems to be needed for GTK 2.6 and later, see - http://debbugs.gnu.org/cgi/bugreport.cgi?bug=15398. */ - x_clear_area (f, - event->xexpose.x, event->xexpose.y, - event->xexpose.width, event->xexpose.height); + /* Go around the back buffer and manually clear the + window the first time we show it. This way, we avoid + showing users the sanity-defying horror of whatever + GtkWindow is rendering beneath us. We've garbaged + the frame, so we'll redraw the whole thing on next + redisplay anyway. Yuck. */ + x_clear_area1 ( + FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + event->xexpose.x, event->xexpose.y, + event->xexpose.width, event->xexpose.height, + 0); +#endif + } + + + if (!FRAME_GARBAGED_P (f)) + { +#ifdef USE_GTK + /* This seems to be needed for GTK 2.6 and later, see + http://debbugs.gnu.org/cgi/bugreport.cgi?bug=15398. */ + x_clear_area (f, + event->xexpose.x, event->xexpose.y, + event->xexpose.width, event->xexpose.height); #endif - expose_frame (f, event->xexpose.x, event->xexpose.y, + expose_frame (f, event->xexpose.x, event->xexpose.y, event->xexpose.width, event->xexpose.height); - } + } + + if (!FRAME_GARBAGED_P (f)) + show_back_buffer (f); } else { @@ -7821,10 +7927,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, available. */ f = x_window_to_frame (dpyinfo, event->xgraphicsexpose.drawable); if (f) - expose_frame (f, event->xgraphicsexpose.x, - event->xgraphicsexpose.y, - event->xgraphicsexpose.width, - event->xgraphicsexpose.height); + { + expose_frame (f, event->xgraphicsexpose.x, + event->xgraphicsexpose.y, + event->xgraphicsexpose.width, + event->xgraphicsexpose.height); + show_back_buffer (f); + } #ifdef USE_X_TOOLKIT else goto OTHER; @@ -7895,16 +8004,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* Force a redisplay sooner or later to update the frame titles in case this is the second frame. */ record_asynch_buffer_change (); - -#ifdef USE_GTK - /* xg_frame_resized does the wrong thing with Gtk+ 3.20.3 or later. - For earlier Gtk+ versions it is unclear whether - xg_frame_resized is useful, so leave it in for now. - See Bug#23144. */ -# if ! GTK_CHECK_VERSION (3, 20, 3) - xg_frame_resized (f, -1, -1); -# endif -#endif } goto OTHER; @@ -8419,7 +8518,17 @@ handle_one_xevent (struct x_display_info *dpyinfo, else configureEvent = next_event; } + f = x_top_window_to_frame (dpyinfo, configureEvent.xconfigure.window); + /* Unfortunately, we need to call font_drop_xrender_surfaces for + _all_ ConfigureNotify events, otherwise we miss some and + flicker. Don't try to optimize these calls by looking only + for size changes: that's not sufficient. We miss some + surface invalidations and flicker. */ + block_input (); + if (f && FRAME_X_DOUBLE_BUFFERED_P (f)) + font_drop_xrender_surfaces (f); + unblock_input (); #ifdef USE_CAIRO if (f) x_cr_destroy_surface (f); #endif @@ -8428,6 +8537,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, && (f = any) && configureEvent.xconfigure.window == FRAME_X_WINDOW (f)) { + block_input (); + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + font_drop_xrender_surfaces (f); + unblock_input (); xg_frame_resized (f, configureEvent.xconfigure.width, configureEvent.xconfigure.height); #ifdef USE_CAIRO @@ -8438,7 +8551,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif if (f) { - x_net_wm_state (f, configureEvent.xconfigure.window); + + x_net_wm_state (f, configureEvent.xconfigure.window); #ifdef USE_X_TOOLKIT /* Tip frames are pure X window, set size for them. */ @@ -8446,7 +8560,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, { if (FRAME_PIXEL_HEIGHT (f) != configureEvent.xconfigure.height || FRAME_PIXEL_WIDTH (f) != configureEvent.xconfigure.width) - SET_FRAME_GARBAGED (f); + { + SET_FRAME_GARBAGED (f); + } FRAME_PIXEL_HEIGHT (f) = configureEvent.xconfigure.height; FRAME_PIXEL_WIDTH (f) = configureEvent.xconfigure.width; } @@ -8472,8 +8588,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, || configureEvent.xconfigure.height != FRAME_PIXEL_HEIGHT (f)) { change_frame_size (f, width, height, false, true, false, true); - x_clear_under_internal_border (f); - SET_FRAME_GARBAGED (f); + x_clear_under_internal_border (f); + SET_FRAME_GARBAGED (f); cancel_mouse_face (f); } #endif /* not USE_GTK */ @@ -8697,6 +8813,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, count++; } + /* Sometimes event processing draws to the frame outside redisplay. + To ensure that these changes become visible, draw them here. */ + flush_dirty_back_buffers (); SAFE_FREE (); return count; } @@ -8889,7 +9008,7 @@ x_draw_hollow_cursor (struct window *w, struct glyph_row *row) if (dpyinfo->scratch_cursor_gc) XChangeGC (dpy, dpyinfo->scratch_cursor_gc, GCForeground, &xgcv); else - dpyinfo->scratch_cursor_gc = XCreateGC (dpy, FRAME_X_WINDOW (f), + dpyinfo->scratch_cursor_gc = XCreateGC (dpy, FRAME_X_DRAWABLE (f), GCForeground, &xgcv); gc = dpyinfo->scratch_cursor_gc; @@ -8946,7 +9065,7 @@ x_draw_bar_cursor (struct window *w, struct glyph_row *row, int width, enum text else { Display *dpy = FRAME_X_DISPLAY (f); - Window window = FRAME_X_WINDOW (f); + Drawable drawable = FRAME_X_DRAWABLE (f); GC gc = FRAME_DISPLAY_INFO (f)->scratch_cursor_gc; unsigned long mask = GCForeground | GCBackground | GCGraphicsExposures; struct face *face = FACE_FROM_ID (f, cursor_glyph->face_id); @@ -8967,7 +9086,7 @@ x_draw_bar_cursor (struct window *w, struct glyph_row *row, int width, enum text XChangeGC (dpy, gc, mask, &xgcv); else { - gc = XCreateGC (dpy, window, mask, &xgcv); + gc = XCreateGC (dpy, drawable, mask, &xgcv); FRAME_DISPLAY_INFO (f)->scratch_cursor_gc = gc; } @@ -9037,11 +9156,6 @@ static void x_clear_frame_area (struct frame *f, int x, int y, int width, int height) { x_clear_area (f, x, y, width, height); -#ifdef USE_GTK - /* Must queue a redraw, because scroll bars might have been cleared. */ - if (FRAME_GTK_WIDGET (f)) - gtk_widget_queue_draw (FRAME_GTK_WIDGET (f)); -#endif } @@ -9398,7 +9512,7 @@ static char *error_msg; /* Handle the loss of connection to display DPY. ERROR_MESSAGE is the text of an error message that lead to the connection loss. */ -static void +static _Noreturn void x_connection_closed (Display *dpy, const char *error_message, bool ioerror) { struct x_display_info *dpyinfo = x_display_info_for_display (dpy); @@ -9496,9 +9610,6 @@ For details, see etc/PROBLEMS.\n", unbind_to (idx, Qnil); clear_waiting_for_input (); - /* Tell GCC not to suggest attribute 'noreturn' for this function. */ - IF_LINT (if (! terminal_list) return; ) - /* Here, we absolutely have to use a non-local exit (e.g. signal, throw, longjmp), because returning from this function would get us back into Xlib's code which will directly call `exit'. */ @@ -9564,7 +9675,7 @@ x_error_quitter (Display *display, XErrorEvent *event) It kills all frames on the display that we lost touch with. If that was the only one, it prints an error message and kills Emacs. */ -static int +static _Noreturn int x_io_error_quitter (Display *display) { char buf[256]; @@ -9572,7 +9683,7 @@ x_io_error_quitter (Display *display) snprintf (buf, sizeof buf, "Connection lost to X server '%s'", DisplayString (display)); x_connection_closed (display, buf, true); - return 0; + assume (false); } /* Changing the font of the frame. */ @@ -10901,9 +11012,9 @@ x_make_frame_visible (struct frame *f) if (! FRAME_VISIBLE_P (f)) { - /* We test FRAME_GARBAGED_P here to make sure we don't - call x_set_offset a second time - if we get to x_make_frame_visible a second time + /* We test asked_for_visible here to make sure we don't + call x_set_offset a second time + if we get to x_make_frame_visible a second time before the window gets really visible. */ if (! FRAME_ICONIFIED_P (f) && ! FRAME_X_EMBEDDED_P (f) @@ -10947,6 +11058,8 @@ x_make_frame_visible (struct frame *f) will set it when they are handled. */ bool previously_visible = f->output_data.x->has_been_visible; + XSETFRAME (frame, f); + original_left = f->left_pos; original_top = f->top_pos; @@ -10993,8 +11106,6 @@ x_make_frame_visible (struct frame *f) unblock_input (); } - XSETFRAME (frame, f); - /* Process X events until a MapNotify event has been seen. */ while (!FRAME_VISIBLE_P (f)) { @@ -11239,6 +11350,7 @@ x_free_frame_resources (struct frame *f) font-driver (e.g. xft) access a window while finishing a face. */ free_frame_faces (f); + tear_down_x_back_buffer (f); if (f->output_data.x->icon_desc) XDestroyWindow (FRAME_X_DISPLAY (f), f->output_data.x->icon_desc); @@ -11270,7 +11382,7 @@ x_free_frame_resources (struct frame *f) /* Tooltips don't have widgets, only a simple X window, even if we are using a toolkit. */ else if (FRAME_X_WINDOW (f)) - XDestroyWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + XDestroyWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); free_frame_menubar (f); @@ -11282,8 +11394,9 @@ x_free_frame_resources (struct frame *f) xg_free_frame_widgets (f); #endif /* USE_GTK */ + tear_down_x_back_buffer (f); if (FRAME_X_WINDOW (f)) - XDestroyWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + XDestroyWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); #endif /* !USE_X_TOOLKIT */ unload_color (f, FRAME_FOREGROUND_PIXEL (f)); @@ -12123,7 +12236,15 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) } else dpyinfo->cmap = XCreateColormap (dpyinfo->display, dpyinfo->root_window, - dpyinfo->visual, AllocNone); + dpyinfo->visual, AllocNone); + +#ifdef HAVE_XDBE + dpyinfo->supports_xdbe = false; + int xdbe_major; + int xdbe_minor; + if (XdbeQueryExtension (dpyinfo->display, &xdbe_major, &xdbe_minor)) + dpyinfo->supports_xdbe = true; +#endif #ifdef HAVE_XFT { @@ -12474,7 +12595,7 @@ static struct redisplay_interface x_redisplay_interface = x_after_update_window_line, x_update_window_begin, x_update_window_end, - x_flush, + x_flip_and_flush, x_clear_window_mouse_face, x_get_glyph_overhangs, x_fix_overlapping_area, @@ -12604,6 +12725,7 @@ x_create_terminal (struct x_display_info *dpyinfo) terminal->update_end_hook = x_update_end; terminal->read_socket_hook = XTread_socket; terminal->frame_up_to_date_hook = XTframe_up_to_date; + terminal->buffer_flipping_unblocked_hook = XTbuffer_flipping_unblocked_hook; terminal->mouse_position_hook = XTmouse_position; terminal->frame_rehighlight_hook = XTframe_rehighlight; terminal->frame_raise_lower_hook = XTframe_raise_lower; @@ -12640,6 +12762,13 @@ x_initialize (void) /* Try to use interrupt input; if we can't, then start polling. */ Fset_input_interrupt_mode (Qt); +#if THREADS_ENABLED + /* This must be called before any other Xlib routines. */ + if (XInitThreads () == 0) + fprintf (stderr, + "Warning: An error occurred initializing X11 thread support!\n"); +#endif + #ifdef USE_X_TOOLKIT XtToolkitInitialize (); @@ -12747,6 +12876,8 @@ With MS Windows or Nextstep, the value is t. */); #endif DEFSYM (Qmodifier_value, "modifier-value"); + DEFSYM (Qctrl, "ctrl"); + Fput (Qctrl, Qmodifier_value, make_number (ctrl_modifier)); DEFSYM (Qalt, "alt"); Fput (Qalt, Qmodifier_value, make_number (alt_modifier)); DEFSYM (Qhyper, "hyper"); @@ -12756,32 +12887,39 @@ With MS Windows or Nextstep, the value is t. */); DEFSYM (Qsuper, "super"); Fput (Qsuper, Qmodifier_value, make_number (super_modifier)); + DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, + doc: /* Which keys Emacs uses for the ctrl modifier. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `ctrl' means use the Ctrl_L and Ctrl_R keysyms. +The default is nil, which is the same as `ctrl'. */); + Vx_ctrl_keysym = Qnil; + DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym, doc: /* Which keys Emacs uses for the alt modifier. -This should be one of the symbols `alt', `hyper', `meta', `super'. -For example, `alt' means use the Alt_L and Alt_R keysyms. The default -is nil, which is the same as `alt'. */); +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `alt' means use the Alt_L and Alt_R keysyms. +The default is nil, which is the same as `alt'. */); Vx_alt_keysym = Qnil; DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym, doc: /* Which keys Emacs uses for the hyper modifier. -This should be one of the symbols `alt', `hyper', `meta', `super'. -For example, `hyper' means use the Hyper_L and Hyper_R keysyms. The -default is nil, which is the same as `hyper'. */); +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `hyper' means use the Hyper_L and Hyper_R +keysyms. The default is nil, which is the same as `hyper'. */); Vx_hyper_keysym = Qnil; DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym, doc: /* Which keys Emacs uses for the meta modifier. -This should be one of the symbols `alt', `hyper', `meta', `super'. -For example, `meta' means use the Meta_L and Meta_R keysyms. The -default is nil, which is the same as `meta'. */); +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `meta' means use the Meta_L and Meta_R keysyms. +The default is nil, which is the same as `meta'. */); Vx_meta_keysym = Qnil; DEFVAR_LISP ("x-super-keysym", Vx_super_keysym, doc: /* Which keys Emacs uses for the super modifier. -This should be one of the symbols `alt', `hyper', `meta', `super'. -For example, `super' means use the Super_L and Super_R keysyms. The -default is nil, which is the same as `super'. */); +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `super' means use the Super_L and Super_R +keysyms. The default is nil, which is the same as `super'. */); Vx_super_keysym = Qnil; DEFVAR_LISP ("x-keysym-table", Vx_keysym_table, diff --git a/src/xterm.h b/src/xterm.h index 8e1fc788bc1..01d7efc6dc8 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -38,6 +38,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include <X11/CoreP.h> /* foul, but we need this to use our own window inside a widget instead of one that Xt creates... */ +#ifdef X_TOOLKIT_EDITRES +#include <X11/Xmu/Editres.h> +#endif + typedef Widget xt_or_gtk_widget; #endif @@ -471,6 +475,10 @@ struct x_display_info #ifdef USE_XCB xcb_connection_t *xcb_connection; #endif + +#ifdef HAVE_XDBE + bool supports_xdbe; +#endif }; #ifdef HAVE_X_I18N @@ -523,6 +531,16 @@ struct x_output and the X window has not yet been created. */ Window window_desc; + /* The drawable to which we're rendering. In the single-buffered + base, the window itself. In the double-buffered case, the + window's back buffer. */ + Drawable draw_desc; + + /* Flag that indicates whether we've modified the back buffer and + need to publish our modifications to the front buffer at a + convenient time. */ + bool need_buffer_flip; + /* The X window used for the bitmap icon; or 0 if we don't have a bitmap icon. */ Window icon_desc; @@ -733,6 +751,24 @@ enum /* Return the X window used for displaying data in frame F. */ #define FRAME_X_WINDOW(f) ((f)->output_data.x->window_desc) +/* Return the drawable used for rendering to frame F. */ +#define FRAME_X_RAW_DRAWABLE(f) ((f)->output_data.x->draw_desc) + +extern void x_mark_frame_dirty (struct frame *f); + +/* Return the drawable used for rendering to frame F and mark the + frame as needing a buffer flip later. There's no easy way to run + code after any drawing command, but we can run code whenever + someone asks for the handle necessary to draw. */ +#define FRAME_X_DRAWABLE(f) \ + (x_mark_frame_dirty((f)), FRAME_X_RAW_DRAWABLE ((f))) + +#define FRAME_X_DOUBLE_BUFFERED_P(f) \ + (FRAME_X_WINDOW (f) != FRAME_X_RAW_DRAWABLE (f)) + +/* Return the need-buffer-flip flag for frame F. */ +#define FRAME_X_NEED_BUFFER_FLIP(f) ((f)->output_data.x->need_buffer_flip) + /* Return the outermost X window associated with the frame F. */ #ifdef USE_X_TOOLKIT #define FRAME_OUTER_WINDOW(f) ((f)->output_data.x->widget ? \ @@ -1136,6 +1172,9 @@ extern bool x_wm_supports (struct frame *, Atom); extern void x_wait_for_event (struct frame *, int); extern void x_clear_under_internal_border (struct frame *f); +extern void tear_down_x_back_buffer (struct frame *f); +extern void initial_set_up_x_back_buffer (struct frame *f); + /* Defined in xselect.c. */ extern void x_handle_property_notify (const XPropertyEvent *); diff --git a/src/xwidget.c b/src/xwidget.c index 82449f7a215..62df6657e9f 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -21,90 +21,14 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "xwidget.h" -#include <signal.h> - -#include <stdio.h> -#include <setjmp.h> -#ifdef HAVE_X_WINDOWS - #include "lisp.h" #include "blockinput.h" -#include "syssignal.h" - -#include "xterm.h" -#include <X11/cursorfont.h> - -#ifndef makedev -# include <sys/types.h> -#endif - -#ifdef BSD_SYSTEM -# include <sys/ioctl.h> -#endif - -#include "systime.h" - -#ifndef INCLUDED_FCNTL -# include <fcntl.h> -#endif -#include <ctype.h> -#include <errno.h> -#include <setjmp.h> -#include <sys/stat.h> - -#include "charset.h" -#include "character.h" -#include "coding.h" -#include "ccl.h" #include "frame.h" -#include "dispextern.h" -#include "fontset.h" -#include "termhooks.h" -#include "termopts.h" -#include "termchar.h" -#include "disptab.h" -#include "buffer.h" -#include "window.h" #include "keyboard.h" -#include "intervals.h" -#include "process.h" -#include "atimer.h" -#include "keymap.h" - - -#ifdef USE_X_TOOLKIT -#include <X11/Shell.h> -#endif -#include <X11/extensions/Xcomposite.h> -#include <X11/extensions/Xrender.h> -#include <cairo.h> -#ifdef HAVE_SYS_TIME_H -#include <sys/time.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - #include "gtkutil.h" -#include "font.h" -#endif /* HAVE_X_WINDOWS */ - -#include <gtk/gtk.h> -#include <gdk/gdk.h> - -#include <gtk/gtkx.h> - -#include "emacsgtkfixed.h" -#include <wchar.h> - -#include <webkit/webkitwebview.h> -#include <webkit/webkitwebplugindatabase.h> -#include <webkit/webkitwebplugin.h> -#include <webkit/webkitglobals.h> -#include <webkit/webkitwebnavigationaction.h> -#include <webkit/webkitdownload.h> -#include <webkit/webkitwebpolicydecision.h> +#include <webkit2/webkit2.h> +#include <JavaScriptCore/JavaScript.h> static struct xwidget * allocate_xwidget (void) @@ -124,34 +48,19 @@ allocate_xwidget_view (void) static struct xwidget_view *xwidget_view_lookup (struct xwidget *, struct window *); -static void webkit_document_load_finished_cb (WebKitWebView *, WebKitWebFrame *, - gpointer); -static gboolean webkit_download_cb (WebKitWebView *, WebKitDownload *, gpointer); +static void webkit_view_load_changed_cb (WebKitWebView *, + WebKitLoadEvent, + gpointer); +static void webkit_javascript_finished_cb (GObject *, + GAsyncResult *, + gpointer); +static gboolean webkit_download_cb (WebKitWebContext *, WebKitDownload *, gpointer); static gboolean -webkit_mime_type_policy_typedecision_requested_cb (WebKitWebView *, - WebKitWebFrame *, - WebKitNetworkRequest *, - gchar *, - WebKitWebPolicyDecision *, - gpointer); - -static gboolean -webkit_new_window_policy_decision_requested_cb (WebKitWebView *, - WebKitWebFrame *, - WebKitNetworkRequest *, - WebKitWebNavigationAction *, - WebKitWebPolicyDecision *, - gpointer); - -static gboolean -webkit_navigation_policy_decision_requested_cb (WebKitWebView *, - WebKitWebFrame *, - WebKitNetworkRequest *, - WebKitWebNavigationAction *, - WebKitWebPolicyDecision *, - gpointer); - +webkit_decide_policy_cb (WebKitWebView *, + WebKitPolicyDecision *, + WebKitPolicyDecisionType, + gpointer); DEFUN ("make-xwidget", @@ -194,25 +103,9 @@ Returns the newly constructed xwidget, or nil if construction fails. */) gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, xw->height); - /* WebKit OSR is the only scrolled component at the moment. */ - xw->widgetscrolledwindow_osr = NULL; - if (EQ (xw->type, Qwebkit)) { - xw->widgetscrolledwindow_osr = gtk_scrolled_window_new (NULL, NULL); - gtk_scrolled_window_set_min_content_height - (GTK_SCROLLED_WINDOW (xw->widgetscrolledwindow_osr), - xw->height); - gtk_scrolled_window_set_min_content_width - (GTK_SCROLLED_WINDOW (xw->widgetscrolledwindow_osr), - xw->width); - gtk_scrolled_window_set_policy - (GTK_SCROLLED_WINDOW (xw->widgetscrolledwindow_osr), - GTK_POLICY_ALWAYS, GTK_POLICY_ALWAYS); - xw->widget_osr = webkit_web_view_new (); - gtk_container_add (GTK_CONTAINER (xw->widgetscrolledwindow_osr), - GTK_WIDGET (WEBKIT_WEB_VIEW (xw->widget_osr))); } gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, @@ -221,7 +114,7 @@ Returns the newly constructed xwidget, or nil if construction fails. */) if (EQ (xw->type, Qwebkit)) { gtk_container_add (GTK_CONTAINER (xw->widgetwindow_osr), - xw->widgetscrolledwindow_osr); + GTK_WIDGET (WEBKIT_WEB_VIEW (xw->widget_osr))); } else { @@ -231,7 +124,6 @@ Returns the newly constructed xwidget, or nil if construction fails. */) gtk_widget_show (xw->widget_osr); gtk_widget_show (xw->widgetwindow_osr); - gtk_widget_show (xw->widgetscrolledwindow_osr); /* Store some xwidget data in the gtk widgets for convenient retrieval in the event handlers. */ @@ -242,29 +134,17 @@ Returns the newly constructed xwidget, or nil if construction fails. */) if (EQ (xw->type, Qwebkit)) { g_signal_connect (G_OBJECT (xw->widget_osr), - "document-load-finished", - G_CALLBACK (webkit_document_load_finished_cb), xw); + "load-changed", + G_CALLBACK (webkit_view_load_changed_cb), xw); - g_signal_connect (G_OBJECT (xw->widget_osr), - "download-requested", + g_signal_connect (G_OBJECT (webkit_web_context_get_default ()), + "download-started", G_CALLBACK (webkit_download_cb), xw); g_signal_connect (G_OBJECT (xw->widget_osr), - "mime-type-policy-decision-requested", - G_CALLBACK - (webkit_mime_type_policy_typedecision_requested_cb), - xw); - - g_signal_connect (G_OBJECT (xw->widget_osr), - "new-window-policy-decision-requested", - G_CALLBACK - (webkit_new_window_policy_decision_requested_cb), - xw); - - g_signal_connect (G_OBJECT (xw->widget_osr), - "navigation-policy-decision-requested", + "decide-policy", G_CALLBACK - (webkit_navigation_policy_decision_requested_cb), + (webkit_decide_policy_cb), xw); } @@ -358,81 +238,221 @@ store_xwidget_event_string (struct xwidget *xw, const char *eventname, kbd_buffer_store_event (&event); } -/* TODO deprecated, use load-status. */ +static void +store_xwidget_js_callback_event (struct xwidget *xw, + Lisp_Object proc, + Lisp_Object argument) +{ + struct input_event event; + Lisp_Object xwl; + XSETXWIDGET (xwl, xw); + EVENT_INIT (event); + event.kind = XWIDGET_EVENT; + event.frame_or_window = Qnil; + event.arg = list4 (intern ("javascript-callback"), xwl, proc, argument); + kbd_buffer_store_event (&event); +} + + void -webkit_document_load_finished_cb (WebKitWebView *webkitwebview, - WebKitWebFrame *arg1, - gpointer data) +webkit_view_load_changed_cb (WebKitWebView *webkitwebview, + WebKitLoadEvent load_event, + gpointer data) { - struct xwidget *xw = g_object_get_data (G_OBJECT (webkitwebview), - XG_XWIDGET); + switch (load_event) { + case WEBKIT_LOAD_FINISHED: + { + struct xwidget *xw = g_object_get_data (G_OBJECT (webkitwebview), + XG_XWIDGET); + store_xwidget_event_string (xw, "load-changed", ""); + break; + } + default: + break; + } +} + +/* Recursively convert a JavaScript value to a Lisp value. */ +static Lisp_Object +webkit_js_to_lisp (JSContextRef context, JSValueRef value) +{ + switch (JSValueGetType (context, value)) + { + case kJSTypeString: + { + JSStringRef js_str_value; + gchar *str_value; + gsize str_length; + + js_str_value = JSValueToStringCopy (context, value, NULL); + str_length = JSStringGetMaximumUTF8CStringSize (js_str_value); + str_value = (gchar *)g_malloc (str_length); + JSStringGetUTF8CString (js_str_value, str_value, str_length); + JSStringRelease (js_str_value); + return build_string (str_value); + } + case kJSTypeBoolean: + return (JSValueToBoolean (context, value)) ? Qt : Qnil; + case kJSTypeNumber: + return make_number (JSValueToNumber (context, value, NULL)); + case kJSTypeObject: + { + if (JSValueIsArray (context, value)) + { + JSStringRef pname = JSStringCreateWithUTF8CString("length"); + JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value, pname, NULL); + int n = JSValueToNumber (context, len, NULL); + JSStringRelease(pname); + + Lisp_Object obj; + struct Lisp_Vector *p = allocate_vector (n); + + for (int i = 0; i < n; ++i) + { + p->contents[i] = + webkit_js_to_lisp (context, + JSObjectGetPropertyAtIndex (context, + (JSObjectRef) value, + i, NULL)); + } + XSETVECTOR (obj, p); + return obj; + } + else + { + JSPropertyNameArrayRef properties = + JSObjectCopyPropertyNames (context, (JSObjectRef) value); + + int n = JSPropertyNameArrayGetCount (properties); + Lisp_Object obj; + + /* TODO: can we use a regular list here? */ + struct Lisp_Vector *p = allocate_vector (n); + + for (int i = 0; i < n; ++i) + { + JSStringRef name = JSPropertyNameArrayGetNameAtIndex (properties, i); + JSValueRef property = JSObjectGetProperty (context, + (JSObjectRef) value, + name, NULL); + gchar *str_name; + gsize str_length; + str_length = JSStringGetMaximumUTF8CStringSize (name); + str_name = (gchar *)g_malloc (str_length); + JSStringGetUTF8CString (name, str_name, str_length); + JSStringRelease (name); + + p->contents[i] = + Fcons (build_string (str_name), + webkit_js_to_lisp (context, property)); + } + + JSPropertyNameArrayRelease (properties); + XSETVECTOR (obj, p); + return obj; + } + } + case kJSTypeUndefined: + case kJSTypeNull: + default: + return Qnil; + } +} + +static void +webkit_javascript_finished_cb (GObject *webview, + GAsyncResult *result, + gpointer lisp_callback) +{ + WebKitJavascriptResult *js_result; + JSValueRef value; + JSGlobalContextRef context; + GError *error = NULL; + struct xwidget *xw = g_object_get_data (G_OBJECT (webview), + XG_XWIDGET); - store_xwidget_event_string (xw, "document-load-finished", ""); + js_result = webkit_web_view_run_javascript_finish + (WEBKIT_WEB_VIEW (webview), result, &error); + + if (!js_result) + { + g_warning ("Error running javascript: %s", error->message); + g_error_free (error); + return; + } + + context = webkit_javascript_result_get_global_context (js_result); + value = webkit_javascript_result_get_value (js_result); + Lisp_Object lisp_value = webkit_js_to_lisp (context, value); + webkit_javascript_result_unref (js_result); + + /* Register an xwidget event here, which then runs the callback. + This ensures that the callback runs in sync with the Emacs + event loop. */ + store_xwidget_js_callback_event (xw, (Lisp_Object)lisp_callback, + lisp_value); } + gboolean -webkit_download_cb (WebKitWebView *webkitwebview, +webkit_download_cb (WebKitWebContext *webkitwebcontext, WebKitDownload *arg1, gpointer data) { - struct xwidget *xw = g_object_get_data (G_OBJECT (webkitwebview), + WebKitWebView *view = webkit_download_get_web_view(arg1); + WebKitURIRequest *request = webkit_download_get_request(arg1); + struct xwidget *xw = g_object_get_data (G_OBJECT (view), XG_XWIDGET); - store_xwidget_event_string (xw, "download-requested", - webkit_download_get_uri (arg1)); + + store_xwidget_event_string (xw, "download-started", + webkit_uri_request_get_uri(request)); return FALSE; } static gboolean -webkit_mime_type_policy_typedecision_requested_cb (WebKitWebView *webView, - WebKitWebFrame *frame, - WebKitNetworkRequest *request, - gchar *mimetype, - WebKitWebPolicyDecision *policy_decision, - gpointer user_data) +webkit_decide_policy_cb (WebKitWebView *webView, + WebKitPolicyDecision *decision, + WebKitPolicyDecisionType type, + gpointer user_data) { - /* This function makes webkit send a download signal for all unknown - mime types. TODO: Defer the decision to Lisp, so that it's - possible to make Emacs handle mime text for instance. */ - if (!webkit_web_view_can_show_mime_type (webView, mimetype)) + switch (type) { + case WEBKIT_POLICY_DECISION_TYPE_RESPONSE: + /* This function makes webkit send a download signal for all unknown + mime types. TODO: Defer the decision to Lisp, so that it's + possible to make Emacs handle mime text for instance. */ { - webkit_web_policy_decision_download (policy_decision); - return TRUE; + WebKitResponsePolicyDecision *response = + WEBKIT_RESPONSE_POLICY_DECISION (decision); + if (!webkit_response_policy_decision_is_mime_type_supported (response)) + { + webkit_policy_decision_download (decision); + return TRUE; + } + else + return FALSE; + break; } - else + case WEBKIT_POLICY_DECISION_TYPE_NEW_WINDOW_ACTION: + case WEBKIT_POLICY_DECISION_TYPE_NAVIGATION_ACTION: + { + WebKitNavigationPolicyDecision *navigation_decision = + WEBKIT_NAVIGATION_POLICY_DECISION (decision); + WebKitNavigationAction *navigation_action = + webkit_navigation_policy_decision_get_navigation_action (navigation_decision); + WebKitURIRequest *request = + webkit_navigation_action_get_request (navigation_action); + + struct xwidget *xw = g_object_get_data (G_OBJECT (webView), XG_XWIDGET); + store_xwidget_event_string (xw, "decide-policy", + webkit_uri_request_get_uri (request)); + return FALSE; + break; + } + default: return FALSE; + } } -static gboolean -webkit_new_window_policy_decision_requested_cb (WebKitWebView *webView, - WebKitWebFrame *frame, - WebKitNetworkRequest *request, - WebKitWebNavigationAction *navigation_action, - WebKitWebPolicyDecision *policy_decision, - gpointer user_data) -{ - struct xwidget *xw = g_object_get_data (G_OBJECT (webView), XG_XWIDGET); - webkit_web_navigation_action_get_original_uri (navigation_action); - - store_xwidget_event_string (xw, "new-window-policy-decision-requested", - webkit_web_navigation_action_get_original_uri - (navigation_action)); - return FALSE; -} - -static gboolean -webkit_navigation_policy_decision_requested_cb (WebKitWebView *webView, - WebKitWebFrame *frame, - WebKitNetworkRequest *request, - WebKitWebNavigationAction *navigation_action, - WebKitWebPolicyDecision *policy_decision, - gpointer user_data) -{ - struct xwidget *xw = g_object_get_data (G_OBJECT (webView), XG_XWIDGET); - store_xwidget_event_string (xw, "navigation-policy-decision-requested", - webkit_web_navigation_action_get_original_uri - (navigation_action)); - return FALSE; -} /* For gtk3 offscreen rendered widgets. */ static gboolean @@ -445,10 +465,7 @@ xwidget_osr_draw_cb (GtkWidget *widget, cairo_t *cr, gpointer data) cairo_rectangle (cr, 0, 0, xv->clip_right, xv->clip_bottom); cairo_clip (cr); - if (xw->widgetscrolledwindow_osr != NULL) - gtk_widget_draw (xw->widgetscrolledwindow_osr, cr); - else - gtk_widget_draw (xw->widget_osr, cr); + gtk_widget_draw (xw->widget_osr, cr); return FALSE; } @@ -565,12 +582,16 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) xwidget on screen. Moving and clipping is done here. Also view initialization. */ struct xwidget *xww = s->xwidget; - struct xwidget_view *xv = xwidget_view_lookup (xww, s->w); + struct xwidget_view *xv; int clip_right; int clip_bottom; int clip_top; int clip_left; + /* FIXME: The result of this call is discarded. + What if the lookup fails? */ + xwidget_view_lookup (xww, s->w); + int x = s->x; int y = s->y + (s->height / 2) - (xww->height / 2); @@ -660,39 +681,51 @@ DEFUN ("xwidget-webkit-goto-uri", return Qnil; } - -DEFUN ("xwidget-webkit-execute-script", - Fxwidget_webkit_execute_script, Sxwidget_webkit_execute_script, +DEFUN ("xwidget-webkit-zoom", + Fxwidget_webkit_zoom, Sxwidget_webkit_zoom, 2, 2, 0, - doc: /* Make the Webkit XWIDGET execute JavaScript SCRIPT. */) - (Lisp_Object xwidget, Lisp_Object script) + doc: /* Change the zoom factor of the xwidget webkit instance +referenced by XWIDGET. */) + (Lisp_Object xwidget, Lisp_Object factor) { WEBKIT_FN_INIT (); - CHECK_STRING (script); - webkit_web_view_execute_script (WEBKIT_WEB_VIEW (xw->widget_osr), - SSDATA (script)); + if (FLOATP (factor)) + { + double zoom_change = XFLOAT_DATA (factor); + webkit_web_view_set_zoom_level + (WEBKIT_WEB_VIEW (xw->widget_osr), + webkit_web_view_get_zoom_level + (WEBKIT_WEB_VIEW (xw->widget_osr)) + zoom_change); + } return Qnil; } -DEFUN ("xwidget-webkit-get-title", - Fxwidget_webkit_get_title, Sxwidget_webkit_get_title, - 1, 1, 0, - doc: /* Return the title from the Webkit instance in XWIDGET. -This can be used to work around the lack of a return value from the -exec method. */ ) - (Lisp_Object xwidget) + +DEFUN ("xwidget-webkit-execute-script", + Fxwidget_webkit_execute_script, Sxwidget_webkit_execute_script, + 2, 3, 0, + doc: /* Make the Webkit XWIDGET execute JavaScript SCRIPT. If +FUN is provided, feed the JavaScript return value to the single +argument procedure FUN.*/) + (Lisp_Object xwidget, Lisp_Object script, Lisp_Object fun) { - /* TODO support multibyte strings. */ WEBKIT_FN_INIT (); - const gchar *str = - webkit_web_view_get_title (WEBKIT_WEB_VIEW (xw->widget_osr)); - if (str == 0) - { - /* TODO maybe return Qnil instead. I suppose webkit returns - null pointer when doc is not properly loaded or something. */ - return build_string (""); - } - return build_string (str); + CHECK_STRING (script); + if (!NILP (fun) && !FUNCTIONP (fun)) + wrong_type_argument (Qinvalid_function, fun); + + void *callback = (FUNCTIONP (fun)) ? + &webkit_javascript_finished_cb : NULL; + + /* JavaScript execution happens asynchronously. If an elisp + callback function is provided we pass it to the C callback + procedure that retrieves the return value. */ + webkit_web_view_run_javascript (WEBKIT_WEB_VIEW (xw->widget_osr), + SSDATA (script), + NULL, /* cancelable */ + callback, + (gpointer) fun); + return Qnil; } DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, @@ -712,21 +745,11 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, /* If there is an offscreen widget resize it first. */ if (xw->widget_osr) { - /* Use minimum size. */ - gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), - xw->width, xw->height); - gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, xw->height); - gtk_scrolled_window_set_min_content_height - (GTK_SCROLLED_WINDOW (xw->widgetscrolledwindow_osr), - xw->height); - gtk_scrolled_window_set_min_content_width - (GTK_SCROLLED_WINDOW (xw->widgetscrolledwindow_osr), - xw->width); - gtk_container_resize_children (GTK_CONTAINER (xw->widgetwindow_osr)); - + gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, + xw->height); } for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); tail = XCDR (tail)) @@ -745,30 +768,6 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, -DEFUN ("xwidget-set-adjustment", - Fxwidget_set_adjustment, Sxwidget_set_adjustment, 4, 4, 0, - doc: /* Set native scrolling for XWIDGET. -AXIS can be `vertical' or `horizontal'. -If RELATIVE is t, scroll relative, otherwise absolutely. -VALUE is the amount to scroll, either relatively or absolutely. */) - (Lisp_Object xwidget, Lisp_Object axis, Lisp_Object relative, - Lisp_Object value) -{ - CHECK_XWIDGET (xwidget); - CHECK_NUMBER (value); - struct xwidget *xw = XXWIDGET (xwidget); - GtkAdjustment *adjustment - = ((EQ (Qhorizontal, axis) - ? gtk_scrolled_window_get_hadjustment - : gtk_scrolled_window_get_vadjustment) - (GTK_SCROLLED_WINDOW (xw->widgetscrolledwindow_osr))); - double final_value = XINT (value); - if (EQ (Qt, relative)) - final_value += gtk_adjustment_get_value (adjustment); - gtk_adjustment_set_value (adjustment, final_value); - return Qnil; -} - DEFUN ("xwidget-size-request", Fxwidget_size_request, Sxwidget_size_request, @@ -973,8 +972,8 @@ syms_of_xwidget (void) defsubr (&Sset_xwidget_query_on_exit_flag); defsubr (&Sxwidget_webkit_goto_uri); + defsubr (&Sxwidget_webkit_zoom); defsubr (&Sxwidget_webkit_execute_script); - defsubr (&Sxwidget_webkit_get_title); DEFSYM (Qwebkit, "webkit"); defsubr (&Sxwidget_size_request); @@ -984,8 +983,6 @@ syms_of_xwidget (void) defsubr (&Sxwidget_buffer); defsubr (&Sset_xwidget_plist); - defsubr (&Sxwidget_set_adjustment); - DEFSYM (Qxwidget, "xwidget"); DEFSYM (QCxwidget, ":xwidget"); @@ -1145,7 +1142,13 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) { /* The only call to xwidget_end_redisplay is in dispnew. xwidget_end_redisplay (w->current_matrix); */ - xwidget_touch (xwidget_view_lookup (glyph->u.xwidget, w)); + struct xwidget_view *xv + = xwidget_view_lookup (glyph->u.xwidget, w); + /* FIXME: Is it safe to assume xwidget_view_lookup + always succeeds here? If so, this comment can be removed. + If not, the code probably needs fixing. */ + eassume (xv); + xwidget_touch (xv); } } } diff --git a/src/xwidget.h b/src/xwidget.h index 8fc382188f4..4447abbe38b 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -56,9 +56,6 @@ struct xwidget GtkWidget *widget_osr; GtkWidget *widgetwindow_osr; - /* Used if the widget (webkit) is to be wrapped in a scrolled window. */ - GtkWidget *widgetscrolledwindow_osr; - /* Kill silently if Emacs is exited. */ bool_bf kill_without_query : 1; }; |