diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/.gdbinit | 90 | ||||
| -rw-r--r-- | src/Makefile.in | 61 | ||||
| -rw-r--r-- | src/alloc.c | 1051 | ||||
| -rw-r--r-- | src/atimer.c | 15 | ||||
| -rw-r--r-- | src/bidi.c | 22 | ||||
| -rw-r--r-- | src/bignum.c | 351 | ||||
| -rw-r--r-- | src/bignum.h | 99 | ||||
| -rw-r--r-- | src/buffer.c | 523 | ||||
| -rw-r--r-- | src/buffer.h | 30 | ||||
| -rw-r--r-- | src/bytecode.c | 129 | ||||
| -rw-r--r-- | src/callint.c | 344 | ||||
| -rw-r--r-- | src/callproc.c | 43 | ||||
| -rw-r--r-- | src/casefiddle.c | 20 | ||||
| -rw-r--r-- | src/casetab.c | 35 | ||||
| -rw-r--r-- | src/category.c | 51 | ||||
| -rw-r--r-- | src/category.h | 12 | ||||
| -rw-r--r-- | src/ccl.c | 188 | ||||
| -rw-r--r-- | src/character.c | 110 | ||||
| -rw-r--r-- | src/character.h | 10 | ||||
| -rw-r--r-- | src/charset.c | 320 | ||||
| -rw-r--r-- | src/charset.h | 6 | ||||
| -rw-r--r-- | src/chartab.c | 107 | ||||
| -rw-r--r-- | src/cmds.c | 78 | ||||
| -rw-r--r-- | src/coding.c | 516 | ||||
| -rw-r--r-- | src/coding.h | 30 | ||||
| -rw-r--r-- | src/composite.c | 173 | ||||
| -rw-r--r-- | src/composite.h | 58 | ||||
| -rw-r--r-- | src/conf_post.h | 46 | ||||
| -rw-r--r-- | src/data.c | 1017 | ||||
| -rw-r--r-- | src/dbusbind.c | 118 | ||||
| -rw-r--r-- | src/decompress.c | 34 | ||||
| -rw-r--r-- | src/deps.mk | 9 | ||||
| -rw-r--r-- | src/dired.c | 119 | ||||
| -rw-r--r-- | src/dispextern.h | 71 | ||||
| -rw-r--r-- | src/dispnew.c | 50 | ||||
| -rw-r--r-- | src/disptab.h | 4 | ||||
| -rw-r--r-- | src/doc.c | 79 | ||||
| -rw-r--r-- | src/doprnt.c | 2 | ||||
| -rw-r--r-- | src/dosfns.c | 82 | ||||
| -rw-r--r-- | src/dynlib.c | 5 | ||||
| -rw-r--r-- | src/editfns.c | 2226 | ||||
| -rw-r--r-- | src/emacs-module.c | 126 | ||||
| -rw-r--r-- | src/emacs.c | 134 | ||||
| -rw-r--r-- | src/eval.c | 317 | ||||
| -rw-r--r-- | src/fileio.c | 524 | ||||
| -rw-r--r-- | src/floatfns.c | 230 | ||||
| -rw-r--r-- | src/fns.c | 580 | ||||
| -rw-r--r-- | src/font.c | 483 | ||||
| -rw-r--r-- | src/font.h | 44 | ||||
| -rw-r--r-- | src/fontset.c | 132 | ||||
| -rw-r--r-- | src/frame.c | 504 | ||||
| -rw-r--r-- | src/frame.h | 23 | ||||
| -rw-r--r-- | src/fringe.c | 75 | ||||
| -rw-r--r-- | src/ftcrfont.c | 5 | ||||
| -rw-r--r-- | src/ftfont.c | 116 | ||||
| -rw-r--r-- | src/gfilenotify.c | 15 | ||||
| -rw-r--r-- | src/gmalloc.c | 24 | ||||
| -rw-r--r-- | src/gnutls.c | 290 | ||||
| -rw-r--r-- | src/gtkutil.c | 71 | ||||
| -rw-r--r-- | src/image.c | 220 | ||||
| -rw-r--r-- | src/indent.c | 152 | ||||
| -rw-r--r-- | src/inotify.c | 26 | ||||
| -rw-r--r-- | src/insdel.c | 36 | ||||
| -rw-r--r-- | src/intervals.c | 52 | ||||
| -rw-r--r-- | src/intervals.h | 2 | ||||
| -rw-r--r-- | src/json.c | 1107 | ||||
| -rw-r--r-- | src/keyboard.c | 1164 | ||||
| -rw-r--r-- | src/keyboard.h | 9 | ||||
| -rw-r--r-- | src/keymap.c | 343 | ||||
| -rw-r--r-- | src/kqueue.c | 42 | ||||
| -rw-r--r-- | src/lastfile.c | 3 | ||||
| -rw-r--r-- | src/lcms.c | 7 | ||||
| -rw-r--r-- | src/lisp.h | 1274 | ||||
| -rw-r--r-- | src/lread.c | 779 | ||||
| -rw-r--r-- | src/macfont.m | 88 | ||||
| -rw-r--r-- | src/macros.c | 22 | ||||
| -rw-r--r-- | src/macuvs.h | 3 | ||||
| -rw-r--r-- | src/marker.c | 62 | ||||
| -rw-r--r-- | src/menu.c | 140 | ||||
| -rw-r--r-- | src/menu.h | 1 | ||||
| -rw-r--r-- | src/mini-gmp-emacs.c | 32 | ||||
| -rw-r--r-- | src/mini-gmp.c | 4452 | ||||
| -rw-r--r-- | src/mini-gmp.h | 300 | ||||
| -rw-r--r-- | src/minibuf.c | 189 | ||||
| -rw-r--r-- | src/msdos.c | 52 | ||||
| -rw-r--r-- | src/nsfns.m | 596 | ||||
| -rw-r--r-- | src/nsfont.m | 148 | ||||
| -rw-r--r-- | src/nsgui.h | 12 | ||||
| -rw-r--r-- | src/nsimage.m | 150 | ||||
| -rw-r--r-- | src/nsmenu.m | 154 | ||||
| -rw-r--r-- | src/nsselect.m | 28 | ||||
| -rw-r--r-- | src/nsterm.h | 121 | ||||
| -rw-r--r-- | src/nsterm.m | 962 | ||||
| -rw-r--r-- | src/print.c | 477 | ||||
| -rw-r--r-- | src/process.c | 445 | ||||
| -rw-r--r-- | src/process.h | 8 | ||||
| -rw-r--r-- | src/profiler.c | 25 | ||||
| -rw-r--r-- | src/ptr-bounds.h | 79 | ||||
| -rw-r--r-- | src/puresize.h | 2 | ||||
| -rw-r--r-- | src/ralloc.c | 12 | ||||
| -rw-r--r-- | src/regex-emacs.c (renamed from src/regex.c) | 2771 | ||||
| -rw-r--r-- | src/regex-emacs.h | 197 | ||||
| -rw-r--r-- | src/regex.h | 644 | ||||
| -rw-r--r-- | src/scroll.c | 34 | ||||
| -rw-r--r-- | src/search.c | 924 | ||||
| -rw-r--r-- | src/sound.c | 17 | ||||
| -rw-r--r-- | src/syntax.c | 219 | ||||
| -rw-r--r-- | src/syntax.h | 16 | ||||
| -rw-r--r-- | src/sysdep.c | 414 | ||||
| -rw-r--r-- | src/syssignal.h | 1 | ||||
| -rw-r--r-- | src/systhread.c | 98 | ||||
| -rw-r--r-- | src/systhread.h | 23 | ||||
| -rw-r--r-- | src/systime.h | 49 | ||||
| -rw-r--r-- | src/term.c | 81 | ||||
| -rw-r--r-- | src/termhooks.h | 10 | ||||
| -rw-r--r-- | src/terminal.c | 6 | ||||
| -rw-r--r-- | src/textprop.c | 315 | ||||
| -rw-r--r-- | src/thread.c | 131 | ||||
| -rw-r--r-- | src/thread.h | 32 | ||||
| -rw-r--r-- | src/timefns.c | 1752 | ||||
| -rw-r--r-- | src/tparam.h | 5 | ||||
| -rw-r--r-- | src/undo.c | 34 | ||||
| -rw-r--r-- | src/unexcw.c | 6 | ||||
| -rw-r--r-- | src/w16select.c | 41 | ||||
| -rw-r--r-- | src/w32.c | 654 | ||||
| -rw-r--r-- | src/w32.h | 17 | ||||
| -rw-r--r-- | src/w32common.h | 31 | ||||
| -rw-r--r-- | src/w32console.c | 12 | ||||
| -rw-r--r-- | src/w32cygwinx.c | 135 | ||||
| -rw-r--r-- | src/w32fns.c | 956 | ||||
| -rw-r--r-- | src/w32font.c | 51 | ||||
| -rw-r--r-- | src/w32heap.c | 6 | ||||
| -rw-r--r-- | src/w32inevt.c | 8 | ||||
| -rw-r--r-- | src/w32menu.c | 17 | ||||
| -rw-r--r-- | src/w32notify.c | 17 | ||||
| -rw-r--r-- | src/w32proc.c | 118 | ||||
| -rw-r--r-- | src/w32reg.c | 8 | ||||
| -rw-r--r-- | src/w32select.c | 56 | ||||
| -rw-r--r-- | src/w32term.c | 133 | ||||
| -rw-r--r-- | src/w32term.h | 6 | ||||
| -rw-r--r-- | src/w32uniscribe.c | 19 | ||||
| -rw-r--r-- | src/widget.c | 10 | ||||
| -rw-r--r-- | src/window.c | 583 | ||||
| -rw-r--r-- | src/window.h | 13 | ||||
| -rw-r--r-- | src/xdisp.c | 979 | ||||
| -rw-r--r-- | src/xfaces.c | 487 | ||||
| -rw-r--r-- | src/xfns.c | 593 | ||||
| -rw-r--r-- | src/xfont.c | 26 | ||||
| -rw-r--r-- | src/xftfont.c | 28 | ||||
| -rw-r--r-- | src/xmenu.c | 58 | ||||
| -rw-r--r-- | src/xml.c | 50 | ||||
| -rw-r--r-- | src/xrdb.c | 60 | ||||
| -rw-r--r-- | src/xselect.c | 87 | ||||
| -rw-r--r-- | src/xsettings.c | 2 | ||||
| -rw-r--r-- | src/xterm.c | 194 | ||||
| -rw-r--r-- | src/xterm.h | 4 | ||||
| -rw-r--r-- | src/xwidget.c | 148 | ||||
| -rw-r--r-- | src/xwidget.h | 11 |
158 files changed, 22843 insertions, 16357 deletions
diff --git a/src/.gdbinit b/src/.gdbinit index 59534417905..7553f07845c 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -49,7 +49,7 @@ define xgetptr else set $bugfix = $arg0 end - set $ptr = $bugfix & VALMASK + set $ptr = (EMACS_INT) $bugfix & VALMASK end define xgetint @@ -58,7 +58,7 @@ define xgetint else set $bugfix = $arg0 end - set $int = $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS + set $int = (EMACS_INT) $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS end define xgettype @@ -67,7 +67,7 @@ define xgettype else set $bugfix = $arg0 end - set $type = (enum Lisp_Type) (USE_LSB_TAG ? $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS) + set $type = (enum Lisp_Type) (USE_LSB_TAG ? (EMACS_INT) $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS) end define xgetsym @@ -119,6 +119,12 @@ Print the value of the lisp variable given as argument. Works only when an inferior emacs is executing. end +# Format the value and print it as a string. Works in +# an rr session and during live debugging. Calls into lisp. +define xfmt + printf "%s\n", debug_format("%S", $arg0) +end + # Print out current buffer point and boundaries define ppt set $b = current_buffer @@ -643,17 +649,13 @@ define xtype xgettype $ output $type echo \n - if $type == Lisp_Misc - xmisctype - else - if $type == Lisp_Vectorlike - xvectype - end + if $type == Lisp_Vectorlike + xvectype end end document xtype Print the type of $, assuming it is an Emacs Lisp value. -If the first type printed is Lisp_Vector or Lisp_Misc, +If the first type printed is Lisp_Vectorlike, a second line gives the more precise type. end @@ -705,15 +707,6 @@ Print the size of $ This command assumes that $ is a Lisp_Object. end -define xmisctype - xgetptr $ - output (enum Lisp_Misc_Type) (((struct Lisp_Free *) $ptr)->type) - echo \n -end -document xmisctype -Assume that $ is some misc type and print its specific type. -end - define xint xgetint $ print $int @@ -748,15 +741,6 @@ Print $ as a overlay pointer. This command assumes that $ is an Emacs Lisp overlay value. end -define xmiscfree - xgetptr $ - print (struct Lisp_Free *) $ptr -end -document xmiscfree -Print $ as a misc free-cell pointer. -This command assumes that $ is an Emacs Lisp Misc value. -end - define xsymbol set $sym = $ xgetsym $sym @@ -819,6 +803,7 @@ define xcompiled xgetptr $ print (struct Lisp_Vector *) $ptr output ($->contents[0])@($->header.size & 0xff) + echo \n end document xcompiled Print $ as a compiled function pointer. @@ -1008,21 +993,6 @@ define xpr if $type == Lisp_Float xfloat end - if $type == Lisp_Misc - set $misc = (enum Lisp_Misc_Type) (((struct Lisp_Free *) $ptr)->type) - if $misc == Lisp_Misc_Free - xmiscfree - end - if $misc == Lisp_Misc_Marker - xmarker - end - if $misc == Lisp_Misc_Overlay - xoverlay - end -# if $misc == Lisp_Misc_Save_Value -# xsavevalue -# end - end if $type == Lisp_Vectorlike set $size = ((struct Lisp_Vector *) $ptr)->header.size if ($size & PSEUDOVECTOR_FLAG) @@ -1030,6 +1000,12 @@ define xpr if $vec == PVEC_NORMAL_VECTOR xvector end + if $vec == PVEC_MARKER + xmarker + end + if $vec == PVEC_OVERLAY + xoverlay + end if $vec == PVEC_PROCESS xprocess end @@ -1270,6 +1246,12 @@ end python +# Python 3 compatibility. +try: + long +except: + long = int + # Omit pretty-printing in older (pre-7.3) GDBs that lack it. if hasattr(gdb, 'printing'): @@ -1306,13 +1288,13 @@ if hasattr(gdb, 'printing'): # symbol table, guess reasonable defaults. sym = gdb.lookup_symbol ("EMACS_INT_WIDTH")[0] if sym: - EMACS_INT_WIDTH = int (sym.value ()) + EMACS_INT_WIDTH = long (sym.value ()) else: sym = gdb.lookup_symbol ("EMACS_INT")[0] EMACS_INT_WIDTH = 8 * sym.type.sizeof sym = gdb.lookup_symbol ("USE_LSB_TAG")[0] if sym: - USE_LSB_TAG = int (sym.value ()) + USE_LSB_TAG = long (sym.value ()) else: USE_LSB_TAG = 1 @@ -1321,19 +1303,26 @@ if hasattr(gdb, 'printing'): Lisp_Int0 = 2 Lisp_Int1 = 6 if USE_LSB_TAG else 3 - # Unpack the Lisp value from its containing structure, if necessary. val = self.val basic_type = gdb.types.get_basic_type (val.type) + + # Unpack VAL from its containing structure, if necessary. if (basic_type.code == gdb.TYPE_CODE_STRUCT and gdb.types.has_field (basic_type, "i")): val = val["i"] + # Convert VAL to a Python integer. Convert by hand, as this is + # simpler and works regardless of whether VAL is a pointer or + # integer. Also, val.cast (gdb.lookup.type ("EMACS_UINT")) + # would have problems with GDB 7.12.1; see + # <http://patchwork.sourceware.org/patch/11557/>. + ival = long (val) + # For nil, yield "XIL(0)", which is easier to read than "XIL(0x0)". - if not val: + if not ival: return "XIL(0)" # Extract the integer representation of the value and its Lisp type. - ival = int(val) itype = ival >> (0 if USE_LSB_TAG else VALBITS) itype = itype & ((1 << GCTYPEBITS) - 1) @@ -1341,7 +1330,7 @@ if hasattr(gdb, 'printing'): if itype == Lisp_Int0 or itype == Lisp_Int1: if USE_LSB_TAG: ival = ival >> (GCTYPEBITS - 1) - elif (ival >> VALBITS) & 1: + if (ival >> VALBITS) & 1: ival = ival | (-1 << VALBITS) else: ival = ival & ((1 << VALBITS) - 1) @@ -1352,8 +1341,7 @@ if hasattr(gdb, 'printing'): # integers even when Lisp_Object is an integer. # Perhaps some day the pretty-printing could be fancier. # Prefer the unsigned representation to negative values, converting - # by hand as val.cast(gdb.lookup_type("EMACS_UINT") does not work in - # GDB 7.12.1; see <http://patchwork.sourceware.org/patch/11557/>. + # by hand as val.cast does not work in GDB 7.12.1 as noted above. if ival < 0: ival = ival + (1 << EMACS_INT_WIDTH) return "XIL(0x%x)" % ival diff --git a/src/Makefile.in b/src/Makefile.in index 5989ab4ceff..e9831e92995 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -104,7 +104,7 @@ LD_SWITCH_SYSTEM_TEMACS=@LD_SWITCH_SYSTEM_TEMACS@ ## Flags to pass to ld only for temacs. TEMACS_LDFLAGS = $(LD_SWITCH_SYSTEM) $(LD_SWITCH_SYSTEM_TEMACS) -## If available, the names of the paxctl and setfattr programs. +## If needed, the names of the paxctl and setfattr programs. ## On grsecurity/PaX systems, unexec will fail due to a gap between ## the bss section and the heap. Older versions need paxctl to work ## around this, newer ones setfattr. See Bug#11398 and Bug#16343. @@ -141,7 +141,6 @@ M17N_FLT_LIBS = @M17N_FLT_LIBS@ LIB_ACL=@LIB_ACL@ LIB_CLOCK_GETTIME=@LIB_CLOCK_GETTIME@ LIB_EACCESS=@LIB_EACCESS@ -LIB_FDATASYNC=@LIB_FDATASYNC@ LIB_TIMER_TIME=@LIB_TIMER_TIME@ DBUS_CFLAGS = @DBUS_CFLAGS@ @@ -234,7 +233,8 @@ LIBXML2_CFLAGS = @LIBXML2_CFLAGS@ GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@ -LIBLCMS2 = @LIBLCMS2@ +LCMS2_LIBS = @LCMS2_LIBS@ +LCMS2_CFLAGS = @LCMS2_CFLAGS@ LIBZ = @LIBZ@ @@ -277,11 +277,12 @@ NS_OBJC_OBJ=@NS_OBJC_OBJ@ ## Used only for GNUstep. GNU_OBJC_CFLAGS=$(patsubst -specs=%-hardened-cc1,,@GNU_OBJC_CFLAGS@) ## w32fns.o w32menu.c w32reg.o fringe.o fontset.o w32font.o w32term.o -## w32xfns.o w32select.o image.o w32uniscribe.o if HAVE_W32, else -## empty. +## w32xfns.o w32select.o image.o w32uniscribe.o w32cygwinx.o if HAVE_W32, +## w32cygwinx.o if CYGWIN but not HAVE_W32, else empty. W32_OBJ=@W32_OBJ@ ## -lkernel32 -luser32 -lusp10 -lgdi32 -lole32 -lcomdlg32 -lcomctl32 -## --lwinspool if HAVE_W32, else empty. +## -lwinspool if HAVE_W32, +## -lkernel32 if CYGWIN but not HAVE_W32, else empty. W32_LIBS=@W32_LIBS@ ## emacs.res if HAVE_W32 @@ -312,10 +313,17 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@ LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ +JSON_LIBS = @JSON_LIBS@ +JSON_CFLAGS = @JSON_CFLAGS@ +JSON_OBJ = @JSON_OBJ@ + INTERVALS_H = dispextern.h intervals.h composite.h GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ +GMP_LIB = @GMP_LIB@ +GMP_OBJ = @GMP_OBJ@ + RUN_TEMACS = ./temacs # Whether builds should contain details. '--no-build-details' or empty. @@ -360,10 +368,10 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \ $(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(DBUS_CFLAGS) \ $(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \ - $(WEBKIT_CFLAGS) \ + $(WEBKIT_CFLAGS) $(LCMS2_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ - $(LIBSYSTEMD_CFLAGS) \ + $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ $(WERROR_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) @@ -383,21 +391,21 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ charset.o coding.o category.o ccl.o character.o chartab.o bidi.o \ $(CM_OBJ) term.o terminal.o xfaces.o $(XOBJ) $(GTK_OBJ) $(DBUS_OBJ) \ emacs.o keyboard.o macros.o keymap.o sysdep.o \ - buffer.o filelock.o insdel.o marker.o \ + bignum.o buffer.o filelock.o insdel.o marker.o \ minibuf.o fileio.o dired.o \ - cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \ + cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o data.o doc.o editfns.o callint.o \ eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ syntax.o $(UNEXEC_OBJ) bytecode.o \ process.o gnutls.o callproc.o \ - region-cache.o sound.o atimer.o \ + region-cache.o sound.o timefns.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o lcms.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) + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) $(GMP_OBJ) obj = $(base_obj) $(NS_OBJC_OBJ) ## Object files used on some machine or other. @@ -408,7 +416,7 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ xterm.o xfns.o xmenu.o xselect.o xrdb.o xsmfns.o fringe.o image.o \ fontset.o dbusbind.o cygw32.o \ nsterm.o nsfns.o nsmenu.o nsselect.o nsimage.o nsfont.o macfont.o \ - w32.o w32console.o w32fns.o w32heap.o w32inevt.o w32notify.o \ + w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.o \ w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \ w16select.o widget.o xfont.o ftfont.o xftfont.o ftxfont.o gtkutil.o \ xsettings.o xgselect.o termcap.o @@ -436,6 +444,10 @@ otherobj= $(TERMCAP_OBJ) $(PRE_ALLOC_OBJ) $(GMALLOC_OBJ) $(RALLOC_OBJ) \ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj) +# Must be first, before dep inclusion! +all: emacs$(EXEEXT) $(OTHER_FILES) +.PHONY: all + AUTO_DEPEND = @AUTO_DEPEND@ DEPDIR = deps ifeq ($(AUTO_DEPEND),yes) @@ -446,9 +458,6 @@ else include $(srcdir)/deps.mk endif -all: emacs$(EXEEXT) $(OTHER_FILES) -.PHONY: all - ## This is the list of all Lisp files that might be loaded into the ## dumped Emacs. Some of them are not loaded on all platforms, but ## the DOC file on every platform uses them (because the DOC file is @@ -486,14 +495,15 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(LIBX_OTHER) $(LIBSOUND) \ $(RSVG_LIBS) $(IMAGEMAGICK_LIBS) $(LIB_ACL) $(LIB_CLOCK_GETTIME) \ $(WEBKIT_LIBS) \ - $(LIB_EACCESS) $(LIB_FDATASYNC) $(LIB_TIMER_TIME) $(DBUS_LIBS) \ + $(LIB_EACCESS) $(LIB_TIMER_TIME) $(DBUS_LIBS) \ $(LIB_EXECINFO) $(XRANDR_LIBS) $(XINERAMA_LIBS) $(XFIXES_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) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ - $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) + $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ + $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ + $(JSON_LIBS) $(GMP_LIB) ## FORCE it so that admin/unidata can decide whether these files ## are up-to-date. Although since charprop depends on bootstrap-emacs, @@ -534,7 +544,6 @@ emacs$(EXEEXT): temacs$(EXEEXT) \ ifeq ($(CANNOT_DUMP),yes) ln -f temacs$(EXEEXT) $@ else - unset EMACS_HEAP_EXEC; \ LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup dump ifneq ($(PAXCTL_dumped),) $(PAXCTL_dumped) $@ @@ -635,12 +644,12 @@ ns-app: emacs$(EXEEXT) .PHONY: versionclean extraclean mostlyclean: - rm -f temacs$(EXEEXT) core *.core \#* *.o + rm -f temacs$(EXEEXT) core ./*.core \#* ./*.o rm -f ../etc/DOC rm -f bootstrap-emacs$(EXEEXT) emacs-$(version)$(EXEEXT) rm -f buildobj.h rm -f globals.h gl-stamp - rm -f *.res *.tmp + rm -f ./*.res ./*.tmp clean: mostlyclean rm -f emacs-*.*.*[0-9]$(EXEEXT) emacs$(EXEEXT) $(DEPDIR)/* @@ -664,7 +673,7 @@ maintainer-clean: distclean versionclean: -rm -f emacs$(EXEEXT) emacs-*.*.*[0-9]$(EXEEXT) ../etc/DOC* extraclean: distclean - -rm -f *~ \#* + -rm -f ./*~ \#* ETAGS = ../lib-src/etags${EXEEXT} @@ -740,7 +749,6 @@ bootstrap-emacs$(EXEEXT): temacs$(EXEEXT) ifeq ($(CANNOT_DUMP),yes) ln -f temacs$(EXEEXT) $@ else - unset EMACS_HEAP_EXEC; \ $(RUN_TEMACS) --batch $(BUILD_DETAILS) --load loadup bootstrap ifneq ($(PAXCTL_dumped),) $(PAXCTL_dumped) emacs$(EXEEXT) @@ -749,3 +757,8 @@ else endif @: Compile some files earlier to speed up further compilation. $(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)" + +### Flymake support (for C only) +check-syntax: + $(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) ${CHK_SOURCES} || true +.PHONY: check-syntax diff --git a/src/alloc.c b/src/alloc.c index 6fd78188a0c..70e417e9f88 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -31,8 +31,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #endif #include "lisp.h" +#include "bignum.h" #include "dispextern.h" #include "intervals.h" +#include "ptr-bounds.h" #include "puresize.h" #include "sheap.h" #include "systime.h" @@ -103,7 +105,7 @@ static bool valgrind_p; #include "w32heap.h" /* for sbrk */ #endif -#ifdef GNU_LINUX +#if defined GNU_LINUX && !defined CANNOT_DUMP /* The address where the heap starts. */ void * my_heap_start (void) @@ -171,6 +173,7 @@ malloc_initialize_hook (void) /* Declare the malloc initialization hook, which runs before 'main' starts. EXTERNALLY_VISIBLE works around Bug#22522. */ +typedef void (*voidfuncptr) (void); # ifndef __MALLOC_HOOK_VOLATILE # define __MALLOC_HOOK_VOLATILE # endif @@ -245,8 +248,8 @@ bool gc_in_progress; /* Number of live and free conses etc. */ -static EMACS_INT total_conses, total_markers, total_symbols, total_buffers; -static EMACS_INT total_free_conses, total_free_markers, total_free_symbols; +static EMACS_INT total_conses, total_symbols, total_buffers; +static EMACS_INT total_free_conses, total_free_symbols; static EMACS_INT total_free_floats, total_floats; /* Points to memory space allocated as "spare", to be freed if we run @@ -354,6 +357,7 @@ no_sanitize_memcpy (void *dest, void const *src, size_t size) #endif /* MAX_SAVE_STACK > 0 */ +static void unchain_finalizer (struct Lisp_Finalizer *); static void mark_terminals (void); static void gc_sweep (void); static Lisp_Object make_pure_vector (ptrdiff_t); @@ -376,7 +380,6 @@ enum mem_type MEM_TYPE_BUFFER, MEM_TYPE_CONS, MEM_TYPE_STRING, - MEM_TYPE_MISC, MEM_TYPE_SYMBOL, MEM_TYPE_FLOAT, /* Since all non-bool pseudovectors are small enough to be @@ -502,30 +505,36 @@ pointer_align (void *ptr, int alignment) return (void *) ROUNDUP ((uintptr_t) ptr, alignment); } -/* Extract the pointer hidden within A, if A is not a symbol. - If A is a symbol, extract the hidden pointer's offset from lispsym, - converted to void *. */ - -#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \ - ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK)) - -/* Extract the pointer hidden within A. */ +/* Define PNTR_ADD and XPNTR as functions, which are cleaner and can + be used in debuggers. Also, define them as macros if + DEFINE_KEY_OPS_AS_MACROS, for performance in that case. + The macro_* macros are private to this section of code. */ -#define macro_XPNTR(a) \ - ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \ - + (SYMBOLP (a) ? (char *) lispsym : NULL))) +/* Add a pointer P to an integer I without gcc -fsanitize complaining + about the result being out of range of the underlying array. */ -/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as - functions, as functions are cleaner and can be used in debuggers. - Also, define them as macros if being compiled with GCC without - optimization, for performance in that case. The macro_* names are - private to this section of code. */ +#define macro_PNTR_ADD(p, i) ((p) + (i)) -static ATTRIBUTE_UNUSED void * -XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a) +static ATTRIBUTE_NO_SANITIZE_UNDEFINED ATTRIBUTE_UNUSED char * +PNTR_ADD (char *p, EMACS_UINT i) { - return macro_XPNTR_OR_SYMBOL_OFFSET (a); + return macro_PNTR_ADD (p, i); } + +#if DEFINE_KEY_OPS_AS_MACROS +# define PNTR_ADD(p, i) macro_PNTR_ADD (p, i) +#endif + +/* Extract the pointer hidden within O. */ + +#define macro_XPNTR(o) \ + ((void *) \ + (SYMBOLP (o) \ + ? PNTR_ADD ((char *) lispsym, \ + (XLI (o) \ + - ((EMACS_UINT) Lisp_Symbol << (USE_LSB_TAG ? 0 : VALBITS)))) \ + : (char *) XLP (o) - (XLI (o) & ~VALMASK))) + static ATTRIBUTE_UNUSED void * XPNTR (Lisp_Object a) { @@ -533,7 +542,6 @@ XPNTR (Lisp_Object a) } #if DEFINE_KEY_OPS_AS_MACROS -# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a) # define XPNTR(a) macro_XPNTR (a) #endif @@ -627,6 +635,29 @@ buffer_memory_full (ptrdiff_t nbytes) #define COMMON_MULTIPLE(a, b) \ ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b)) +/* LISP_ALIGNMENT is the alignment of Lisp objects. It must be at + least GCALIGNMENT so that pointers can be tagged. It also must be + at least as strict as the alignment of all the C types used to + implement Lisp objects; since pseudovectors can contain any C type, + this is max_align_t. On recent GNU/Linux x86 and x86-64 this can + often waste up to 8 bytes, since alignof (max_align_t) is 16 but + typical vectors need only an alignment of 8. Although shrinking + the alignment to 8 would save memory, it cost a 20% hit to Emacs + CPU performance on Fedora 28 x86-64 when compiled with gcc -m32. */ +enum { LISP_ALIGNMENT = alignof (union { max_align_t x; + GCALIGNED_UNION_MEMBER }) }; +verify (LISP_ALIGNMENT % GCALIGNMENT == 0); + +/* True if malloc (N) is known to return storage suitably aligned for + Lisp objects whenever N is a multiple of LISP_ALIGNMENT. In + practice this is true whenever alignof (max_align_t) is also a + multiple of LISP_ALIGNMENT. This works even for x86, where some + platform combinations (e.g., GCC 7 and later, glibc 2.25 and + earlier) have bugs where alignof (max_align_t) is 16 even though + the malloc alignment is only 8, and where Emacs still works because + it never does anything that requires an alignment of 16. */ +enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 }; + #ifndef XMALLOC_OVERRUN_CHECK #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0 #else @@ -647,18 +678,13 @@ buffer_memory_full (ptrdiff_t nbytes) #define XMALLOC_OVERRUN_CHECK_OVERHEAD \ (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE) -#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) \ - / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \ + + LISP_ALIGNMENT - 1) \ + / LISP_ALIGNMENT * LISP_ALIGNMENT) \ - XMALLOC_OVERRUN_CHECK_SIZE) static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] = @@ -1140,11 +1166,10 @@ lisp_free (void *block) 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. */ + Aligned allocation is incompatible with unexmacosx.c, so don't use + it on Darwin unless CANNOT_DUMP. */ -#if ! ADDRESS_SANITIZER && !defined DARWIN_OS +#if !defined DARWIN_OS || defined CANNOT_DUMP # if (defined HAVE_ALIGNED_ALLOC \ || (defined HYBRID_MALLOC \ ? defined HAVE_POSIX_MEMALIGN \ @@ -1160,9 +1185,11 @@ aligned_alloc (size_t alignment, size_t size) 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); + verify (MALLOC_IS_LISP_ALIGNED + || (LISP_ALIGNMENT % sizeof (void *) == 0 + && POWER_OF_2 (LISP_ALIGNMENT / sizeof (void *)))); + eassert (alignment == BLOCK_ALIGN + || (!MALLOC_IS_LISP_ALIGNED && alignment == LISP_ALIGNMENT)); void *p; return posix_memalign (&p, alignment, size) == 0 ? p : 0; @@ -1394,31 +1421,15 @@ lisp_align_free (void *block) MALLOC_UNBLOCK_INPUT; } -#if !defined __GNUC__ && !defined __alignof__ -# define __alignof__(type) alignof (type) -#endif - -/* 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 \ - (GCALIGNMENT == 8 && __alignof__ (max_align_t) % GCALIGNMENT == 0) - /* True if a malloc-returned pointer P is suitably aligned for SIZE, - where Lisp alignment may be needed if SIZE is Lisp-aligned. */ + where Lisp object alignment may be needed if SIZE is a multiple of + LISP_ALIGNMENT. */ static bool laligned (void *p, size_t size) { - return (MALLOC_IS_GC_ALIGNED || (intptr_t) p % GCALIGNMENT == 0 - || size % GCALIGNMENT != 0); + return (MALLOC_IS_LISP_ALIGNED || (intptr_t) p % LISP_ALIGNMENT == 0 + || size % LISP_ALIGNMENT != 0); } /* Like malloc and realloc except that if SIZE is Lisp-aligned, make @@ -1440,9 +1451,9 @@ laligned (void *p, size_t size) static void * lmalloc (size_t size) { -#if USE_ALIGNED_ALLOC - if (! MALLOC_IS_GC_ALIGNED && size % GCALIGNMENT == 0) - return aligned_alloc (GCALIGNMENT, size); +#ifdef USE_ALIGNED_ALLOC + if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0) + return aligned_alloc (LISP_ALIGNMENT, size); #endif while (true) @@ -1451,7 +1462,7 @@ lmalloc (size_t size) if (laligned (p, size)) return p; free (p); - size_t bigger = size + GCALIGNMENT; + size_t bigger = size + LISP_ALIGNMENT; if (size < bigger) size = bigger; } @@ -1465,7 +1476,7 @@ lrealloc (void *p, size_t size) p = realloc (p, size); if (laligned (p, size)) return p; - size_t bigger = size + GCALIGNMENT; + size_t bigger = size + LISP_ALIGNMENT; if (size < bigger) size = bigger; } @@ -1737,7 +1748,8 @@ static EMACS_INT total_string_bytes; a pointer to the `u.data' member of its sdata structure; the structure starts at a constant offset in front of that. */ -#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET)) +#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \ + - SDATA_DATA_OFFSET)) #ifdef GC_CHECK_STRING_OVERRUN @@ -1929,7 +1941,7 @@ allocate_string (void) /* Every string on a free list should have NULL data pointer. */ s->u.s.data = NULL; NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); } total_free_strings += STRING_BLOCK_SIZE; @@ -2044,7 +2056,7 @@ allocate_string_data (struct Lisp_String *s, MALLOC_UNBLOCK_INPUT; - s->u.s.data = SDATA_DATA (data); + s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1); #ifdef GC_CHECK_STRING_BYTES SDATA_NBYTES (data) = nbytes; #endif @@ -2130,7 +2142,7 @@ sweep_strings (void) /* Put the string on the free-list. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); ++nfree; } } @@ -2138,7 +2150,7 @@ sweep_strings (void) { /* S was on the free-list before. Put it there again. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); ++nfree; } } @@ -2234,9 +2246,9 @@ compact_small_strings (void) nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from); eassert (nbytes <= LARGE_STRING_BYTES); - nbytes = SDATA_SIZE (nbytes); + ptrdiff_t size = SDATA_SIZE (nbytes); sdata *from_end = (sdata *) ((char *) from - + nbytes + GC_STRING_EXTRA); + + size + GC_STRING_EXTRA); #ifdef GC_CHECK_STRING_OVERRUN if (memcmp (string_overrun_cookie, @@ -2250,22 +2262,23 @@ compact_small_strings (void) { /* If TB is full, proceed with the next sblock. */ sdata *to_end = (sdata *) ((char *) to - + nbytes + GC_STRING_EXTRA); + + size + 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); + to_end = (sdata *) ((char *) to + size + 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->u.s.data = SDATA_DATA (to); + memmove (to, from, size + GC_STRING_EXTRA); + to->string->u.s.data + = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1); } /* Advance past the sdata we copied to. */ @@ -2299,23 +2312,25 @@ string_overflow (void) error ("Maximum string size exceeded"); } -DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, +DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0, doc: /* Return a newly created string of length LENGTH, with INIT in each element. LENGTH must be an integer. -INIT must be an integer that represents a character. */) - (Lisp_Object length, Lisp_Object init) +INIT must be an integer that represents a character. +If optional argument MULTIBYTE is non-nil, the result will be +a multibyte string even if INIT is an ASCII character. */) + (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte) { register Lisp_Object val; int c; EMACS_INT nbytes; - CHECK_NATNUM (length); + CHECK_FIXNAT (length); CHECK_CHARACTER (init); - c = XFASTINT (init); - if (ASCII_CHAR_P (c)) + c = XFIXNAT (init); + if (ASCII_CHAR_P (c) && NILP (multibyte)) { - nbytes = XINT (length); + nbytes = XFIXNUM (length); val = make_uninit_string (nbytes); if (nbytes) { @@ -2327,7 +2342,7 @@ INIT must be an integer that represents a character. */) { unsigned char str[MAX_MULTIBYTE_LENGTH]; ptrdiff_t len = CHAR_STRING (c, str); - EMACS_INT string_len = XINT (length); + EMACS_INT string_len = XFIXNUM (length); unsigned char *p, *beg, *end; if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes)) @@ -2383,6 +2398,8 @@ make_uninit_bool_vector (EMACS_INT nbits) EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes + word_size - 1) / word_size); + if (PTRDIFF_MAX < needed_elements) + memory_full (SIZE_MAX); struct Lisp_Bool_Vector *p = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements); XSETVECTOR (val, p); @@ -2403,8 +2420,8 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */) { Lisp_Object val; - CHECK_NATNUM (length); - val = make_uninit_bool_vector (XFASTINT (length)); + CHECK_FIXNAT (length); + val = make_uninit_bool_vector (XFIXNAT (length)); return bool_vector_fill (val, init); } @@ -2878,9 +2895,9 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, (Lisp_Object length, Lisp_Object init) { Lisp_Object val = Qnil; - CHECK_NATNUM (length); + CHECK_FIXNAT (length); - for (EMACS_INT size = XFASTINT (length); 0 < size; size--) + for (EMACS_INT size = XFIXNAT (length); 0 < size; size--) { val = Fcons (init, val); rarely_quit (size); @@ -2903,7 +2920,7 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, static struct Lisp_Vector * next_vector (struct Lisp_Vector *v) { - return XUNTAG (v->contents[0], Lisp_Int0); + return XUNTAG (v->contents[0], Lisp_Int0, struct Lisp_Vector); } static void @@ -2916,18 +2933,10 @@ set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p) for the most common cases; it's not required to be a power of two, but it's expected to be a mult-of-ROUNDUP_SIZE (see below). */ -#define VECTOR_BLOCK_SIZE 4096 - -/* Alignment of struct Lisp_Vector objects. Because pseudovectors - can contain any C type, align at least as strictly as - max_align_t. On x86 and x86-64 this can waste up to 8 bytes - for typical vectors, since alignof (max_align_t) is 16 but - typical vectors need only an alignment of 8. However, it is - not worth the hassle to avoid wasting those bytes. */ -enum {vector_alignment = COMMON_MULTIPLE (alignof (max_align_t), GCALIGNMENT)}; +enum { VECTOR_BLOCK_SIZE = 4096 }; /* Vector size requests are a multiple of this. */ -enum { roundup_size = COMMON_MULTIPLE (vector_alignment, word_size) }; +enum { roundup_size = COMMON_MULTIPLE (LISP_ALIGNMENT, word_size) }; /* Verify assumptions described above. */ verify (VECTOR_BLOCK_SIZE % roundup_size == 0); @@ -2940,22 +2949,21 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS)); /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */ -#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))) +enum {VECTOR_BLOCK_BYTES = VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))}; /* Size of the minimal vector allocated from block. */ -#define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object)) +enum { VBLOCK_BYTES_MIN = vroundup_ct (header_size + sizeof (Lisp_Object)) }; /* Size of the largest vector allocated from block. */ -#define VBLOCK_BYTES_MAX \ - vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size) +enum { VBLOCK_BYTES_MAX = vroundup_ct ((VECTOR_BLOCK_BYTES / 2) - word_size) }; /* We maintain one free list for each possible block-allocated vector size, and this is the number of free lists we have. */ -#define VECTOR_MAX_FREE_LIST_INDEX \ - ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1) +enum { VECTOR_MAX_FREE_LIST_INDEX = + (VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1 }; /* Common shortcut to advance vector pointer over a block data. */ @@ -2994,7 +3002,7 @@ struct large_vector enum { - large_vector_offset = ROUNDUP (sizeof (struct large_vector), vector_alignment) + large_vector_offset = ROUNDUP (sizeof (struct large_vector), LISP_ALIGNMENT) }; static struct Lisp_Vector * @@ -3042,6 +3050,7 @@ static EMACS_INT total_vector_slots, total_free_vector_slots; static void setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) { + v = ptr_bounds_clip (v, nbytes); eassume (header_size <= nbytes); ptrdiff_t nwords = (nbytes - header_size) / word_size; XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords); @@ -3081,14 +3090,14 @@ init_vectors (void) /* Allocate vector from a vector block. */ static struct Lisp_Vector * -allocate_vector_from_block (size_t nbytes) +allocate_vector_from_block (ptrdiff_t nbytes) { struct Lisp_Vector *vector; struct vector_block *block; size_t index, restbytes; - eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX); - eassert (nbytes % roundup_size == 0); + eassume (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX); + eassume (nbytes % roundup_size == 0); /* First, try to allocate from a free list containing vectors of the requested size. */ @@ -3173,35 +3182,63 @@ vector_nbytes (struct Lisp_Vector *v) return vroundup (header_size + word_size * nwords); } +/* Convert a pseudovector pointer P to its underlying struct T pointer. + Verify that the struct is small, since cleanup_vector is called + only on small vector-like objects. */ + +#define PSEUDOVEC_STRUCT(p, t) \ + verify_expr ((header_size + VECSIZE (struct t) * word_size \ + <= VBLOCK_BYTES_MAX), \ + (struct t *) (p)) + /* Release extra resources still in use by VECTOR, which may be any - vector-like object. */ + small vector-like object. */ static void cleanup_vector (struct Lisp_Vector *vector) { detect_suspicious_free (vector); - if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT) - && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) - == FONT_OBJECT_MAX)) - { - 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. */ - if (drv) + if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BIGNUM)) + mpz_clear (PSEUDOVEC_STRUCT (vector, Lisp_Bignum)->value); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FINALIZER)) + unchain_finalizer (PSEUDOVEC_STRUCT (vector, Lisp_Finalizer)); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT)) + { + if ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX) { - /* Attempt to catch subtle bugs like Bug#16140. */ - eassert (valid_font_driver (drv)); - drv->close ((struct font *) vector); + struct font *font = PSEUDOVEC_STRUCT (vector, font); + struct font_driver const *drv = font->driver; + + /* The font driver might sometimes be NULL, e.g. if Emacs was + interrupted before it had time to set it up. */ + if (drv) + { + /* Attempt to catch subtle bugs like Bug#16140. */ + eassert (valid_font_driver (drv)); + drv->close (font); + } } } - - if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) - finalize_one_thread ((struct thread_state *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) + finalize_one_thread (PSEUDOVEC_STRUCT (vector, thread_state)); else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) - finalize_one_mutex ((struct Lisp_Mutex *) vector); + finalize_one_mutex (PSEUDOVEC_STRUCT (vector, Lisp_Mutex)); else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR)) - finalize_one_condvar ((struct Lisp_CondVar *) vector); + finalize_one_condvar (PSEUDOVEC_STRUCT (vector, Lisp_CondVar)); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MARKER)) + { + /* sweep_buffer should already have unchained this from its buffer. */ + eassert (! PSEUDOVEC_STRUCT (vector, Lisp_Marker)->buffer); + } +#ifdef HAVE_MODULES + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_USER_PTR)) + { + struct Lisp_User_Ptr *uptr = PSEUDOVEC_STRUCT (vector, Lisp_User_Ptr); + if (uptr->finalizer) + uptr->finalizer (uptr->p); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -3221,8 +3258,7 @@ sweep_vectors (void) for (block = vector_blocks; block; block = *bprev) { - bool free_this_block = 0; - ptrdiff_t nbytes; + bool free_this_block = false; for (vector = (struct Lisp_Vector *) block->data; VECTOR_IN_BLOCK (vector, block); vector = next) @@ -3231,31 +3267,26 @@ sweep_vectors (void) { VECTOR_UNMARK (vector); total_vectors++; - nbytes = vector_nbytes (vector); + ptrdiff_t nbytes = vector_nbytes (vector); total_vector_slots += nbytes / word_size; next = ADVANCE (vector, nbytes); } else { - ptrdiff_t total_bytes; - - cleanup_vector (vector); - nbytes = vector_nbytes (vector); - total_bytes = nbytes; - next = ADVANCE (vector, nbytes); + ptrdiff_t total_bytes = 0; /* While NEXT is not marked, try to coalesce with VECTOR, thus making VECTOR of the largest possible size. */ - while (VECTOR_IN_BLOCK (next, block)) + next = vector; + do { - if (VECTOR_MARKED_P (next)) - break; cleanup_vector (next); - nbytes = vector_nbytes (next); + ptrdiff_t nbytes = vector_nbytes (next); total_bytes += nbytes; next = ADVANCE (next, nbytes); } + while (VECTOR_IN_BLOCK (next, block) && !VECTOR_MARKED_P (next)); eassert (total_bytes % roundup_size == 0); @@ -3263,7 +3294,7 @@ sweep_vectors (void) && !VECTOR_IN_BLOCK (next, block)) /* This block should be freed because all of its space was coalesced into the only free vector. */ - free_this_block = 1; + free_this_block = true; else setup_on_free_list (vector, total_bytes); } @@ -3305,71 +3336,72 @@ sweep_vectors (void) } } +/* Maximum number of elements in a vector. This is a macro so that it + can be used in an integer constant expression. */ + +#define VECTOR_ELTS_MAX \ + ((ptrdiff_t) \ + min (((min (PTRDIFF_MAX, SIZE_MAX) - header_size - large_vector_offset) \ + / word_size), \ + MOST_POSITIVE_FIXNUM)) + /* Value is a pointer to a newly allocated Lisp_Vector structure - with room for LEN Lisp_Objects. */ + with room for LEN Lisp_Objects. LEN must be positive and + at most VECTOR_ELTS_MAX. */ static struct Lisp_Vector * allocate_vectorlike (ptrdiff_t len) { + eassert (0 < len && len <= VECTOR_ELTS_MAX); + ptrdiff_t nbytes = header_size + len * word_size; struct Lisp_Vector *p; MALLOC_BLOCK_INPUT; - if (len == 0) - p = XVECTOR (zero_vector); - else - { - size_t nbytes = header_size + len * word_size; - #ifdef DOUG_LEA_MALLOC - if (!mmap_lisp_allowed_p ()) - mallopt (M_MMAP_MAX, 0); + if (!mmap_lisp_allowed_p ()) + mallopt (M_MMAP_MAX, 0); #endif - if (nbytes <= VBLOCK_BYTES_MAX) - p = allocate_vector_from_block (vroundup (nbytes)); - else - { - struct large_vector *lv - = lisp_malloc ((large_vector_offset + header_size - + len * word_size), - MEM_TYPE_VECTORLIKE); - lv->next = large_vectors; - large_vectors = lv; - p = large_vector_vec (lv); - } + if (nbytes <= VBLOCK_BYTES_MAX) + p = allocate_vector_from_block (vroundup (nbytes)); + else + { + struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes, + MEM_TYPE_VECTORLIKE); + lv->next = large_vectors; + large_vectors = lv; + p = large_vector_vec (lv); + } #ifdef DOUG_LEA_MALLOC - if (!mmap_lisp_allowed_p ()) - mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); + if (!mmap_lisp_allowed_p ()) + mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); #endif - if (find_suspicious_object_in_range (p, (char *) p + nbytes)) - emacs_abort (); + if (find_suspicious_object_in_range (p, (char *) p + nbytes)) + emacs_abort (); - consing_since_gc += nbytes; - vector_cells_consed += len; - } + consing_since_gc += nbytes; + vector_cells_consed += len; MALLOC_UNBLOCK_INPUT; - return p; + return ptr_bounds_clip (p, nbytes); } /* Allocate a vector with LEN slots. */ struct Lisp_Vector * -allocate_vector (EMACS_INT len) +allocate_vector (ptrdiff_t len) { - struct Lisp_Vector *v; - ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX); - - if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len) + if (len == 0) + return XVECTOR (zero_vector); + if (VECTOR_ELTS_MAX < len) memory_full (SIZE_MAX); - v = allocate_vectorlike (len); - if (len) - v->header.size = len; + struct Lisp_Vector *v = allocate_vectorlike (len); + v->header.size = len; return v; } @@ -3380,14 +3412,16 @@ struct Lisp_Vector * allocate_pseudovector (int memlen, int lisplen, int zerolen, enum pvec_type tag) { - struct Lisp_Vector *v = allocate_vectorlike (memlen); - /* Catch bogus values. */ + enum { size_max = (1 << PSEUDOVECTOR_SIZE_BITS) - 1 }; + enum { rest_max = (1 << PSEUDOVECTOR_REST_BITS) - 1 }; + verify (size_max + rest_max <= VECTOR_ELTS_MAX); eassert (0 <= tag && tag <= PVEC_FONT); eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen); - eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1); - eassert (lisplen <= PSEUDOVECTOR_SIZE_MASK); + eassert (lisplen <= size_max); + eassert (memlen <= size_max + rest_max); + struct Lisp_Vector *v = allocate_vectorlike (memlen); /* Only the first LISPLEN slots will be traced normally by the GC. */ memclear (v->contents, zerolen * word_size); XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); @@ -3431,8 +3465,8 @@ symbol or a type descriptor. SLOTS is the number of non-type slots, each initialized to INIT. */) (Lisp_Object type, Lisp_Object slots, Lisp_Object init) { - CHECK_NATNUM (slots); - EMACS_INT size = XFASTINT (slots) + 1; + CHECK_FIXNAT (slots); + EMACS_INT size = XFIXNAT (slots) + 1; struct Lisp_Vector *p = allocate_record (size); p->contents[0] = type; for (ptrdiff_t i = 1; i < size; i++) @@ -3460,9 +3494,18 @@ DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, See also the function `vector'. */) (Lisp_Object length, Lisp_Object init) { - CHECK_NATNUM (length); - struct Lisp_Vector *p = allocate_vector (XFASTINT (length)); - for (ptrdiff_t i = 0; i < XFASTINT (length); i++) + CHECK_TYPE (FIXNATP (length) && XFIXNAT (length) <= PTRDIFF_MAX, + Qwholenump, length); + return make_vector (XFIXNAT (length), init); +} + +/* Return a new vector of length LENGTH with each element being INIT. */ + +Lisp_Object +make_vector (ptrdiff_t length, Lisp_Object init) +{ + struct Lisp_Vector *p = allocate_vector (length); + for (ptrdiff_t i = 0; i < length; i++) p->contents[i] = init; return make_lisp_ptr (p, Lisp_Vectorlike); } @@ -3633,205 +3676,27 @@ Its value is void, and its function definition and property list are nil. */) -/*********************************************************************** - Marker (Misc) Allocation - ***********************************************************************/ - -/* Like union Lisp_Misc, but padded so that its size is a multiple of - the required alignment. */ - -union aligned_Lisp_Misc -{ - union Lisp_Misc m; - unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1) - & -GCALIGNMENT]; -}; - -/* Allocation of markers and other objects that share that structure. - Works like allocation of conses. */ - -#define MARKER_BLOCK_SIZE \ - ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc)) - -struct marker_block -{ - /* Place `markers' first, to preserve alignment. */ - union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE]; - struct marker_block *next; -}; - -static struct marker_block *marker_block; -static int marker_block_index = MARKER_BLOCK_SIZE; - -static union Lisp_Misc *marker_free_list; - -/* Return a newly allocated Lisp_Misc object of specified TYPE. */ - -static Lisp_Object -allocate_misc (enum Lisp_Misc_Type type) -{ - Lisp_Object val; - - MALLOC_BLOCK_INPUT; - - if (marker_free_list) - { - XSETMISC (val, marker_free_list); - marker_free_list = marker_free_list->u_free.chain; - } - else - { - if (marker_block_index == MARKER_BLOCK_SIZE) - { - struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC); - new->next = marker_block; - marker_block = new; - marker_block_index = 0; - total_free_markers += MARKER_BLOCK_SIZE; - } - XSETMISC (val, &marker_block->markers[marker_block_index].m); - marker_block_index++; - } - - MALLOC_UNBLOCK_INPUT; - - --total_free_markers; - consing_since_gc += sizeof (union Lisp_Misc); - misc_objects_consed++; - XMISCANY (val)->type = type; - XMISCANY (val)->gcmarkbit = 0; - return val; -} - -/* Free a Lisp_Misc object. */ - -void -free_misc (Lisp_Object misc) -{ - XMISCANY (misc)->type = Lisp_Misc_Free; - XMISC (misc)->u_free.chain = marker_free_list; - marker_free_list = XMISC (misc); - consing_since_gc -= sizeof (union Lisp_Misc); - total_free_markers++; -} - -/* Verify properties of Lisp_Save_Value's representation - that are assumed here and elsewhere. */ - -verify (SAVE_UNUSED == 0); -verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT) - >> SAVE_SLOT_BITS) - == 0); - -/* Return Lisp_Save_Value objects for the various combinations - that callers need. */ - -Lisp_Object -make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_INT_INT_INT; - p->data[0].integer = a; - p->data[1].integer = b; - p->data[2].integer = c; - return val; -} - -Lisp_Object -make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c, - Lisp_Object d) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ; - p->data[0].object = a; - p->data[1].object = b; - p->data[2].object = c; - p->data[3].object = d; - return val; -} - -Lisp_Object -make_save_ptr (void *a) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_POINTER; - p->data[0].pointer = a; - return val; -} - Lisp_Object -make_save_ptr_int (void *a, ptrdiff_t b) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_PTR_INT; - p->data[0].pointer = a; - p->data[1].integer = b; - return val; -} - -Lisp_Object -make_save_ptr_ptr (void *a, void *b) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_PTR_PTR; - p->data[0].pointer = a; - p->data[1].pointer = b; - return val; -} - -Lisp_Object -make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ; - p->data[0].funcpointer = a; - p->data[1].pointer = b; - p->data[2].object = c; - return val; -} - -/* Return a Lisp_Save_Value object that represents an array A - of N Lisp objects. */ - -Lisp_Object -make_save_memory (Lisp_Object *a, ptrdiff_t n) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_MEMORY; - p->data[0].pointer = a; - p->data[1].integer = n; - return val; -} - -/* Free a Lisp_Save_Value object. Do not use this function - if SAVE contains pointer other than returned by xmalloc. */ - -void -free_save_value (Lisp_Object save) +make_misc_ptr (void *a) { - xfree (XSAVE_POINTER (save, 0)); - free_misc (save); + struct Lisp_Misc_Ptr *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Misc_Ptr, pointer, + PVEC_MISC_PTR); + p->pointer = a; + return make_lisp_ptr (p, Lisp_Vectorlike); } -/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */ +/* Return a new overlay with specified START, END and PLIST. */ Lisp_Object build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist) { - register Lisp_Object overlay; - - overlay = allocate_misc (Lisp_Misc_Overlay); + struct Lisp_Overlay *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Overlay, next, + PVEC_OVERLAY); + Lisp_Object overlay = make_lisp_ptr (p, Lisp_Vectorlike); OVERLAY_START (overlay) = start; OVERLAY_END (overlay) = end; set_overlay_plist (overlay, plist); - XOVERLAY (overlay)->next = NULL; + p->next = NULL; return overlay; } @@ -3839,18 +3704,15 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, doc: /* Return a newly allocated marker which does not point at any place. */) (void) { - register Lisp_Object val; - register struct Lisp_Marker *p; - - val = allocate_misc (Lisp_Misc_Marker); - p = XMARKER (val); + struct Lisp_Marker *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Marker, buffer, + PVEC_MARKER); p->buffer = 0; p->bytepos = 0; p->charpos = 0; p->next = NULL; p->insertion_type = 0; p->need_adjustment = 0; - return val; + return make_lisp_ptr (p, Lisp_Vectorlike); } /* Return a newly allocated marker which points into BUF @@ -3859,17 +3721,14 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, Lisp_Object build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos) { - Lisp_Object obj; - struct Lisp_Marker *m; - /* No dead buffers here. */ eassert (BUFFER_LIVE_P (buf)); /* Every character is at least one byte. */ eassert (charpos <= bytepos); - obj = allocate_misc (Lisp_Misc_Marker); - m = XMARKER (obj); + struct Lisp_Marker *m = ALLOCATE_PSEUDOVECTOR (struct Lisp_Marker, buffer, + PVEC_MARKER); m->buffer = buf; m->charpos = charpos; m->bytepos = bytepos; @@ -3877,7 +3736,7 @@ build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos) m->need_adjustment = 0; m->next = BUF_MARKERS (buf); BUF_MARKERS (buf) = m; - return obj; + return make_lisp_ptr (m, Lisp_Vectorlike); } @@ -3896,8 +3755,8 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) /* The things that fit in a string are characters that are in 0...127, after discarding the meta bit and all the bits above it. */ - if (!INTEGERP (args[i]) - || (XINT (args[i]) & ~(-CHAR_META)) >= 0200) + if (!FIXNUMP (args[i]) + || (XFIXNUM (args[i]) & ~(-CHAR_META)) >= 0200) return Fvector (nargs, args); /* Since the loop exited, we know that all the things in it are @@ -3905,12 +3764,12 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object result; - result = Fmake_string (make_number (nargs), make_number (0)); + result = Fmake_string (make_fixnum (nargs), make_fixnum (0), Qnil); for (i = 0; i < nargs; i++) { - SSET (result, i, XINT (args[i])); + SSET (result, i, XFIXNUM (args[i])); /* Move the meta bit to the right place for a string char. */ - if (XINT (args[i]) & CHAR_META) + if (XFIXNUM (args[i]) & CHAR_META) SSET (result, i, SREF (result, i) | 0x80); } @@ -3923,14 +3782,11 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) Lisp_Object make_user_ptr (void (*finalizer) (void *), void *p) { - Lisp_Object obj; - struct Lisp_User_Ptr *uptr; - - obj = allocate_misc (Lisp_Misc_User_Ptr); - uptr = XUSER_PTR (obj); + struct Lisp_User_Ptr *uptr = ALLOCATE_PSEUDOVECTOR (struct Lisp_User_Ptr, + finalizer, PVEC_USER_PTR); uptr->finalizer = finalizer; uptr->p = p; - return obj; + return make_lisp_ptr (uptr, Lisp_Vectorlike); } #endif @@ -3973,7 +3829,7 @@ mark_finalizer_list (struct Lisp_Finalizer *head) finalizer != head; finalizer = finalizer->next) { - finalizer->base.gcmarkbit = true; + VECTOR_MARK (finalizer); mark_object (finalizer->function); } } @@ -3990,7 +3846,7 @@ queue_doomed_finalizers (struct Lisp_Finalizer *dest, while (finalizer != src) { struct Lisp_Finalizer *next = finalizer->next; - if (!finalizer->base.gcmarkbit && !NILP (finalizer->function)) + if (!VECTOR_MARKED_P (finalizer) && !NILP (finalizer->function)) { unchain_finalizer (finalizer); finalizer_insert (dest, finalizer); @@ -4026,7 +3882,6 @@ run_finalizers (struct Lisp_Finalizer *finalizers) while (finalizers->next != finalizers) { finalizer = finalizers->next; - eassert (finalizer->base.type == Lisp_Misc_Finalizer); unchain_finalizer (finalizer); function = finalizer->function; if (!NILP (function)) @@ -4046,12 +3901,12 @@ count as reachable for the purpose of deciding whether to run FUNCTION. FUNCTION will be run once per finalizer object. */) (Lisp_Object function) { - Lisp_Object val = allocate_misc (Lisp_Misc_Finalizer); - struct Lisp_Finalizer *finalizer = XFINALIZER (val); + struct Lisp_Finalizer *finalizer + = ALLOCATE_PSEUDOVECTOR (struct Lisp_Finalizer, prev, PVEC_FINALIZER); finalizer->function = function; finalizer->prev = finalizer->next = NULL; finalizer_insert (&finalizers, finalizer); - return val; + return make_lisp_ptr (finalizer, Lisp_Vectorlike); } @@ -4561,6 +4416,7 @@ live_string_holding (struct mem_node *m, void *p) must not be on the free-list. */ if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0]) { + cp = ptr_bounds_copy (cp, b); struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; if (s->u.s.data) return make_lisp_ptr (s, Lisp_String); @@ -4595,6 +4451,7 @@ live_cons_holding (struct mem_node *m, void *p) && (b != cons_block || offset / sizeof b->conses[0] < cons_block_index)) { + cp = ptr_bounds_copy (cp, b); struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; if (!EQ (s->u.s.car, Vdead)) return make_lisp_ptr (s, Lisp_Cons); @@ -4630,6 +4487,7 @@ live_symbol_holding (struct mem_node *m, void *p) && (b != symbol_block || offset / sizeof b->symbols[0] < symbol_block_index)) { + cp = ptr_bounds_copy (cp, b); struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; if (!EQ (s->u.s.function, Vdead)) return make_lisp_symbol (s); @@ -4669,40 +4527,6 @@ live_float_p (struct mem_node *m, void *p) return 0; } - -/* If P is a pointer to a live Lisp Misc on the heap, return the object. - Otherwise, return nil. M is a pointer to the mem_block for P. */ - -static Lisp_Object -live_misc_holding (struct mem_node *m, void *p) -{ - if (m->type == MEM_TYPE_MISC) - { - struct marker_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->markers[0]; - - /* P must point into a Lisp_Misc, not be - one of the unused cells in the current misc block, - and not be on the free-list. */ - if (0 <= offset && offset < MARKER_BLOCK_SIZE * sizeof b->markers[0] - && (b != marker_block - || offset / sizeof b->markers[0] < marker_block_index)) - { - union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0]; - if (s->u_any.type != Lisp_Misc_Free) - return make_lisp_ptr (s, Lisp_Misc); - } - } - return Qnil; -} - -static bool -live_misc_p (struct mem_node *m, void *p) -{ - return !NILP (live_misc_holding (m, p)); -} - /* If P is a pointer to a live vector-like object, return the object. Otherwise, return nil. M is a pointer to the mem_block for P. */ @@ -4788,7 +4612,7 @@ mark_maybe_object (Lisp_Object obj) VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); #endif - if (INTEGERP (obj)) + if (FIXNUMP (obj)) return; void *po = XPNTR (obj); @@ -4821,10 +4645,6 @@ mark_maybe_object (Lisp_Object obj) || EQ (obj, live_buffer_holding (m, po))); break; - case Lisp_Misc: - mark_p = EQ (obj, live_misc_holding (m, po)); - break; - default: break; } @@ -4834,14 +4654,23 @@ mark_maybe_object (Lisp_Object obj) } } -/* Return true if P can point to Lisp data, and false otherwise. +void +mark_maybe_objects (Lisp_Object *array, ptrdiff_t nelts) +{ + for (Lisp_Object *lim = array + nelts; array < lim; array++) + mark_maybe_object (*array); +} + +/* Return true if P might point to Lisp data that can be garbage + collected, and false otherwise (i.e., false if it is easy to see + that P cannot point to Lisp data that can be garbage collected). Symbols are implemented via offsets not pointers, but the offsets - are also multiples of GCALIGNMENT. */ + are also multiples of LISP_ALIGNMENT. */ static bool maybe_lisp_pointer (void *p) { - return (uintptr_t) p % GCALIGNMENT == 0; + return (uintptr_t) p % LISP_ALIGNMENT == 0; } #ifndef HAVE_MODULES @@ -4870,7 +4699,7 @@ mark_maybe_pointer (void *p) { /* For the wide-int case, also mark emacs_value tagged pointers, which can be generated by emacs-module.c's value_to_lisp. */ - p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 1)); + p = (void *) ((uintptr_t) p & ~((1 << GCTYPEBITS) - 1)); } m = mem_find (p); @@ -4897,10 +4726,6 @@ mark_maybe_pointer (void *p) obj = live_string_holding (m, p); break; - case MEM_TYPE_MISC: - obj = live_misc_holding (m, p); - break; - case MEM_TYPE_SYMBOL: obj = live_symbol_holding (m, p); break; @@ -5253,15 +5078,13 @@ valid_pointer_p (void *p) /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we - cannot validate OBJ. This function can be quite slow, so its primary - use is the manual debugging. The only exception is print_object, where - we use it to check whether the memory referenced by the pointer of - Lisp_Save_Value object contains valid objects. */ + cannot validate OBJ. This function can be quite slow, and is used + only in debugging. */ int valid_lisp_object_p (Lisp_Object obj) { - if (INTEGERP (obj)) + if (FIXNUMP (obj)) return 1; void *p = XPNTR (obj); @@ -5303,9 +5126,6 @@ valid_lisp_object_p (Lisp_Object obj) case MEM_TYPE_STRING: return live_string_p (m, p); - case MEM_TYPE_MISC: - return live_misc_p (m, p); - case MEM_TYPE_SYMBOL: return live_symbol_p (m, p); @@ -5341,7 +5161,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 = pointer_align (purebeg + pure_bytes_used_lisp, GCALIGNMENT); + result = pointer_align (purebeg + pure_bytes_used_lisp, LISP_ALIGNMENT); pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size; } else @@ -5354,7 +5174,7 @@ pure_alloc (size_t size, int type) pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; if (pure_bytes_used <= pure_size) - return result; + return ptr_bounds_clip (result, size); /* Don't allocate a large amount here, because it might get mmap'd and then its address @@ -5439,7 +5259,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes) /* Check the remaining characters. */ if (memcmp (data, non_lisp_beg + start, nbytes) == 0) /* Found. */ - return non_lisp_beg + start; + return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1); start += last_char_skip; } @@ -5522,6 +5342,32 @@ make_pure_float (double num) return new; } +/* Value is a bignum object with value VALUE allocated from pure + space. */ + +static Lisp_Object +make_pure_bignum (struct Lisp_Bignum *value) +{ + size_t i, nlimbs = mpz_size (value->value); + size_t nbytes = nlimbs * sizeof (mp_limb_t); + mp_limb_t *pure_limbs; + mp_size_t new_size; + + struct Lisp_Bignum *b = pure_alloc (sizeof *b, Lisp_Vectorlike); + XSETPVECTYPESIZE (b, PVEC_BIGNUM, 0, VECSIZE (struct Lisp_Bignum)); + + pure_limbs = pure_alloc (nbytes, -1); + for (i = 0; i < nlimbs; ++i) + pure_limbs[i] = mpz_getlimbn (value->value, i); + + new_size = nlimbs; + if (mpz_sgn (value->value) < 0) + new_size = -new_size; + + mpz_roinit_n (b->value, pure_limbs, new_size); + + return make_lisp_ptr (b, Lisp_Vectorlike); +} /* Return a vector with room for LEN Lisp_Objects allocated from pure space. */ @@ -5594,8 +5440,8 @@ static struct pinned_object static Lisp_Object purecopy (Lisp_Object obj) { - if (INTEGERP (obj) - || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj))) + if (FIXNUMP (obj) + || (! SYMBOLP (obj) && PURE_P (XPNTR (obj))) || SUBRP (obj)) return obj; /* Already pure. */ @@ -5663,6 +5509,8 @@ purecopy (Lisp_Object obj) /* Don't hash-cons it. */ return obj; } + else if (BIGNUMP (obj)) + obj = make_pure_bignum (XBIGNUM (obj)); else { AUTO_STRING (fmt, "Don't know how to purify: %S"); @@ -5704,7 +5552,7 @@ inhibit_garbage_collection (void) { ptrdiff_t count = SPECPDL_INDEX (); - specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM)); + specbind (Qgc_cons_threshold, make_fixnum (MOST_POSITIVE_FIXNUM)); return count; } @@ -5714,7 +5562,7 @@ inhibit_garbage_collection (void) static Lisp_Object bounded_number (EMACS_INT number) { - return make_number (min (MOST_POSITIVE_FIXNUM, number)); + return make_fixnum (min (MOST_POSITIVE_FIXNUM, number)); } /* Calculate total bytes of live objects. */ @@ -5725,7 +5573,6 @@ total_bytes_of_live_objects (void) size_t tot = 0; tot += total_conses * sizeof (struct Lisp_Cons); tot += total_symbols * sizeof (struct Lisp_Symbol); - tot += total_markers * sizeof (union Lisp_Misc); tot += total_string_bytes; tot += total_vector_slots * word_size; tot += total_floats * sizeof (struct Lisp_Float); @@ -5846,7 +5693,7 @@ compact_undo_list (Lisp_Object list) { if (CONSP (XCAR (tail)) && MARKERP (XCAR (XCAR (tail))) - && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit) + && !VECTOR_MARKED_P (XMARKER (XCAR (XCAR (tail))))) *prev = XCDR (tail); else prev = xcdr_addr (tail); @@ -5956,6 +5803,7 @@ garbage_collect_1 (void *end) stack_copy = xrealloc (stack_copy, stack_size); stack_copy_size = stack_size; } + stack = ptr_bounds_set (stack, stack_size); no_sanitize_memcpy (stack_copy, stack, stack_size); } } @@ -6030,6 +5878,8 @@ garbage_collect_1 (void *end) VECTOR_UNMARK (&buffer_defaults); VECTOR_UNMARK (&buffer_local_symbols); + unmark_main_thread (); + check_cons_list (); gc_in_progress = 0; @@ -6066,37 +5916,34 @@ garbage_collect_1 (void *end) unbind_to (count, Qnil); Lisp_Object total[] = { - list4 (Qconses, make_number (sizeof (struct Lisp_Cons)), + list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)), bounded_number (total_conses), bounded_number (total_free_conses)), - list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)), + list4 (Qsymbols, make_fixnum (sizeof (struct Lisp_Symbol)), bounded_number (total_symbols), bounded_number (total_free_symbols)), - list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)), - bounded_number (total_markers), - bounded_number (total_free_markers)), - list4 (Qstrings, make_number (sizeof (struct Lisp_String)), + list4 (Qstrings, make_fixnum (sizeof (struct Lisp_String)), bounded_number (total_strings), bounded_number (total_free_strings)), - list3 (Qstring_bytes, make_number (1), + list3 (Qstring_bytes, make_fixnum (1), bounded_number (total_string_bytes)), list3 (Qvectors, - make_number (header_size + sizeof (Lisp_Object)), + make_fixnum (header_size + sizeof (Lisp_Object)), bounded_number (total_vectors)), - list4 (Qvector_slots, make_number (word_size), + list4 (Qvector_slots, make_fixnum (word_size), bounded_number (total_vector_slots), bounded_number (total_free_vector_slots)), - list4 (Qfloats, make_number (sizeof (struct Lisp_Float)), + list4 (Qfloats, make_fixnum (sizeof (struct Lisp_Float)), bounded_number (total_floats), bounded_number (total_free_floats)), - list4 (Qintervals, make_number (sizeof (struct interval)), + list4 (Qintervals, make_fixnum (sizeof (struct interval)), bounded_number (total_intervals), bounded_number (total_free_intervals)), - list3 (Qbuffers, make_number (sizeof (struct buffer)), + list3 (Qbuffers, make_fixnum (sizeof (struct buffer)), bounded_number (total_buffers)), #ifdef DOUG_LEA_MALLOC - list4 (Qheap, make_number (1024), + list4 (Qheap, make_fixnum (1024), bounded_number ((mallinfo ().uordblks + 1023) >> 10), bounded_number ((mallinfo ().fordblks + 1023) >> 10)), #endif @@ -6185,11 +6032,7 @@ mark_glyph_matrix (struct glyph_matrix *matrix) } } -/* Mark reference to a Lisp_Object. - If the object referred to has not been seen yet, recursively mark - all the references contained in it. */ - -#define LAST_MARKED_SIZE 500 +enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */ Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE; static int last_marked_index; @@ -6235,7 +6078,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype) { Lisp_Object val = ptr->contents[i]; - if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit)) + if (FIXNUMP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit)) continue; if (SUB_CHAR_TABLE_P (val)) { @@ -6265,12 +6108,12 @@ mark_compiled (struct Lisp_Vector *ptr) static void mark_overlay (struct Lisp_Overlay *ptr) { - for (; ptr && !ptr->gcmarkbit; ptr = ptr->next) + for (; ptr && !VECTOR_MARKED_P (ptr); ptr = ptr->next) { - ptr->gcmarkbit = 1; + VECTOR_MARK (ptr); /* These two are always markers and can be marked fast. */ - XMARKER (ptr->start)->gcmarkbit = 1; - XMARKER (ptr->end)->gcmarkbit = 1; + VECTOR_MARK (XMARKER (ptr->start)); + VECTOR_MARK (XMARKER (ptr->end)); mark_object (ptr->plist); } } @@ -6338,30 +6181,6 @@ mark_localized_symbol (struct Lisp_Symbol *ptr) mark_object (blv->defcell); } -NO_INLINE /* To reduce stack depth in mark_object. */ -static void -mark_save_value (struct Lisp_Save_Value *ptr) -{ - /* If `save_type' is zero, `data[0].pointer' is the address - of a memory area containing `data[1].integer' potential - Lisp_Objects. */ - if (ptr->save_type == SAVE_TYPE_MEMORY) - { - Lisp_Object *p = ptr->data[0].pointer; - ptrdiff_t nelt; - for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++) - mark_maybe_object (*p); - } - else - { - /* Find Lisp_Objects in `data[N]' slots and mark them. */ - int i; - for (i = 0; i < SAVE_VALUE_SLOTS; i++) - if (save_type (ptr, i) == SAVE_OBJECT) - mark_object (ptr->data[i].object); - } -} - /* Remove killed buffers or items whose car is a killed buffer from LIST, and mark other items. Return changed LIST, which is marked. */ @@ -6415,8 +6234,7 @@ mark_object (Lisp_Object arg) return; last_marked[last_marked_index++] = obj; - if (last_marked_index == LAST_MARKED_SIZE) - last_marked_index = 0; + last_marked_index &= LAST_MARKED_SIZE - 1; /* Perform some sanity checks on the objects marked here. Abort if we encounter an object we know is bogus. This increases GC time @@ -6596,9 +6414,8 @@ mark_object (Lisp_Object arg) mark_char_table (ptr, (enum pvec_type) pvectype); break; - case PVEC_BOOL_VECTOR: - /* No Lisp_Objects to mark in a bool vector. */ - VECTOR_MARK (ptr); + case PVEC_OVERLAY: + mark_overlay (XOVERLAY (obj)); break; case PVEC_SUBR: @@ -6608,6 +6425,8 @@ mark_object (Lisp_Object arg) emacs_abort (); default: + /* A regular vector, or a pseudovector needing no special + treatment. */ mark_vectorlike (ptr); } } @@ -6656,55 +6475,15 @@ mark_object (Lisp_Object arg) } break; - case Lisp_Misc: - CHECK_ALLOCATED_AND_LIVE (live_misc_p); - - if (XMISCANY (obj)->gcmarkbit) - break; - - switch (XMISCTYPE (obj)) - { - case Lisp_Misc_Marker: - /* DO NOT mark thru the marker's chain. - The buffer's markers chain does not preserve markers from gc; - instead, markers are removed from the chain when freed by gc. */ - XMISCANY (obj)->gcmarkbit = 1; - break; - - case Lisp_Misc_Save_Value: - XMISCANY (obj)->gcmarkbit = 1; - mark_save_value (XSAVE_VALUE (obj)); - break; - - case Lisp_Misc_Overlay: - mark_overlay (XOVERLAY (obj)); - break; - - case Lisp_Misc_Finalizer: - XMISCANY (obj)->gcmarkbit = true; - mark_object (XFINALIZER (obj)->function); - break; - -#ifdef HAVE_MODULES - case Lisp_Misc_User_Ptr: - XMISCANY (obj)->gcmarkbit = true; - break; -#endif - - default: - emacs_abort (); - } - break; - case Lisp_Cons: { - register struct Lisp_Cons *ptr = XCONS (obj); + struct Lisp_Cons *ptr = XCONS (obj); if (CONS_MARKED_P (ptr)) break; CHECK_ALLOCATED_AND_LIVE (live_cons_p); CONS_MARK (ptr); /* If the cdr is nil, avoid recursion for the car. */ - if (EQ (ptr->u.s.u.cdr, Qnil)) + if (NILP (ptr->u.s.u.cdr)) { obj = ptr->u.s.car; cdr_count = 0; @@ -6775,10 +6554,6 @@ survives_gc_p (Lisp_Object obj) survives_p = XSYMBOL (obj)->u.s.gcmarkbit; break; - case Lisp_Misc: - survives_p = XMISCANY (obj)->gcmarkbit; - break; - case Lisp_String: survives_p = STRING_MARKED_P (XSTRING (obj)); break; @@ -6845,7 +6620,9 @@ sweep_conses (void) for (pos = start; pos < stop; pos++) { - if (!CONS_MARKED_P (&cblk->conses[pos])) + struct Lisp_Cons *acons + = ptr_bounds_copy (&cblk->conses[pos], cblk); + if (!CONS_MARKED_P (acons)) { this_free++; cblk->conses[pos].u.s.u.chain = cons_free_list; @@ -6855,7 +6632,7 @@ sweep_conses (void) else { num_used++; - CONS_UNMARK (&cblk->conses[pos]); + CONS_UNMARK (acons); } } } @@ -6898,17 +6675,20 @@ sweep_floats (void) register int i; int this_free = 0; for (i = 0; i < lim; i++) - if (!FLOAT_MARKED_P (&fblk->floats[i])) - { - this_free++; - fblk->floats[i].u.chain = float_free_list; - float_free_list = &fblk->floats[i]; - } - else - { - num_used++; - FLOAT_UNMARK (&fblk->floats[i]); - } + { + struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk); + if (!FLOAT_MARKED_P (afloat)) + { + this_free++; + fblk->floats[i].u.chain = float_free_list; + float_free_list = &fblk->floats[i]; + } + else + { + num_used++; + FLOAT_UNMARK (afloat); + } + } lim = FLOAT_BLOCK_SIZE; /* If this block contains only free floats and we have already seen more than two blocks worth of free floats then deallocate @@ -7050,75 +6830,21 @@ sweep_symbols (void) total_free_symbols = num_free; } -NO_INLINE /* For better stack traces. */ +/* Remove BUFFER's markers that are due to be swept. This is needed since + we treat BUF_MARKERS and markers's `next' field as weak pointers. */ static void -sweep_misc (void) +unchain_dead_markers (struct buffer *buffer) { - register struct marker_block *mblk; - struct marker_block **mprev = &marker_block; - register int lim = marker_block_index; - EMACS_INT num_free = 0, num_used = 0; - - /* Put all unmarked misc's on free list. For a marker, first - unchain it from the buffer it points into. */ + struct Lisp_Marker *this, **prev = &BUF_MARKERS (buffer); - marker_free_list = 0; - - for (mblk = marker_block; mblk; mblk = *mprev) - { - register int i; - int this_free = 0; - - for (i = 0; i < lim; i++) - { - if (!mblk->markers[i].m.u_any.gcmarkbit) - { - if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker) - unchain_marker (&mblk->markers[i].m.u_marker); - else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer) - unchain_finalizer (&mblk->markers[i].m.u_finalizer); -#ifdef HAVE_MODULES - else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr) - { - struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr; - if (uptr->finalizer) - uptr->finalizer (uptr->p); - } -#endif - /* Set the type of the freed object to Lisp_Misc_Free. - We could leave the type alone, since nobody checks it, - but this might catch bugs faster. */ - mblk->markers[i].m.u_marker.type = Lisp_Misc_Free; - mblk->markers[i].m.u_free.chain = marker_free_list; - marker_free_list = &mblk->markers[i].m; - this_free++; - } - else - { - num_used++; - mblk->markers[i].m.u_any.gcmarkbit = 0; - } - } - lim = MARKER_BLOCK_SIZE; - /* If this block contains only free markers and we have already - seen more than two blocks worth of free markers then deallocate - this block. */ - if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE) - { - *mprev = mblk->next; - /* Unhook from the free list. */ - marker_free_list = mblk->markers[0].m.u_free.chain; - lisp_free (mblk); - } - else - { - num_free += this_free; - mprev = &mblk->next; - } - } - - total_markers = num_used; - total_free_markers = num_free; + while ((this = *prev)) + if (VECTOR_MARKED_P (this)) + prev = &this->next; + else + { + this->buffer = NULL; + *prev = this->next; + } } NO_INLINE /* For better stack traces */ @@ -7139,6 +6865,7 @@ sweep_buffers (void) VECTOR_UNMARK (buffer); /* Do not use buffer_(set|get)_intervals here. */ buffer->text->intervals = balance_intervals (buffer->text->intervals); + unchain_dead_markers (buffer); total_buffers++; bprev = &buffer->next; } @@ -7158,7 +6885,6 @@ gc_sweep (void) sweep_floats (); sweep_intervals (); sweep_symbols (); - sweep_misc (); sweep_buffers (); sweep_vectors (); check_string_bytes (!noninteractive); @@ -7214,46 +6940,26 @@ or memory information can't be obtained, return nil. */) /* Debugging aids. */ -DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0, - doc: /* Return the address of the last byte Emacs has allocated, divided by 1024. -This may be helpful in debugging Emacs's memory usage. -We divide the value by 1024 to make sure it fits in a Lisp integer. */) - (void) -{ - Lisp_Object end; - -#if defined HAVE_NS || defined __APPLE__ || !HAVE_SBRK - /* Avoid warning. sbrk has no relation to memory allocated anyway. */ - XSETINT (end, 0); -#else - XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024); -#endif - - return end; -} - DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0, doc: /* Return a list of counters that measure how much consing there has been. Each of these counters increments for a certain kind of object. The counters wrap around from the largest positive integer to zero. Garbage collection does not decrease them. The elements of the value are as follows: - (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS) + (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS INTERVALS STRINGS) All are in units of 1 = one object consed except for VECTOR-CELLS and STRING-CHARS, which count the total length of objects consed. -MISCS include overlays, markers, and some internal types. Frames, windows, buffers, and subprocesses count as vectors (but the contents of a buffer's text do not count here). */) (void) { - return listn (CONSTYPE_HEAP, 8, + return listn (CONSTYPE_HEAP, 7, bounded_number (cons_cells_consed), bounded_number (floats_consed), bounded_number (vector_cells_consed), bounded_number (symbols_consed), bounded_number (string_chars_consed), - bounded_number (misc_objects_consed), bounded_number (intervals_consed), bounded_number (strings_consed)); } @@ -7318,8 +7024,7 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max) } out: - unbind_to (gc_count, Qnil); - return found; + return unbind_to (gc_count, found); } #ifdef SUSPICIOUS_OBJECT_CHECKING @@ -7513,11 +7218,6 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */); DEFVAR_INT ("string-chars-consed", string_chars_consed, doc: /* Number of string characters that have been consed so far. */); - DEFVAR_INT ("misc-objects-consed", misc_objects_consed, - doc: /* Number of miscellaneous objects that have been consed so far. -These include markers and overlays, plus certain objects not visible -to users. */); - DEFVAR_INT ("intervals-consed", intervals_consed, doc: /* Number of intervals that have been consed so far. */); @@ -7553,7 +7253,6 @@ do hash-consing of the objects allocated to pure space. */); DEFSYM (Qconses, "conses"); DEFSYM (Qsymbols, "symbols"); - DEFSYM (Qmiscs, "miscs"); DEFSYM (Qstrings, "strings"); DEFSYM (Qvectors, "vectors"); DEFSYM (Qfloats, "floats"); @@ -7573,6 +7272,11 @@ The time is in seconds as a floating point value. */); DEFVAR_INT ("gcs-done", gcs_done, doc: /* Accumulated number of garbage collections done. */); + DEFVAR_INT ("integer-width", integer_width, + doc: /* Maximum number of bits in bignums. +Integers outside the fixnum range are limited to absolute values less +than 2**N, where N is this variable's value. N should be nonnegative. */); + defsubr (&Scons); defsubr (&Slist); defsubr (&Svector); @@ -7589,7 +7293,6 @@ The time is in seconds as a floating point value. */); defsubr (&Smake_finalizer); defsubr (&Spurecopy); defsubr (&Sgarbage_collect); - defsubr (&Smemory_limit); defsubr (&Smemory_info); defsubr (&Smemory_use_counts); defsubr (&Ssuspicious_object); diff --git a/src/atimer.c b/src/atimer.c index 8723573070e..4d97470a28f 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -113,10 +113,10 @@ start_atimer (enum atimer_type type, struct timespec timestamp, sigset_t oldset; /* Round TIMESTAMP up to the next full second if we don't have itimers. */ -#ifndef HAVE_SETITIMER +#if ! (defined HAVE_ITIMERSPEC || defined HAVE_SETITIMER) if (timestamp.tv_nsec != 0 && timestamp.tv_sec < TYPE_MAXIMUM (time_t)) timestamp = make_timespec (timestamp.tv_sec + 1, 0); -#endif /* not HAVE_SETITIMER */ +#endif /* Get an atimer structure from the free-list, or allocate a new one. */ @@ -494,15 +494,14 @@ debug_timer_callback (struct atimer *t) r->intime = 0; else if (result >= 0) { -#ifdef HAVE_SETITIMER + bool intime = true; +#if defined HAVE_ITIMERSPEC || defined HAVE_SETITIMER struct timespec delta = timespec_sub (now, r->expected); /* Too late if later than expected + 0.02s. FIXME: this should depend from system clock resolution. */ - if (timespec_cmp (delta, make_timespec (0, 20000000)) > 0) - r->intime = 0; - else -#endif /* HAVE_SETITIMER */ - r->intime = 1; + intime = timespec_cmp (delta, make_timespec (0, 20000000)) <= 0; +#endif + r->intime = intime; } } diff --git a/src/bidi.c b/src/bidi.c index 216279cbc3a..a62b888432e 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -1,6 +1,8 @@ /* Low-level bidirectional buffer/string-scanning functions for GNU Emacs. - Copyright (C) 2000-2001, 2004-2005, 2009-2019 Free Software - Foundation, Inc. + +Copyright (C) 2000-2001, 2004-2005, 2009-2019 Free Software Foundation, Inc. + +Author: Eli Zaretskii <eliz@gnu.org> This file is part of GNU Emacs. @@ -17,9 +19,7 @@ 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 <https://www.gnu.org/licenses/>. */ -/* Written by Eli Zaretskii <eliz@gnu.org>. - - A sequential implementation of the Unicode Bidirectional algorithm, +/* A sequential implementation of the Unicode Bidirectional algorithm, (UBA) as per UAX#9, a part of the Unicode Standard. Unlike the Reference Implementation and most other implementations, @@ -280,7 +280,7 @@ bidi_get_type (int ch, bidi_dir_t override) if (ch < 0 || ch > MAX_CHAR) emacs_abort (); - default_type = (bidi_type_t) XINT (CHAR_TABLE_REF (bidi_type_table, ch)); + default_type = (bidi_type_t) XFIXNUM (CHAR_TABLE_REF (bidi_type_table, ch)); /* Every valid character code, even those that are unassigned by the UCD, have some bidi-class property, according to DerivedBidiClass.txt file. Therefore, if we ever get UNKNOWN_BT @@ -379,15 +379,15 @@ bidi_mirror_char (int c) emacs_abort (); val = CHAR_TABLE_REF (bidi_mirror_table, c); - if (INTEGERP (val)) + if (FIXNUMP (val)) { int v; /* When debugging, check before assigning to V, so that the check isn't broken by undefined behavior due to int overflow. */ - eassert (CHAR_VALID_P (XINT (val))); + eassert (CHAR_VALID_P (XFIXNUM (val))); - v = XINT (val); + v = XFIXNUM (val); /* Minimal test we must do in optimized builds, to prevent weird crashes further down the road. */ @@ -409,7 +409,7 @@ bidi_paired_bracket_type (int c) if (c < 0 || c > MAX_CHAR) emacs_abort (); - return (bidi_bracket_type_t) XINT (CHAR_TABLE_REF (bidi_brackets_table, c)); + return (bidi_bracket_type_t) XFIXNUM (CHAR_TABLE_REF (bidi_brackets_table, c)); } /* Determine the start-of-sequence (sos) directional type given the two @@ -1805,7 +1805,7 @@ bidi_explicit_dir_char (int ch) eassert (ch == BIDI_EOB); return false; } - ch_type = (bidi_type_t) XINT (CHAR_TABLE_REF (bidi_type_table, ch)); + ch_type = (bidi_type_t) XFIXNUM (CHAR_TABLE_REF (bidi_type_table, ch)); return (ch_type == LRE || ch_type == LRO || ch_type == RLE || ch_type == RLO || ch_type == PDF); diff --git a/src/bignum.c b/src/bignum.c new file mode 100644 index 00000000000..e3db0377a53 --- /dev/null +++ b/src/bignum.c @@ -0,0 +1,351 @@ +/* Big numbers for Emacs. + +Copyright 2018 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include "bignum.h" + +#include "lisp.h" + +#include <math.h> +#include <stdlib.h> + +/* mpz global temporaries. Making them global saves the trouble of + properly using mpz_init and mpz_clear on temporaries even when + storage is exhausted. Admittedly this is not ideal. An mpz value + in a temporary is made permanent by mpz_swapping it with a bignum's + value. Although typically at most two temporaries are needed, + time_arith, rounddiv_q and rounding_driver each need four. */ + +mpz_t mpz[4]; + +static void * +xrealloc_for_gmp (void *ptr, size_t ignore, size_t size) +{ + return xrealloc (ptr, size); +} + +static void +xfree_for_gmp (void *ptr, size_t ignore) +{ + xfree (ptr); +} + +void +init_bignum (void) +{ + eassert (mp_bits_per_limb == GMP_NUMB_BITS); + integer_width = 1 << 16; + mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp); + + for (int i = 0; i < ARRAYELTS (mpz); i++) + mpz_init (mpz[i]); +} + +/* Return the value of the Lisp bignum N, as a double. */ +double +bignum_to_double (Lisp_Object n) +{ + return mpz_get_d_rounded (XBIGNUM (n)->value); +} + +/* Return D, converted to a Lisp integer. Discard any fraction. + Signal an error if D cannot be converted. */ +Lisp_Object +double_to_integer (double d) +{ + if (!isfinite (d)) + overflow_error (); + mpz_set_d (mpz[0], d); + return make_integer_mpz (); +} + +/* Return a Lisp integer equal to mpz[0], which has BITS bits and which + must not be in fixnum range. Set mpz[0] to a junk value. */ +static Lisp_Object +make_bignum_bits (size_t bits) +{ + /* The documentation says integer-width should be nonnegative, so + a single comparison suffices even though 'bits' is unsigned. */ + if (integer_width < bits) + overflow_error (); + + struct Lisp_Bignum *b = ALLOCATE_PSEUDOVECTOR (struct Lisp_Bignum, value, + PVEC_BIGNUM); + mpz_init (b->value); + mpz_swap (b->value, mpz[0]); + return make_lisp_ptr (b, Lisp_Vectorlike); +} + +/* Return a Lisp integer equal to mpz[0], which must not be in fixnum range. + Set mpz[0] to a junk value. */ +static Lisp_Object +make_bignum (void) +{ + return make_bignum_bits (mpz_sizeinbase (mpz[0], 2)); +} + +/* Return a Lisp integer equal to N, which must not be in fixnum range. */ +Lisp_Object +make_bigint (intmax_t n) +{ + eassert (FIXNUM_OVERFLOW_P (n)); + mpz_set_intmax (mpz[0], n); + return make_bignum (); +} +Lisp_Object +make_biguint (uintmax_t n) +{ + eassert (FIXNUM_OVERFLOW_P (n)); + mpz_set_uintmax (mpz[0], n); + return make_bignum (); +} + +/* Return a Lisp integer equal to -N, which must not be in fixnum range. */ +Lisp_Object +make_neg_biguint (uintmax_t n) +{ + eassert (-MOST_NEGATIVE_FIXNUM < n); + mpz_set_uintmax (mpz[0], n); + mpz_neg (mpz[0], mpz[0]); + return make_bignum (); +} + +/* Return a Lisp integer with value taken from mpz[0]. + Set mpz[0] to a junk value. */ +Lisp_Object +make_integer_mpz (void) +{ + size_t bits = mpz_sizeinbase (mpz[0], 2); + + if (bits <= FIXNUM_BITS) + { + EMACS_INT v = 0; + int i = 0, shift = 0; + + do + { + EMACS_INT limb = mpz_getlimbn (mpz[0], i++); + v += limb << shift; + shift += GMP_NUMB_BITS; + } + while (shift < bits); + + if (mpz_sgn (mpz[0]) < 0) + v = -v; + + if (!FIXNUM_OVERFLOW_P (v)) + return make_fixnum (v); + } + + return make_bignum_bits (bits); +} + +/* Set RESULT to V. This code is for when intmax_t is wider than long. */ +void +mpz_set_intmax_slow (mpz_t result, intmax_t v) +{ + int maxlimbs = (INTMAX_WIDTH + GMP_NUMB_BITS - 1) / GMP_NUMB_BITS; + mp_limb_t *limb = mpz_limbs_write (result, maxlimbs); + int n = 0; + uintmax_t u = v; + bool negative = v < 0; + if (negative) + { + uintmax_t two = 2; + u = -u & ((two << (UINTMAX_WIDTH - 1)) - 1); + } + + do + { + limb[n++] = u; + u = GMP_NUMB_BITS < UINTMAX_WIDTH ? u >> GMP_NUMB_BITS : 0; + } + while (u != 0); + + mpz_limbs_finish (result, negative ? -n : n); +} +void +mpz_set_uintmax_slow (mpz_t result, uintmax_t v) +{ + int maxlimbs = (UINTMAX_WIDTH + GMP_NUMB_BITS - 1) / GMP_NUMB_BITS; + mp_limb_t *limb = mpz_limbs_write (result, maxlimbs); + int n = 0; + + do + { + limb[n++] = v; + v = GMP_NUMB_BITS < INTMAX_WIDTH ? v >> GMP_NUMB_BITS : 0; + } + while (v != 0); + + mpz_limbs_finish (result, n); +} + +/* If Z fits into *PI, store its value there and return true. + Return false otherwise. */ +bool +mpz_to_intmax (mpz_t const z, intmax_t *pi) +{ + ptrdiff_t bits = mpz_sizeinbase (z, 2); + bool negative = mpz_sgn (z) < 0; + + if (bits < INTMAX_WIDTH) + { + intmax_t v = 0; + int i = 0, shift = 0; + + do + { + intmax_t limb = mpz_getlimbn (z, i++); + v += limb << shift; + shift += GMP_NUMB_BITS; + } + while (shift < bits); + + *pi = negative ? -v : v; + return true; + } + if (bits == INTMAX_WIDTH && INTMAX_MIN < -INTMAX_MAX && negative + && mpz_scan1 (z, 0) == INTMAX_WIDTH - 1) + { + *pi = INTMAX_MIN; + return true; + } + return false; +} +bool +mpz_to_uintmax (mpz_t const z, uintmax_t *pi) +{ + if (mpz_sgn (z) < 0) + return false; + ptrdiff_t bits = mpz_sizeinbase (z, 2); + if (UINTMAX_WIDTH < bits) + return false; + + uintmax_t v = 0; + int i = 0, shift = 0; + + do + { + uintmax_t limb = mpz_getlimbn (z, i++); + v += limb << shift; + shift += GMP_NUMB_BITS; + } + while (shift < bits); + + *pi = v; + return true; +} + +/* Return the value of the bignum X if it fits, 0 otherwise. + A bignum cannot be zero, so 0 indicates failure reliably. */ +intmax_t +bignum_to_intmax (Lisp_Object x) +{ + intmax_t i; + return mpz_to_intmax (XBIGNUM (x)->value, &i) ? i : 0; +} +uintmax_t +bignum_to_uintmax (Lisp_Object x) +{ + uintmax_t i; + return mpz_to_uintmax (XBIGNUM (x)->value, &i) ? i : 0; +} + +/* Yield an upper bound on the buffer size needed to contain a C + string representing the NUM in base BASE. This includes any + preceding '-' and the terminating null. */ +static ptrdiff_t +mpz_bufsize (mpz_t const num, int base) +{ + return mpz_sizeinbase (num, base) + 2; +} +ptrdiff_t +bignum_bufsize (Lisp_Object num, int base) +{ + return mpz_bufsize (XBIGNUM (num)->value, base); +} + +/* Convert NUM to a nearest double, as opposed to mpz_get_d which + truncates toward zero. */ +double +mpz_get_d_rounded (mpz_t const num) +{ + ptrdiff_t size = mpz_bufsize (num, 10); + + /* Use mpz_get_d as a shortcut for a bignum so small that rounding + errors cannot occur, which is possible if EMACS_INT (not counting + sign) has fewer bits than a double significand. */ + if (! ((FLT_RADIX == 2 && DBL_MANT_DIG <= FIXNUM_BITS - 1) + || (FLT_RADIX == 16 && DBL_MANT_DIG * 4 <= FIXNUM_BITS - 1)) + && size <= DBL_DIG + 2) + return mpz_get_d (num); + + USE_SAFE_ALLOCA; + char *buf = SAFE_ALLOCA (size); + mpz_get_str (buf, 10, num); + double result = strtod (buf, NULL); + SAFE_FREE (); + return result; +} + +/* Store into BUF (of size SIZE) the value of NUM as a base-BASE string. + If BASE is negative, use upper-case digits in base -BASE. + Return the string's length. + SIZE must equal bignum_bufsize (NUM, abs (BASE)). */ +ptrdiff_t +bignum_to_c_string (char *buf, ptrdiff_t size, Lisp_Object num, int base) +{ + eassert (bignum_bufsize (num, abs (base)) == size); + mpz_get_str (buf, base, XBIGNUM (num)->value); + ptrdiff_t n = size - 2; + return !buf[n - 1] ? n - 1 : n + !!buf[n]; +} + +/* Convert NUM to a base-BASE Lisp string. + If BASE is negative, use upper-case digits in base -BASE. */ + +Lisp_Object +bignum_to_string (Lisp_Object num, int base) +{ + ptrdiff_t size = bignum_bufsize (num, abs (base)); + USE_SAFE_ALLOCA; + char *str = SAFE_ALLOCA (size); + ptrdiff_t len = bignum_to_c_string (str, size, num, base); + Lisp_Object result = make_unibyte_string (str, len); + SAFE_FREE (); + return result; +} + +/* Create a bignum by scanning NUM, with digits in BASE. + NUM must consist of an optional '-', a nonempty sequence + of base-BASE digits, and a terminating null byte, and + the represented number must not be in fixnum range. */ + +Lisp_Object +make_bignum_str (char const *num, int base) +{ + struct Lisp_Bignum *b = ALLOCATE_PSEUDOVECTOR (struct Lisp_Bignum, value, + PVEC_BIGNUM); + mpz_init (b->value); + int check = mpz_set_str (b->value, num, base); + eassert (check == 0); + return make_lisp_ptr (b, Lisp_Vectorlike); +} diff --git a/src/bignum.h b/src/bignum.h new file mode 100644 index 00000000000..fd035e6e14d --- /dev/null +++ b/src/bignum.h @@ -0,0 +1,99 @@ +/* Big numbers for Emacs. + +Copyright 2018 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 <https://www.gnu.org/licenses/>. */ + +/* Include this header only if access to bignum internals is needed. */ + +#ifndef BIGNUM_H +#define BIGNUM_H + +#ifdef HAVE_GMP +# include <gmp.h> +#else +# include "mini-gmp.h" +#endif + +#include "lisp.h" + +/* Number of data bits in a limb. */ +#ifndef GMP_NUMB_BITS +enum { GMP_NUMB_BITS = TYPE_WIDTH (mp_limb_t) }; +#endif + +struct Lisp_Bignum +{ + union vectorlike_header header; + mpz_t value; +} GCALIGNED_STRUCT; + +extern mpz_t mpz[4]; + +extern void init_bignum (void); +extern Lisp_Object make_integer_mpz (void); +extern bool mpz_to_intmax (mpz_t const, intmax_t *) ARG_NONNULL ((1, 2)); +extern bool mpz_to_uintmax (mpz_t const, uintmax_t *) ARG_NONNULL ((1, 2)); +extern void mpz_set_intmax_slow (mpz_t, intmax_t) ARG_NONNULL ((1)); +extern void mpz_set_uintmax_slow (mpz_t, uintmax_t) ARG_NONNULL ((1)); +extern double mpz_get_d_rounded (mpz_t const); + +INLINE_HEADER_BEGIN + +INLINE struct Lisp_Bignum * +XBIGNUM (Lisp_Object a) +{ + eassert (BIGNUMP (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Bignum); +} + +INLINE void ARG_NONNULL ((1)) +mpz_set_intmax (mpz_t result, intmax_t v) +{ + /* mpz_set_si works in terms of long, but Emacs may use a wider + integer type, and so sometimes will have to construct the mpz_t + by hand. */ + if (LONG_MIN <= v && v <= LONG_MAX) + mpz_set_si (result, v); + else + mpz_set_intmax_slow (result, v); +} +INLINE void ARG_NONNULL ((1)) +mpz_set_uintmax (mpz_t result, uintmax_t v) +{ + if (v <= ULONG_MAX) + mpz_set_ui (result, v); + else + mpz_set_uintmax_slow (result, v); +} + +/* Return a pointer to an mpz_t that is equal to the Lisp integer I. + If I is a bignum this returns a pointer to I's representation; + otherwise this sets *TMP to I's value and returns TMP. */ +INLINE mpz_t * +bignum_integer (mpz_t *tmp, Lisp_Object i) +{ + if (FIXNUMP (i)) + { + mpz_set_intmax (*tmp, XFIXNUM (i)); + return tmp; + } + return &XBIGNUM (i)->value; +} + +INLINE_HEADER_END + +#endif /* BIGNUM_H */ diff --git a/src/buffer.c b/src/buffer.c index 4ab5d4efe30..cc0899676de 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -466,7 +466,7 @@ See also `find-buffer-visiting'. */) filename = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qget_file_buffer); if (!NILP (handler)) { @@ -849,7 +849,7 @@ CLONE nil means the indirect buffer's state is reset to default values. */) clone_per_buffer_values (b->base_buffer, b); bset_filename (b, Qnil); bset_file_truename (b, Qnil); - bset_display_count (b, make_number (0)); + bset_display_count (b, make_fixnum (0)); bset_backed_up (b, Qnil); bset_auto_save_file_name (b, Qnil); set_buffer_internal_1 (b); @@ -939,7 +939,7 @@ reset_buffer (register struct buffer *b) bset_file_format (b, Qnil); bset_auto_save_file_format (b, Qt); bset_last_selected_window (b, Qnil); - bset_display_count (b, make_number (0)); + bset_display_count (b, make_fixnum (0)); bset_display_time (b, Qnil); bset_enable_multibyte_characters (b, BVAR (&buffer_defaults, enable_multibyte_characters)); @@ -1102,8 +1102,8 @@ is first appended to NAME, to speed up finding a non-existent buffer. */) { char number[sizeof "-999999"]; - /* Use XINT instead of XFASTINT to work around GCC bug 80776. */ - int i = XINT (Frandom (make_number (1000000))); + /* Use XFIXNUM instead of XFIXNAT to work around GCC bug 80776. */ + int i = XFIXNUM (Frandom (make_fixnum (1000000))); eassume (0 <= i && i < 1000000); AUTO_STRING_WITH_LEN (lnumber, number, sprintf (number, "-%d", i)); @@ -1421,7 +1421,7 @@ text in that buffer is changed. It wraps around occasionally. No argument or nil as argument means use current buffer as BUFFER. */) (register Lisp_Object buffer) { - return make_number (BUF_MODIFF (decode_buffer (buffer))); + return make_fixnum (BUF_MODIFF (decode_buffer (buffer))); } DEFUN ("buffer-chars-modified-tick", Fbuffer_chars_modified_tick, @@ -1436,7 +1436,7 @@ between these calls. No argument or nil as argument means use current buffer as BUFFER. */) (register Lisp_Object buffer) { - return make_number (BUF_CHARS_MODIFF (decode_buffer (buffer))); + return make_fixnum (BUF_CHARS_MODIFF (decode_buffer (buffer))); } DEFUN ("rename-buffer", Frename_buffer, Srename_buffer, 1, 2, @@ -1696,7 +1696,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) { ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); set_buffer_internal (b); /* First run the query functions; if any query is answered no, @@ -2203,7 +2203,7 @@ If the text under POSITION (which defaults to point) has the if (NILP (position)) XSETFASTINT (position, PT); else - CHECK_NUMBER (position); + CHECK_FIXNUM (position); if (!NILP (BVAR (current_buffer, read_only)) && NILP (Vinhibit_read_only) @@ -2233,16 +2233,16 @@ so the buffer is truly empty after this. */) void validate_region (register Lisp_Object *b, register Lisp_Object *e) { - CHECK_NUMBER_COERCE_MARKER (*b); - CHECK_NUMBER_COERCE_MARKER (*e); + CHECK_FIXNUM_COERCE_MARKER (*b); + CHECK_FIXNUM_COERCE_MARKER (*e); - if (XINT (*b) > XINT (*e)) + if (XFIXNUM (*b) > XFIXNUM (*e)) { Lisp_Object tem; tem = *b; *b = *e; *e = tem; } - if (! (BEGV <= XINT (*b) && XINT (*e) <= ZV)) + if (! (BEGV <= XFIXNUM (*b) && XFIXNUM (*e) <= ZV)) args_out_of_range_3 (Fcurrent_buffer (), *b, *e); } @@ -2409,7 +2409,7 @@ results, see Info node `(elisp)Swapping Text'. */) && (EQ (XWINDOW (w)->contents, buf1) || EQ (XWINDOW (w)->contents, buf2))) Fset_marker (XWINDOW (w)->pointm, - make_number + make_fixnum (BUF_BEGV (XBUFFER (XWINDOW (w)->contents))), XWINDOW (w)->contents); /* Blindly copied from pointm part. */ @@ -2417,14 +2417,14 @@ results, see Info node `(elisp)Swapping Text'. */) && (EQ (XWINDOW (w)->contents, buf1) || EQ (XWINDOW (w)->contents, buf2))) Fset_marker (XWINDOW (w)->old_pointm, - make_number + make_fixnum (BUF_BEGV (XBUFFER (XWINDOW (w)->contents))), XWINDOW (w)->contents); if (MARKERP (XWINDOW (w)->start) && (EQ (XWINDOW (w)->contents, buf1) || EQ (XWINDOW (w)->contents, buf2))) Fset_marker (XWINDOW (w)->start, - make_number + make_fixnum (XBUFFER (XWINDOW (w)->contents)->last_window_start), XWINDOW (w)->contents); w = Fnext_window (w, Qt, Qt); @@ -2547,7 +2547,7 @@ current buffer is cleared. */) } } if (narrowed) - Fnarrow_to_region (make_number (begv), make_number (zv)); + Fnarrow_to_region (make_fixnum (begv), make_fixnum (zv)); } else { @@ -2628,7 +2628,7 @@ current buffer is cleared. */) TEMP_SET_PT (pt); if (narrowed) - Fnarrow_to_region (make_number (begv), make_number (zv)); + Fnarrow_to_region (make_fixnum (begv), make_fixnum (zv)); /* Do this first, so that chars_in_text asks the right question. set_intervals_multibyte needs it too. */ @@ -2789,8 +2789,6 @@ overlays_at (EMACS_INT pos, bool extend, Lisp_Object **vec_ptr, ptrdiff_t *len_ptr, ptrdiff_t *next_ptr, ptrdiff_t *prev_ptr, bool change_req) { - Lisp_Object overlay, start, end; - struct Lisp_Overlay *tail; ptrdiff_t idx = 0; ptrdiff_t len = *len_ptr; Lisp_Object *vec = *vec_ptr; @@ -2798,22 +2796,20 @@ overlays_at (EMACS_INT pos, bool extend, Lisp_Object **vec_ptr, ptrdiff_t prev = BEGV; bool inhibit_storing = 0; - for (tail = current_buffer->overlays_before; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { - ptrdiff_t startpos, endpos; - - XSETMISC (overlay, tail); - - start = OVERLAY_START (overlay); - end = OVERLAY_END (overlay); - endpos = OVERLAY_POSITION (end); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object start = OVERLAY_START (overlay); + Lisp_Object end = OVERLAY_END (overlay); + ptrdiff_t endpos = OVERLAY_POSITION (end); if (endpos < pos) { if (prev < endpos) prev = endpos; break; } - startpos = OVERLAY_POSITION (start); + ptrdiff_t startpos = OVERLAY_POSITION (start); /* This one ends at or after POS so its start counts for PREV_PTR if it's before POS. */ if (prev < startpos && startpos < pos) @@ -2846,22 +2842,20 @@ overlays_at (EMACS_INT pos, bool extend, Lisp_Object **vec_ptr, next = startpos; } - for (tail = current_buffer->overlays_after; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { - ptrdiff_t startpos, endpos; - - XSETMISC (overlay, tail); - - start = OVERLAY_START (overlay); - end = OVERLAY_END (overlay); - startpos = OVERLAY_POSITION (start); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object start = OVERLAY_START (overlay); + Lisp_Object end = OVERLAY_END (overlay); + ptrdiff_t startpos = OVERLAY_POSITION (start); if (pos < startpos) { if (startpos < next) next = startpos; break; } - endpos = OVERLAY_POSITION (end); + ptrdiff_t endpos = OVERLAY_POSITION (end); if (pos < endpos) { if (idx == len) @@ -2923,8 +2917,6 @@ overlays_in (EMACS_INT beg, EMACS_INT end, bool extend, Lisp_Object **vec_ptr, ptrdiff_t *len_ptr, ptrdiff_t *next_ptr, ptrdiff_t *prev_ptr) { - Lisp_Object overlay, ostart, oend; - struct Lisp_Overlay *tail; ptrdiff_t idx = 0; ptrdiff_t len = *len_ptr; Lisp_Object *vec = *vec_ptr; @@ -2933,22 +2925,20 @@ overlays_in (EMACS_INT beg, EMACS_INT end, bool extend, bool inhibit_storing = 0; bool end_is_Z = end == Z; - for (tail = current_buffer->overlays_before; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { - ptrdiff_t startpos, endpos; - - XSETMISC (overlay, tail); - - ostart = OVERLAY_START (overlay); - oend = OVERLAY_END (overlay); - endpos = OVERLAY_POSITION (oend); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object ostart = OVERLAY_START (overlay); + Lisp_Object oend = OVERLAY_END (overlay); + ptrdiff_t endpos = OVERLAY_POSITION (oend); if (endpos < beg) { if (prev < endpos) prev = endpos; break; } - startpos = OVERLAY_POSITION (ostart); + ptrdiff_t startpos = OVERLAY_POSITION (ostart); /* Count an interval if it overlaps the range, is empty at the start of the range, or is empty at END provided END denotes the end of the buffer. */ @@ -2980,22 +2970,20 @@ overlays_in (EMACS_INT beg, EMACS_INT end, bool extend, next = startpos; } - for (tail = current_buffer->overlays_after; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { - ptrdiff_t startpos, endpos; - - XSETMISC (overlay, tail); - - ostart = OVERLAY_START (overlay); - oend = OVERLAY_END (overlay); - startpos = OVERLAY_POSITION (ostart); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object ostart = OVERLAY_START (overlay); + Lisp_Object oend = OVERLAY_END (overlay); + ptrdiff_t startpos = OVERLAY_POSITION (ostart); if (end < startpos) { if (startpos < next) next = startpos; break; } - endpos = OVERLAY_POSITION (oend); + ptrdiff_t endpos = OVERLAY_POSITION (oend); /* Count an interval if it overlaps the range, is empty at the start of the range, or is empty at END provided END denotes the end of the buffer. */ @@ -3097,31 +3085,26 @@ disable_line_numbers_overlay_at_eob (void) bool overlay_touches_p (ptrdiff_t pos) { - Lisp_Object overlay; - struct Lisp_Overlay *tail; - - for (tail = current_buffer->overlays_before; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { - ptrdiff_t endpos; - - XSETMISC (overlay ,tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); + ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); if (endpos < pos) break; if (endpos == pos || OVERLAY_POSITION (OVERLAY_START (overlay)) == pos) return 1; } - for (tail = current_buffer->overlays_after; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { - ptrdiff_t startpos; - - XSETMISC (overlay, tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); + ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); if (pos < startpos) break; if (startpos == pos || OVERLAY_POSITION (OVERLAY_END (overlay)) == pos) @@ -3212,17 +3195,17 @@ sort_overlays (Lisp_Object *overlay_vec, ptrdiff_t noverlays, struct window *w) sortvec[j].priority = 0; sortvec[j].spriority = 0; } - else if (INTEGERP (tem)) + else if (FIXNUMP (tem)) { - sortvec[j].priority = XINT (tem); + sortvec[j].priority = XFIXNUM (tem); sortvec[j].spriority = 0; } else if (CONSP (tem)) { Lisp_Object car = XCAR (tem); Lisp_Object cdr = XCDR (tem); - sortvec[j].priority = INTEGERP (car) ? XINT (car) : 0; - sortvec[j].spriority = INTEGERP (cdr) ? XINT (cdr) : 0; + sortvec[j].priority = FIXNUMP (car) ? XFIXNUM (car) : 0; + sortvec[j].spriority = FIXNUMP (cdr) ? XFIXNUM (cdr) : 0; } j++; } @@ -3290,7 +3273,7 @@ record_overlay_string (struct sortstrlist *ssl, Lisp_Object str, ssl->buf[ssl->used].string = str; ssl->buf[ssl->used].string2 = str2; ssl->buf[ssl->used].size = size; - ssl->buf[ssl->used].priority = (INTEGERP (pri) ? XINT (pri) : 0); + ssl->buf[ssl->used].priority = (FIXNUMP (pri) ? XFIXNUM (pri) : 0); ssl->used++; if (NILP (BVAR (current_buffer, enable_multibyte_characters))) @@ -3337,27 +3320,26 @@ record_overlay_string (struct sortstrlist *ssl, Lisp_Object str, ptrdiff_t overlay_strings (ptrdiff_t pos, struct window *w, unsigned char **pstr) { - Lisp_Object overlay, window, str; - struct Lisp_Overlay *ov; - ptrdiff_t startpos, endpos; bool multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters)); overlay_heads.used = overlay_heads.bytes = 0; overlay_tails.used = overlay_tails.bytes = 0; - for (ov = current_buffer->overlays_before; ov; ov = ov->next) + for (struct Lisp_Overlay *ov = current_buffer->overlays_before; + ov; ov = ov->next) { - XSETMISC (overlay, ov); + Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); - endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); + ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); + ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); if (endpos < pos) break; if (endpos != pos && startpos != pos) continue; - window = Foverlay_get (overlay, Qwindow); + Lisp_Object window = Foverlay_get (overlay, Qwindow); if (WINDOWP (window) && XWINDOW (window) != w) continue; + Lisp_Object str; if (startpos == pos && (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str))) record_overlay_string (&overlay_heads, str, @@ -3372,20 +3354,22 @@ overlay_strings (ptrdiff_t pos, struct window *w, unsigned char **pstr) Foverlay_get (overlay, Qpriority), endpos - startpos); } - for (ov = current_buffer->overlays_after; ov; ov = ov->next) + for (struct Lisp_Overlay *ov = current_buffer->overlays_after; + ov; ov = ov->next) { - XSETMISC (overlay, ov); + Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); - endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); + ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); + ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); if (startpos > pos) break; if (endpos != pos && startpos != pos) continue; - window = Foverlay_get (overlay, Qwindow); + Lisp_Object window = Foverlay_get (overlay, Qwindow); if (WINDOWP (window) && XWINDOW (window) != w) continue; + Lisp_Object str; if (startpos == pos && (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str))) record_overlay_string (&overlay_heads, str, @@ -3460,8 +3444,7 @@ overlay_strings (ptrdiff_t pos, struct window *w, unsigned char **pstr) void recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos) { - Lisp_Object overlay, beg, end; - struct Lisp_Overlay *prev, *tail, *next; + struct Lisp_Overlay *prev, *next; /* See if anything in overlays_before should move to overlays_after. */ @@ -3469,14 +3452,15 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos) But we use it for symmetry and in case that should cease to be true with some future change. */ prev = NULL; - for (tail = buf->overlays_before; tail; prev = tail, tail = next) + for (struct Lisp_Overlay *tail = buf->overlays_before; + tail; prev = tail, tail = next) { next = tail->next; - XSETMISC (overlay, tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - beg = OVERLAY_START (overlay); - end = OVERLAY_END (overlay); + Lisp_Object beg = OVERLAY_START (overlay); + Lisp_Object end = OVERLAY_END (overlay); if (OVERLAY_POSITION (end) > pos) { @@ -3495,12 +3479,10 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos) for (other = buf->overlays_after; other; other_prev = other, other = other->next) { - Lisp_Object otherbeg, otheroverlay; - - XSETMISC (otheroverlay, other); + Lisp_Object otheroverlay = make_lisp_ptr (other, Lisp_Vectorlike); eassert (OVERLAYP (otheroverlay)); - otherbeg = OVERLAY_START (otheroverlay); + Lisp_Object otherbeg = OVERLAY_START (otheroverlay); if (OVERLAY_POSITION (otherbeg) >= where) break; } @@ -3522,14 +3504,15 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos) /* See if anything in overlays_after should be in overlays_before. */ prev = NULL; - for (tail = buf->overlays_after; tail; prev = tail, tail = next) + for (struct Lisp_Overlay *tail = buf->overlays_after; + tail; prev = tail, tail = next) { next = tail->next; - XSETMISC (overlay, tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - beg = OVERLAY_START (overlay); - end = OVERLAY_END (overlay); + Lisp_Object beg = OVERLAY_START (overlay); + Lisp_Object end = OVERLAY_END (overlay); /* Stop looking, when we know that nothing further can possibly end before POS. */ @@ -3553,12 +3536,10 @@ recenter_overlay_lists (struct buffer *buf, ptrdiff_t pos) for (other = buf->overlays_before; other; other_prev = other, other = other->next) { - Lisp_Object otherend, otheroverlay; - - XSETMISC (otheroverlay, other); + Lisp_Object otheroverlay = make_lisp_ptr (other, Lisp_Vectorlike); eassert (OVERLAYP (otheroverlay)); - otherend = OVERLAY_END (otheroverlay); + Lisp_Object otherend = OVERLAY_END (otheroverlay); if (OVERLAY_POSITION (otherend) <= where) break; } @@ -3613,7 +3594,6 @@ adjust_overlays_for_delete (ptrdiff_t pos, ptrdiff_t length) void fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end) { - Lisp_Object overlay; struct Lisp_Overlay *before_list UNINIT; struct Lisp_Overlay *after_list UNINIT; /* These are either nil, indicating that before_list or after_list @@ -3623,8 +3603,7 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end) /* 'Parent', likewise, indicates a cons cell or current_buffer->overlays_before or overlays_after, depending which loop we're in. */ - struct Lisp_Overlay *tail, *parent; - ptrdiff_t startpos, endpos; + struct Lisp_Overlay *parent; /* This algorithm shifts links around instead of consing and GCing. The loop invariant is that before_list (resp. after_list) is a @@ -3633,18 +3612,20 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end) (after_list) if it is, is still uninitialized. So it's not a bug that before_list isn't initialized, although it may look strange. */ - for (parent = NULL, tail = current_buffer->overlays_before; tail;) + parent = NULL; + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { - XSETMISC (overlay, tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); - endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); - startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); + ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); + ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); /* If the overlay is backwards, make it empty. */ if (endpos < startpos) { startpos = endpos; - Fset_marker (OVERLAY_START (overlay), make_number (startpos), + Fset_marker (OVERLAY_START (overlay), make_fixnum (startpos), Qnil); } @@ -3676,23 +3657,24 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end) set_buffer_overlays_before (current_buffer, tail->next); else parent->next = tail->next; - tail = tail->next; } else - parent = tail, tail = parent->next; + parent = tail; } - for (parent = NULL, tail = current_buffer->overlays_after; tail;) + parent = NULL; + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { - XSETMISC (overlay, tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); - startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); - endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); + ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); + ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); /* If the overlay is backwards, make it empty. */ if (endpos < startpos) { startpos = endpos; - Fset_marker (OVERLAY_START (overlay), make_number (startpos), + Fset_marker (OVERLAY_START (overlay), make_fixnum (startpos), Qnil); } @@ -3722,10 +3704,9 @@ fix_start_end_in_overlays (register ptrdiff_t start, register ptrdiff_t end) set_buffer_overlays_after (current_buffer, tail->next); else parent->next = tail->next; - tail = tail->next; } else - parent = tail, tail = parent->next; + parent = tail; } /* Splice the constructed (wrong) lists into the buffer's lists, @@ -3776,7 +3757,7 @@ fix_overlays_before (struct buffer *bp, ptrdiff_t prev, ptrdiff_t pos) overlay whose ending marker is after-insertion-marker if disorder exists). */ while (tail - && (XSETMISC (tem, tail), + && (tem = make_lisp_ptr (tail, Lisp_Vectorlike), (end = OVERLAY_POSITION (OVERLAY_END (tem))) >= pos)) { parent = tail; @@ -3801,7 +3782,7 @@ fix_overlays_before (struct buffer *bp, ptrdiff_t prev, ptrdiff_t pos) overlays are in correct order. */ while (tail) { - XSETMISC (tem, tail); + tem = make_lisp_ptr (tail, Lisp_Vectorlike); end = OVERLAY_POSITION (OVERLAY_END (tem)); if (end == pos) @@ -3867,10 +3848,10 @@ for the rear of the overlay advance when text is inserted there if (MARKERP (end) && !EQ (Fmarker_buffer (end), buffer)) signal_error ("Marker points into wrong buffer", end); - CHECK_NUMBER_COERCE_MARKER (beg); - CHECK_NUMBER_COERCE_MARKER (end); + CHECK_FIXNUM_COERCE_MARKER (beg); + CHECK_FIXNUM_COERCE_MARKER (end); - if (XINT (beg) > XINT (end)) + if (XFIXNUM (beg) > XFIXNUM (end)) { Lisp_Object temp; temp = beg; beg = end; end = temp; @@ -3987,10 +3968,10 @@ buffer. */) if (MARKERP (end) && !EQ (Fmarker_buffer (end), buffer)) signal_error ("Marker points into wrong buffer", end); - CHECK_NUMBER_COERCE_MARKER (beg); - CHECK_NUMBER_COERCE_MARKER (end); + CHECK_FIXNUM_COERCE_MARKER (beg); + CHECK_FIXNUM_COERCE_MARKER (end); - if (XINT (beg) > XINT (end)) + if (XFIXNUM (beg) > XFIXNUM (end)) { Lisp_Object temp; temp = beg; beg = end; end = temp; @@ -4010,6 +3991,16 @@ buffer. */) unchain_both (ob, overlay); } + else + /* An overlay not associated with any buffer will normally have its + `next' field set to NULL, but not always: when killing a buffer, + we just set its overlays_after and overlays_before to NULL without + manually setting each overlay's `next' field to NULL. + Let's correct it here, to simplify subsequent assertions. + FIXME: Maybe the better fix is to change `kill-buffer'!? */ + XOVERLAY (overlay)->next = NULL; + + eassert (XOVERLAY (overlay)->next == NULL); /* Set the overlay boundaries, which may clip them. */ Fset_marker (OVERLAY_START (overlay), beg, buffer); @@ -4039,10 +4030,20 @@ buffer. */) modify_overlay (b, min (o_beg, n_beg), max (o_end, n_end)); } + eassert (XOVERLAY (overlay)->next == NULL); + /* Delete the overlay if it is empty after clipping and has the evaporate property. */ if (n_beg == n_end && !NILP (Foverlay_get (overlay, Qevaporate))) - return unbind_to (count, Fdelete_overlay (overlay)); + { /* We used to call `Fdelete_overlay' here, but it causes problems: + - At this stage, `overlay' is not included in its buffer's lists + of overlays (the data-structure is in an inconsistent state), + contrary to `Fdelete_overlay's assumptions. + - Most of the work done by Fdelete_overlay has already been done + here for other reasons. */ + drop_overlay (XBUFFER (buffer), XOVERLAY (overlay)); + return unbind_to (count, overlay); + } /* Put the overlay into the new buffer's overlay lists, first on the wrong list. */ @@ -4156,7 +4157,7 @@ If SORTED is non-nil, then sort them by decreasing priority. */) Lisp_Object *overlay_vec; Lisp_Object result; - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); if (!buffer_has_overlays ()) return Qnil; @@ -4167,7 +4168,7 @@ If SORTED is non-nil, then sort them by decreasing priority. */) /* Put all the overlays we want in a vector in overlay_vec. Store the length in len. */ - noverlays = overlays_at (XINT (pos), 1, &overlay_vec, &len, + noverlays = overlays_at (XFIXNUM (pos), 1, &overlay_vec, &len, NULL, NULL, 0); if (!NILP (sorted)) @@ -4200,8 +4201,8 @@ end of the buffer. */) Lisp_Object *overlay_vec; Lisp_Object result; - CHECK_NUMBER_COERCE_MARKER (beg); - CHECK_NUMBER_COERCE_MARKER (end); + CHECK_FIXNUM_COERCE_MARKER (beg); + CHECK_FIXNUM_COERCE_MARKER (end); if (!buffer_has_overlays ()) return Qnil; @@ -4211,7 +4212,7 @@ end of the buffer. */) /* Put all the overlays we want in a vector in overlay_vec. Store the length in len. */ - noverlays = overlays_in (XINT (beg), XINT (end), 1, &overlay_vec, &len, + noverlays = overlays_in (XFIXNUM (beg), XFIXNUM (end), 1, &overlay_vec, &len, NULL, NULL); /* Make a list of them all. */ @@ -4232,10 +4233,10 @@ the value is (point-max). */) ptrdiff_t endpos; Lisp_Object *overlay_vec; - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); if (!buffer_has_overlays ()) - return make_number (ZV); + return make_fixnum (ZV); len = 10; overlay_vec = xmalloc (len * sizeof *overlay_vec); @@ -4243,7 +4244,7 @@ the value is (point-max). */) /* Put all the overlays we want in a vector in overlay_vec. Store the length in len. endpos gets the position where the next overlay starts. */ - noverlays = overlays_at (XINT (pos), 1, &overlay_vec, &len, + noverlays = overlays_at (XFIXNUM (pos), 1, &overlay_vec, &len, &endpos, 0, 1); /* If any of these overlays ends before endpos, @@ -4260,7 +4261,7 @@ the value is (point-max). */) } xfree (overlay_vec); - return make_number (endpos); + return make_fixnum (endpos); } DEFUN ("previous-overlay-change", Fprevious_overlay_change, @@ -4274,14 +4275,14 @@ the value is (point-min). */) Lisp_Object *overlay_vec; ptrdiff_t len; - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); if (!buffer_has_overlays ()) - return make_number (BEGV); + return make_fixnum (BEGV); /* At beginning of buffer, we know the answer; avoid bug subtracting 1 below. */ - if (XINT (pos) == BEGV) + if (XFIXNUM (pos) == BEGV) return pos; len = 10; @@ -4290,11 +4291,11 @@ the value is (point-min). */) /* Put all the overlays we want in a vector in overlay_vec. Store the length in len. prevpos gets the position of the previous change. */ - overlays_at (XINT (pos), 1, &overlay_vec, &len, + overlays_at (XFIXNUM (pos), 1, &overlay_vec, &len, 0, &prevpos, 1); xfree (overlay_vec); - return make_number (prevpos); + return make_fixnum (prevpos); } /* These functions are for debugging overlays. */ @@ -4308,19 +4309,14 @@ The lists you get are copies, so that changing them has no effect. However, the overlays you get are the real objects that the buffer uses. */) (void) { - struct Lisp_Overlay *ol; - Lisp_Object before = Qnil, after = Qnil, tmp; + Lisp_Object before = Qnil, after = Qnil; - for (ol = current_buffer->overlays_before; ol; ol = ol->next) - { - XSETMISC (tmp, ol); - before = Fcons (tmp, before); - } - for (ol = current_buffer->overlays_after; ol; ol = ol->next) - { - XSETMISC (tmp, ol); - after = Fcons (tmp, after); - } + for (struct Lisp_Overlay *ol = current_buffer->overlays_before; + ol; ol = ol->next) + before = Fcons (make_lisp_ptr (ol, Lisp_Vectorlike), before); + for (struct Lisp_Overlay *ol = current_buffer->overlays_after; + ol; ol = ol->next) + after = Fcons (make_lisp_ptr (ol, Lisp_Vectorlike), after); return Fcons (Fnreverse (before), Fnreverse (after)); } @@ -4332,9 +4328,9 @@ for positions far away from POS). */) (Lisp_Object pos) { ptrdiff_t p; - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); - p = clip_to_bounds (PTRDIFF_MIN, XINT (pos), PTRDIFF_MAX); + p = clip_to_bounds (PTRDIFF_MIN, XFIXNUM (pos), PTRDIFF_MAX); recenter_overlay_lists (current_buffer, p); return Qnil; } @@ -4439,13 +4435,8 @@ void report_overlay_modification (Lisp_Object start, Lisp_Object end, bool after, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) { - Lisp_Object prop, overlay; - struct Lisp_Overlay *tail; /* True if this change is an insertion. */ - bool insertion = (after ? XFASTINT (arg3) == 0 : EQ (start, end)); - - overlay = Qnil; - tail = NULL; + bool insertion = (after ? XFIXNAT (arg3) == 0 : EQ (start, end)); /* We used to run the functions as soon as we found them and only register them in last_overlay_modification_hooks for the purpose of the `after' @@ -4460,75 +4451,77 @@ report_overlay_modification (Lisp_Object start, Lisp_Object end, bool after, /* We are being called before a change. Scan the overlays to find the functions to call. */ last_overlay_modification_hooks_used = 0; - for (tail = current_buffer->overlays_before; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { ptrdiff_t startpos, endpos; Lisp_Object ostart, oend; - XSETMISC (overlay, tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); ostart = OVERLAY_START (overlay); oend = OVERLAY_END (overlay); endpos = OVERLAY_POSITION (oend); - if (XFASTINT (start) > endpos) + if (XFIXNAT (start) > endpos) break; startpos = OVERLAY_POSITION (ostart); - if (insertion && (XFASTINT (start) == startpos - || XFASTINT (end) == startpos)) + if (insertion && (XFIXNAT (start) == startpos + || XFIXNAT (end) == startpos)) { - prop = Foverlay_get (overlay, Qinsert_in_front_hooks); + Lisp_Object prop = Foverlay_get (overlay, Qinsert_in_front_hooks); if (!NILP (prop)) add_overlay_mod_hooklist (prop, overlay); } - if (insertion && (XFASTINT (start) == endpos - || XFASTINT (end) == endpos)) + if (insertion && (XFIXNAT (start) == endpos + || XFIXNAT (end) == endpos)) { - prop = Foverlay_get (overlay, Qinsert_behind_hooks); + Lisp_Object prop = Foverlay_get (overlay, Qinsert_behind_hooks); if (!NILP (prop)) add_overlay_mod_hooklist (prop, overlay); } /* Test for intersecting intervals. This does the right thing for both insertion and deletion. */ - if (XFASTINT (end) > startpos && XFASTINT (start) < endpos) + if (XFIXNAT (end) > startpos && XFIXNAT (start) < endpos) { - prop = Foverlay_get (overlay, Qmodification_hooks); + Lisp_Object prop = Foverlay_get (overlay, Qmodification_hooks); if (!NILP (prop)) add_overlay_mod_hooklist (prop, overlay); } } - for (tail = current_buffer->overlays_after; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { ptrdiff_t startpos, endpos; Lisp_Object ostart, oend; - XSETMISC (overlay, tail); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); ostart = OVERLAY_START (overlay); oend = OVERLAY_END (overlay); startpos = OVERLAY_POSITION (ostart); endpos = OVERLAY_POSITION (oend); - if (XFASTINT (end) < startpos) + if (XFIXNAT (end) < startpos) break; - if (insertion && (XFASTINT (start) == startpos - || XFASTINT (end) == startpos)) + if (insertion && (XFIXNAT (start) == startpos + || XFIXNAT (end) == startpos)) { - prop = Foverlay_get (overlay, Qinsert_in_front_hooks); + Lisp_Object prop = Foverlay_get (overlay, Qinsert_in_front_hooks); if (!NILP (prop)) add_overlay_mod_hooklist (prop, overlay); } - if (insertion && (XFASTINT (start) == endpos - || XFASTINT (end) == endpos)) + if (insertion && (XFIXNAT (start) == endpos + || XFIXNAT (end) == endpos)) { - prop = Foverlay_get (overlay, Qinsert_behind_hooks); + Lisp_Object prop = Foverlay_get (overlay, Qinsert_behind_hooks); if (!NILP (prop)) add_overlay_mod_hooklist (prop, overlay); } /* Test for intersecting intervals. This does the right thing for both insertion and deletion. */ - if (XFASTINT (end) > startpos && XFASTINT (start) < endpos) + if (XFIXNAT (end) > startpos && XFIXNAT (start) < endpos) { - prop = Foverlay_get (overlay, Qmodification_hooks); + Lisp_Object prop = Foverlay_get (overlay, Qmodification_hooks); if (!NILP (prop)) add_overlay_mod_hooklist (prop, overlay); } @@ -4584,16 +4577,13 @@ call_overlay_mod_hooks (Lisp_Object list, Lisp_Object overlay, bool after, void evaporate_overlays (ptrdiff_t pos) { - Lisp_Object overlay, hit_list; - struct Lisp_Overlay *tail; - - hit_list = Qnil; + Lisp_Object hit_list = Qnil; if (pos <= current_buffer->overlay_center) - for (tail = current_buffer->overlays_before; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { - ptrdiff_t endpos; - XSETMISC (overlay, tail); - endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + ptrdiff_t endpos = OVERLAY_POSITION (OVERLAY_END (overlay)); if (endpos < pos) break; if (endpos == pos && OVERLAY_POSITION (OVERLAY_START (overlay)) == pos @@ -4601,11 +4591,11 @@ evaporate_overlays (ptrdiff_t pos) hit_list = Fcons (overlay, hit_list); } else - for (tail = current_buffer->overlays_after; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { - ptrdiff_t startpos; - XSETMISC (overlay, tail); - startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + ptrdiff_t startpos = OVERLAY_POSITION (OVERLAY_START (overlay)); if (startpos > pos) break; if (startpos == pos && OVERLAY_POSITION (OVERLAY_END (overlay)) == pos @@ -5070,41 +5060,41 @@ init_buffer_once (void) /* 0 means not a lisp var, -1 means always local, else mask. */ memset (&buffer_local_flags, 0, sizeof buffer_local_flags); - bset_filename (&buffer_local_flags, make_number (-1)); - bset_directory (&buffer_local_flags, make_number (-1)); - bset_backed_up (&buffer_local_flags, make_number (-1)); - bset_save_length (&buffer_local_flags, make_number (-1)); - bset_auto_save_file_name (&buffer_local_flags, make_number (-1)); - bset_read_only (&buffer_local_flags, make_number (-1)); - bset_major_mode (&buffer_local_flags, make_number (-1)); - bset_mode_name (&buffer_local_flags, make_number (-1)); - bset_undo_list (&buffer_local_flags, make_number (-1)); - bset_mark_active (&buffer_local_flags, make_number (-1)); - bset_point_before_scroll (&buffer_local_flags, make_number (-1)); - bset_file_truename (&buffer_local_flags, make_number (-1)); - bset_invisibility_spec (&buffer_local_flags, make_number (-1)); - bset_file_format (&buffer_local_flags, make_number (-1)); - bset_auto_save_file_format (&buffer_local_flags, make_number (-1)); - bset_display_count (&buffer_local_flags, make_number (-1)); - bset_display_time (&buffer_local_flags, make_number (-1)); - bset_enable_multibyte_characters (&buffer_local_flags, make_number (-1)); + bset_filename (&buffer_local_flags, make_fixnum (-1)); + bset_directory (&buffer_local_flags, make_fixnum (-1)); + bset_backed_up (&buffer_local_flags, make_fixnum (-1)); + bset_save_length (&buffer_local_flags, make_fixnum (-1)); + bset_auto_save_file_name (&buffer_local_flags, make_fixnum (-1)); + bset_read_only (&buffer_local_flags, make_fixnum (-1)); + bset_major_mode (&buffer_local_flags, make_fixnum (-1)); + bset_mode_name (&buffer_local_flags, make_fixnum (-1)); + bset_undo_list (&buffer_local_flags, make_fixnum (-1)); + bset_mark_active (&buffer_local_flags, make_fixnum (-1)); + bset_point_before_scroll (&buffer_local_flags, make_fixnum (-1)); + bset_file_truename (&buffer_local_flags, make_fixnum (-1)); + bset_invisibility_spec (&buffer_local_flags, make_fixnum (-1)); + bset_file_format (&buffer_local_flags, make_fixnum (-1)); + bset_auto_save_file_format (&buffer_local_flags, make_fixnum (-1)); + bset_display_count (&buffer_local_flags, make_fixnum (-1)); + bset_display_time (&buffer_local_flags, make_fixnum (-1)); + bset_enable_multibyte_characters (&buffer_local_flags, make_fixnum (-1)); /* These used to be stuck at 0 by default, but now that the all-zero value means Qnil, we have to initialize them explicitly. */ - bset_name (&buffer_local_flags, make_number (0)); - bset_mark (&buffer_local_flags, make_number (0)); - bset_local_var_alist (&buffer_local_flags, make_number (0)); - bset_keymap (&buffer_local_flags, make_number (0)); - bset_downcase_table (&buffer_local_flags, make_number (0)); - bset_upcase_table (&buffer_local_flags, make_number (0)); - bset_case_canon_table (&buffer_local_flags, make_number (0)); - bset_case_eqv_table (&buffer_local_flags, make_number (0)); - bset_minor_modes (&buffer_local_flags, make_number (0)); - bset_width_table (&buffer_local_flags, make_number (0)); - bset_pt_marker (&buffer_local_flags, make_number (0)); - bset_begv_marker (&buffer_local_flags, make_number (0)); - bset_zv_marker (&buffer_local_flags, make_number (0)); - bset_last_selected_window (&buffer_local_flags, make_number (0)); + bset_name (&buffer_local_flags, make_fixnum (0)); + bset_mark (&buffer_local_flags, make_fixnum (0)); + bset_local_var_alist (&buffer_local_flags, make_fixnum (0)); + bset_keymap (&buffer_local_flags, make_fixnum (0)); + bset_downcase_table (&buffer_local_flags, make_fixnum (0)); + bset_upcase_table (&buffer_local_flags, make_fixnum (0)); + bset_case_canon_table (&buffer_local_flags, make_fixnum (0)); + bset_case_eqv_table (&buffer_local_flags, make_fixnum (0)); + bset_minor_modes (&buffer_local_flags, make_fixnum (0)); + bset_width_table (&buffer_local_flags, make_fixnum (0)); + bset_pt_marker (&buffer_local_flags, make_fixnum (0)); + bset_begv_marker (&buffer_local_flags, make_fixnum (0)); + bset_zv_marker (&buffer_local_flags, make_fixnum (0)); + bset_last_selected_window (&buffer_local_flags, make_fixnum (0)); idx = 1; XSETFASTINT (BVAR (&buffer_local_flags, mode_line_format), idx); ++idx; @@ -5115,7 +5105,9 @@ init_buffer_once (void) XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx; - XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx; + XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); + /* Make this one a permanent local. */ + buffer_permanent_local_flags[idx++] = 1; XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx; @@ -5276,9 +5268,7 @@ init_buffer_once (void) void init_buffer (int initialized) { - char *pwd; Lisp_Object temp; - ptrdiff_t len; #ifdef USE_MMAP_FOR_BUFFERS if (initialized) @@ -5332,7 +5322,7 @@ init_buffer (int initialized) if (NILP (BVAR (&buffer_defaults, enable_multibyte_characters))) Fset_buffer_multibyte (Qnil); - pwd = emacs_get_current_dir_name (); + char const *pwd = emacs_wd; if (!pwd) { @@ -5344,22 +5334,16 @@ init_buffer (int initialized) { /* Maybe this should really use some standard subroutine whose definition is filename syntax dependent. */ - len = strlen (pwd); - if (!(IS_DIRECTORY_SEP (pwd[len - 1]))) - { - /* Grow buffer to add directory separator and '\0'. */ - pwd = realloc (pwd, len + 2); - if (!pwd) - fatal ("get_current_dir_name: %s\n", strerror (errno)); - pwd[len] = DIRECTORY_SEP; - pwd[len + 1] = '\0'; - len++; - } + ptrdiff_t len = strlen (pwd); + bool add_slash = ! IS_DIRECTORY_SEP (pwd[len - 1]); /* At this moment, we still don't know how to decode the directory name. So, we keep the bytes in unibyte form so that file I/O routines correctly get the original bytes. */ - bset_directory (current_buffer, make_unibyte_string (pwd, len)); + Lisp_Object dirname = make_unibyte_string (pwd, len + add_slash); + if (add_slash) + SSET (dirname, len, DIRECTORY_SEP); + bset_directory (current_buffer, dirname); /* Add /: to the front of the name if it would otherwise be treated as magic. */ @@ -5380,8 +5364,6 @@ init_buffer (int initialized) temp = get_minibuffer (0); bset_directory (XBUFFER (temp), BVAR (current_buffer, directory)); - - free (pwd); } /* Similar to defvar_lisp but define a variable whose value is the @@ -5428,8 +5410,7 @@ void syms_of_buffer (void) { staticpro (&last_overlay_modification_hooks); - last_overlay_modification_hooks - = Fmake_vector (make_number (10), Qnil); + last_overlay_modification_hooks = make_nil_vector (10); staticpro (&QSFundamental); staticpro (&Vbuffer_alist); @@ -5570,17 +5551,17 @@ Use the command `abbrev-mode' to change this variable. */); doc: /* Non-nil if searches and matches should ignore case. */); DEFVAR_PER_BUFFER ("fill-column", &BVAR (current_buffer, fill_column), - Qintegerp, + Qfixnump, doc: /* Column beyond which automatic line-wrapping should happen. Interactively, you can set the buffer local value using \\[set-fill-column]. */); DEFVAR_PER_BUFFER ("left-margin", &BVAR (current_buffer, left_margin), - Qintegerp, + Qfixnump, doc: /* Column for the default `indent-line-function' to indent to. Linefeed indents to this column in Fundamental mode. */); DEFVAR_PER_BUFFER ("tab-width", &BVAR (current_buffer, tab_width), - Qintegerp, + Qfixnump, doc: /* Distance between tab stops (for display of tab characters), in columns. NOTE: This controls the display width of a TAB character, and not the size of an indentation step. @@ -5714,8 +5695,8 @@ visual lines rather than logical lines. See the documentation of DEFVAR_PER_BUFFER ("default-directory", &BVAR (current_buffer, directory), Qstringp, doc: /* Name of default directory of current buffer. -It should be a directory name (as opposed to a directory file-name). -On GNU and Unix systems, directory names end in a slash `/'. +It should be an absolute directory name; on GNU and Unix systems, +these names start with `/' or `~' and end with `/'. To interactively change the default directory, use command `cd'. */); DEFVAR_PER_BUFFER ("auto-fill-function", &BVAR (current_buffer, auto_fill_function), @@ -5751,7 +5732,7 @@ If it is nil, that means don't auto-save this buffer. */); Backing up is done before the first time the file is saved. */); DEFVAR_PER_BUFFER ("buffer-saved-size", &BVAR (current_buffer, save_length), - Qintegerp, + Qfixnump, doc: /* Length of current buffer when last read in, saved or auto-saved. 0 initially. -1 means auto-saving turned off until next real save. @@ -5825,7 +5806,7 @@ In addition, a char-table has six extra slots to control the display of: See also the functions `display-table-slot' and `set-display-table-slot'. */); DEFVAR_PER_BUFFER ("left-margin-width", &BVAR (current_buffer, left_margin_cols), - Qintegerp, + Qfixnump, doc: /* Width in columns of left marginal area for display of a buffer. A value of nil means no marginal area. @@ -5833,7 +5814,7 @@ Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); DEFVAR_PER_BUFFER ("right-margin-width", &BVAR (current_buffer, right_margin_cols), - Qintegerp, + Qfixnump, doc: /* Width in columns of right marginal area for display of a buffer. A value of nil means no marginal area. @@ -5841,7 +5822,7 @@ Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); DEFVAR_PER_BUFFER ("left-fringe-width", &BVAR (current_buffer, left_fringe_width), - Qintegerp, + Qfixnump, doc: /* Width of this buffer's left fringe (in pixels). A value of 0 means no left fringe is shown in this buffer's window. A value of nil means to use the left fringe width from the window's frame. @@ -5850,7 +5831,7 @@ Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); DEFVAR_PER_BUFFER ("right-fringe-width", &BVAR (current_buffer, right_fringe_width), - Qintegerp, + Qfixnump, doc: /* Width of this buffer's right fringe (in pixels). A value of 0 means no right fringe is shown in this buffer's window. A value of nil means to use the right fringe width from the window's frame. @@ -5867,12 +5848,12 @@ Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); DEFVAR_PER_BUFFER ("scroll-bar-width", &BVAR (current_buffer, scroll_bar_width), - Qintegerp, + Qfixnump, doc: /* Width of this buffer's vertical scroll bars in pixels. A value of nil means to use the scroll bar width from the window's frame. */); DEFVAR_PER_BUFFER ("scroll-bar-height", &BVAR (current_buffer, scroll_bar_height), - Qintegerp, + Qfixnump, doc: /* Height of this buffer's horizontal scroll bars in pixels. A value of nil means to use the scroll bar height from the window's frame. */); @@ -6038,11 +6019,11 @@ An entry (TEXT . POSITION) represents the deletion of the string TEXT from (abs POSITION). If POSITION is positive, point was at the front of the text being deleted; if negative, point was at the end. -An entry (t HIGH LOW USEC PSEC) indicates that the buffer was previously -unmodified; (HIGH LOW USEC PSEC) is in the same style as (current-time) -and is the visited file's modification time, as of that time. If the -modification time of the most recent save is different, this entry is -obsolete. +An entry (t . TIMESTAMP), where TIMESTAMP is in the style of +`current-time', indicates that the buffer was previously unmodified; +TIMESTAMP is the visited file's modification time, as of that time. +If the modification time of the most recent save is different, this +entry is obsolete. An entry (t . 0) means the buffer was previously unmodified but its time stamp was unknown because it was not associated with a file. @@ -6142,7 +6123,7 @@ Setting this variable is very fast, much faster than scanning all the text in the buffer looking for properties to change. */); DEFVAR_PER_BUFFER ("buffer-display-count", - &BVAR (current_buffer, display_count), Qintegerp, + &BVAR (current_buffer, display_count), Qfixnump, doc: /* A number incremented each time this buffer is displayed in a window. The function `set-window-buffer' increments it. */); diff --git a/src/buffer.h b/src/buffer.h index b8322294031..82cc2ebfbf9 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -288,28 +288,6 @@ extern void enlarge_buffer_text (struct buffer *, ptrdiff_t); or convert between a byte position and an address. These macros do not check that the position is in range. */ -/* Access a Lisp position value in POS, - and store the charpos in CHARPOS and the bytepos in BYTEPOS. */ - -#define DECODE_POSITION(charpos, bytepos, pos) \ - do \ - { \ - Lisp_Object __pos = (pos); \ - if (NUMBERP (__pos)) \ - { \ - charpos = __pos; \ - bytepos = buf_charpos_to_bytepos (current_buffer, __pos); \ - } \ - else if (MARKERP (__pos)) \ - { \ - charpos = marker_position (__pos); \ - bytepos = marker_byte_position (__pos); \ - } \ - else \ - wrong_type_argument (Qinteger_or_marker_p, __pos); \ - } \ - while (false) - /* Maximum number of bytes in a buffer. A buffer cannot contain more bytes than a 1-origin fixnum can represent, nor can it be so large that C pointer arithmetic stops working. @@ -912,7 +890,7 @@ INLINE struct buffer * XBUFFER (Lisp_Object a) { eassert (BUFFERP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct buffer); } /* Most code should use these functions to set Lisp fields in struct @@ -1349,7 +1327,7 @@ extern int last_per_buffer_idx; #define PER_BUFFER_IDX(OFFSET) \ - XINT (*(Lisp_Object *)((OFFSET) + (char *) &buffer_local_flags)) + XFIXNUM (*(Lisp_Object *)((OFFSET) + (char *) &buffer_local_flags)) /* Functions to get and set default value of the per-buffer variable at offset OFFSET in the buffer structure. */ @@ -1387,7 +1365,7 @@ downcase (int c) { Lisp_Object downcase_table = BVAR (current_buffer, downcase_table); Lisp_Object down = CHAR_TABLE_REF (downcase_table, c); - return NATNUMP (down) ? XFASTINT (down) : c; + return FIXNATP (down) ? XFIXNAT (down) : c; } /* Upcase a character C, or make no change if that cannot be done. */ @@ -1396,7 +1374,7 @@ upcase (int c) { Lisp_Object upcase_table = BVAR (current_buffer, upcase_table); Lisp_Object up = CHAR_TABLE_REF (upcase_table, c); - return NATNUMP (up) ? XFASTINT (up) : c; + return FIXNATP (up) ? XFIXNAT (up) : c; } /* True if C is upper case. */ diff --git a/src/bytecode.c b/src/bytecode.c index a5c7576269f..bb7d796bac5 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "character.h" #include "buffer.h" #include "keyboard.h" +#include "ptr-bounds.h" #include "syntax.h" #include "window.h" @@ -62,14 +63,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ { \ if (byte_metering_on) \ { \ - if (XFASTINT (METER_1 (this_code)) < MOST_POSITIVE_FIXNUM) \ + if (XFIXNAT (METER_1 (this_code)) < MOST_POSITIVE_FIXNUM) \ XSETFASTINT (METER_1 (this_code), \ - XFASTINT (METER_1 (this_code)) + 1); \ + XFIXNAT (METER_1 (this_code)) + 1); \ if (last_code \ - && (XFASTINT (METER_2 (last_code, this_code)) \ + && (XFIXNAT (METER_2 (last_code, this_code)) \ < MOST_POSITIVE_FIXNUM)) \ XSETFASTINT (METER_2 (last_code, this_code), \ - XFASTINT (METER_2 (last_code, this_code)) + 1); \ + XFIXNAT (METER_2 (last_code, this_code)) + 1); \ } \ } @@ -345,7 +346,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CHECK_STRING (bytestr); CHECK_VECTOR (vector); - CHECK_NATNUM (maxdepth); + CHECK_FIXNAT (maxdepth); ptrdiff_t const_length = ASIZE (vector); @@ -361,31 +362,33 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object *vectorp = XVECTOR (vector)->contents; unsigned char quitcounter = 1; - EMACS_INT stack_items = XFASTINT (maxdepth) + 1; + EMACS_INT stack_items = XFIXNAT (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; + void *alloc; + SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length); + ptrdiff_t item_bytes = stack_items * word_size; + Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes); Lisp_Object *top = stack_base; *top = vector; /* Ensure VECTOR survives GC (Bug#33014). */ - memcpy (stack_lim, SDATA (bytestr), bytestr_length); - void *void_stack_lim = stack_lim; - unsigned char const *bytestr_data = void_stack_lim; + Lisp_Object *stack_lim = stack_base + stack_items; + unsigned char *bytestr_data = alloc; + bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length); + memcpy (bytestr_data, SDATA (bytestr), bytestr_length); unsigned char const *pc = bytestr_data; ptrdiff_t count = SPECPDL_INDEX (); if (!NILP (args_template)) { - eassert (INTEGERP (args_template)); - ptrdiff_t at = XINT (args_template); + eassert (FIXNUMP (args_template)); + ptrdiff_t at = XFIXNUM (args_template); bool rest = (at & 128) != 0; int mandatory = at & 127; ptrdiff_t nonrest = at >> 8; 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))); + list2 (Fcons (make_fixnum (mandatory), make_fixnum (nonrest)), + make_fixnum (nargs))); ptrdiff_t pushedargs = min (nonrest, nargs); for (ptrdiff_t i = 0; i < pushedargs; i++, args++) PUSH (*args); @@ -619,10 +622,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { Lisp_Object v1 = TOP; Lisp_Object v2 = Fget (v1, Qbyte_code_meter); - if (INTEGERP (v2) - && XINT (v2) < MOST_POSITIVE_FIXNUM) + if (FIXNUMP (v2) + && XFIXNUM (v2) < MOST_POSITIVE_FIXNUM) { - XSETINT (v2, XINT (v2) + 1); + XSETINT (v2, XFIXNUM (v2) + 1); Fput (v1, Qbyte_code_meter, v2); } } @@ -737,8 +740,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bsave_excursion): - record_unwind_protect (save_excursion_restore, - save_excursion_save ()); + record_unwind_protect_excursion (); NEXT; CASE (Bsave_current_buffer): /* Obsolete since ??. */ @@ -831,13 +833,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bnth): { Lisp_Object v2 = POP, v1 = TOP; - CHECK_NUMBER (v1); - for (EMACS_INT n = XINT (v1); 0 < n && CONSP (v2); n--) + if (RANGED_FIXNUMP (0, v1, SMALL_LIST_LEN_MAX)) { - v2 = XCDR (v2); - rarely_quit (n); + for (EMACS_INT n = XFIXNUM (v1); 0 < n && CONSP (v2); n--) + v2 = XCDR (v2); + TOP = CAR (v2); } - TOP = CAR (v2); + else + TOP = Fnth (v1, v2); NEXT; } @@ -971,24 +974,21 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bsub1): - TOP = INTEGERP (TOP) ? make_number (XINT (TOP) - 1) : Fsub1 (TOP); + TOP = (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (XFIXNUM (TOP) - 1) + : Fsub1 (TOP)); NEXT; CASE (Badd1): - TOP = INTEGERP (TOP) ? make_number (XINT (TOP) + 1) : Fadd1 (TOP); + TOP = (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM + ? make_fixnum (XFIXNUM (TOP) + 1) + : Fadd1 (TOP)); NEXT; CASE (Beqlsign): { - Lisp_Object v2 = POP, v1 = TOP; - if (FLOATP (v1) || FLOATP (v2)) - TOP = arithcompare (v1, v2, ARITH_EQUAL); - else - { - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2); - TOP = EQ (v1, v2) ? Qt : Qnil; - } + Lisp_Object v1 = POP; + TOP = arithcompare (TOP, v1, ARITH_EQUAL); NEXT; } @@ -1026,7 +1026,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bnegate): - TOP = INTEGERP (TOP) ? make_number (- XINT (TOP)) : Fminus (1, &TOP); + TOP = (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) + : Fminus (1, &TOP)); NEXT; CASE (Bplus): @@ -1062,7 +1064,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } CASE (Bpoint): - PUSH (make_natnum (PT)); + PUSH (make_fixed_natnum (PT)); NEXT; CASE (Bgoto_char): @@ -1088,7 +1090,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } CASE (Bpoint_min): - PUSH (make_natnum (BEGV)); + PUSH (make_fixed_natnum (BEGV)); NEXT; CASE (Bchar_after): @@ -1104,7 +1106,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bcurrent_column): - PUSH (make_natnum (current_column ())); + PUSH (make_fixed_natnum (current_column ())); NEXT; CASE (Bindent_to): @@ -1168,7 +1170,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bchar_syntax): { CHECK_CHARACTER (TOP); - int c = XFASTINT (TOP); + int c = XFIXNAT (TOP); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) MAKE_CHAR_MULTIBYTE (c); XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]); @@ -1257,23 +1259,16 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Belt): { - if (CONSP (TOP)) + Lisp_Object v2 = POP, v1 = TOP; + if (CONSP (v1) && RANGED_FIXNUMP (0, v2, SMALL_LIST_LEN_MAX)) { - /* Exchange args and then do nth. */ - Lisp_Object v2 = POP, v1 = TOP; - CHECK_NUMBER (v2); - for (EMACS_INT n = XINT (v2); 0 < n && CONSP (v1); n--) - { - v1 = XCDR (v1); - rarely_quit (n); - } + /* Like the fast case for Bnth, but with args reversed. */ + for (EMACS_INT n = XFIXNUM (v2); 0 < n && CONSP (v1); n--) + v1 = XCDR (v1); TOP = CAR (v1); } else - { - Lisp_Object v1 = POP; - TOP = Felt (TOP, v1); - } + TOP = Felt (v1, v2); NEXT; } @@ -1414,7 +1409,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ Lisp_Object hash_code = h->test.cmpfn - ? make_number (h->test.hashfn (&h->test, v1)) : Qnil; + ? make_fixnum (h->test.hashfn (&h->test, v1)) : Qnil; for (i = h->count; 0 <= --i; ) if (EQ (v1, HASH_KEY (h, i)) @@ -1430,9 +1425,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (i >= 0) { Lisp_Object val = HASH_VALUE (h, i); - if (BYTE_CODE_SAFE && !INTEGERP (val)) + if (BYTE_CODE_SAFE && !FIXNUMP (val)) emacs_abort (); - op = XINT (val); + op = XFIXNUM (val); goto op_branch; } } @@ -1467,14 +1462,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object get_byte_code_arity (Lisp_Object args_template) { - eassert (NATNUMP (args_template)); - EMACS_INT at = XINT (args_template); + eassert (FIXNATP (args_template)); + EMACS_INT at = XFIXNUM (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)); + return Fcons (make_fixnum (mandatory), + rest ? Qmany : make_fixnum (nonrest)); } void @@ -1499,13 +1494,9 @@ 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 = false; - Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0)); + Vbyte_code_meter = make_nil_vector (256); DEFSYM (Qbyte_code_meter, "byte-code-meter"); - { - int i = 256; - while (i--) - ASET (Vbyte_code_meter, i, - Fmake_vector (make_number (256), make_number (0))); - } + for (int i = 0; i < 256; i++) + ASET (Vbyte_code_meter, i, make_vector (256, make_fixnum (0))); #endif } diff --git a/src/callint.c b/src/callint.c index 82e407fb966..dac905e16f4 100644 --- a/src/callint.c +++ b/src/callint.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include "lisp.h" +#include "ptr-bounds.h" #include "character.h" #include "buffer.h" #include "keyboard.h" @@ -199,8 +200,8 @@ fix_command (Lisp_Object input, Lisp_Object values) carelt = XCAR (elt); /* If it is (if X Y), look at Y. */ if (EQ (carelt, Qif) - && EQ (Fnthcdr (make_number (3), elt), Qnil)) - elt = Fnth (make_number (2), elt); + && NILP (Fnthcdr (make_fixnum (3), elt))) + elt = Fnth (make_fixnum (2), elt); /* If it is (when ... Y), look at Y. */ else if (EQ (carelt, Qwhen)) { @@ -261,7 +262,7 @@ to the function `interactive' at the top level of the function body. See `interactive'. Optional second arg RECORD-FLAG non-nil -means unconditionally put this command in the command-history. +means unconditionally put this command in the variable `command-history'. Otherwise, this is done only if an arg is read using the minibuffer. Optional third arg KEYS, if given, specifies the sequence of events to @@ -270,44 +271,16 @@ invoke it. If KEYS is omitted or nil, the return value of `this-command-keys-vector' is used. */) (Lisp_Object function, Lisp_Object record_flag, Lisp_Object keys) { - /* `args' will contain the array of arguments to pass to the function. - `visargs' will contain the same list but in a nicer form, so that if we - pass it to Fformat_message it will be understandable to a human. */ - Lisp_Object *args, *visargs; - Lisp_Object specs; - Lisp_Object filter_specs; - Lisp_Object teml; - Lisp_Object up_event; - Lisp_Object enable; - USE_SAFE_ALLOCA; ptrdiff_t speccount = SPECPDL_INDEX (); - /* The index of the next element of this_command_keys to examine for - the 'e' interactive code. */ - ptrdiff_t next_event; - - Lisp_Object prefix_arg; - char *string; - const char *tem; - - /* If varies[i] > 0, the i'th argument shouldn't just have its value - in this call quoted in the command history. It should be - recorded as a call to the function named callint_argfuns[varies[i]]. */ - signed char *varies; - - ptrdiff_t i, nargs; - ptrdiff_t mark; - bool arg_from_tty = 0; + bool arg_from_tty = false; ptrdiff_t key_count; - bool record_then_fail = 0; - - Lisp_Object save_this_command, save_last_command; - Lisp_Object save_this_original_command, save_real_this_command; + bool record_then_fail = false; - save_this_command = Vthis_command; - save_this_original_command = Vthis_original_command; - save_real_this_command = Vreal_this_command; - save_last_command = KVAR (current_kboard, Vlast_command); + Lisp_Object save_this_command = Vthis_command; + Lisp_Object save_this_original_command = Vthis_original_command; + Lisp_Object save_real_this_command = Vreal_this_command; + Lisp_Object save_last_command = KVAR (current_kboard, Vlast_command); if (NILP (keys)) keys = this_command_keys, key_count = this_command_key_count; @@ -318,66 +291,45 @@ invoke it. If KEYS is omitted or nil, the return value of } /* Save this now, since use of minibuffer will clobber it. */ - prefix_arg = Vcurrent_prefix_arg; + Lisp_Object prefix_arg = Vcurrent_prefix_arg; - if (SYMBOLP (function)) - enable = Fget (function, Qenable_recursive_minibuffers); - else - enable = Qnil; - - specs = Qnil; - string = 0; - /* The idea of FILTER_SPECS is to provide a way to - specify how to represent the arguments in command history. - The feature is not fully implemented. */ - filter_specs = Qnil; + Lisp_Object enable = (SYMBOLP (function) + ? Fget (function, Qenable_recursive_minibuffers) + : Qnil); /* If k or K discard an up-event, save it here so it can be retrieved with U. */ - up_event = Qnil; + Lisp_Object up_event = Qnil; /* Set SPECS to the interactive form, or barf if not interactive. */ - { - Lisp_Object form; - form = Finteractive_form (function); - if (CONSP (form)) - specs = filter_specs = Fcar (XCDR (form)); - else - wrong_type_argument (Qcommandp, function); - } + Lisp_Object form = Finteractive_form (function); + if (! CONSP (form)) + wrong_type_argument (Qcommandp, function); + Lisp_Object specs = Fcar (XCDR (form)); + + /* At this point the value of SPECS could help provide a way to + specify how to represent the arguments in command history. + The feature is not fully implemented. */ /* If SPECS is not a string, invent one. */ if (! STRINGP (specs)) { - Lisp_Object input; Lisp_Object funval = Findirect_function (function, Qt); uintmax_t events = num_input_events; - input = specs; + Lisp_Object input = specs; /* Compute the arg values using the user's expression. */ specs = Feval (specs, CONSP (funval) && EQ (Qclosure, XCAR (funval)) ? CAR_SAFE (XCDR (funval)) : Qnil); if (events != num_input_events || !NILP (record_flag)) { - /* We should record this command on the command history. */ - Lisp_Object values; - Lisp_Object this_cmd; - /* Make a copy of the list of values, for the command history, + /* We should record this command on the command history. + Make a copy of the list of values, for the command history, and turn them into things we can eval. */ - values = quotify_args (Fcopy_sequence (specs)); + Lisp_Object values = quotify_args (Fcopy_sequence (specs)); fix_command (input, values); - this_cmd = Fcons (function, values); - if (history_delete_duplicates) - Vcommand_history = Fdelete (this_cmd, Vcommand_history); - Vcommand_history = Fcons (this_cmd, Vcommand_history); - - /* Don't keep command history around forever. */ - if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0) - { - teml = Fnthcdr (Vhistory_length, Vcommand_history); - if (CONSP (teml)) - XSETCDR (teml, Qnil); - } + call4 (intern ("add-to-history"), intern ("command-history"), + Fcons (function, values), Qnil, Qt); } Vthis_command = save_this_command; @@ -385,46 +337,42 @@ invoke it. If KEYS is omitted or nil, the return value of Vreal_this_command = save_real_this_command; kset_last_command (current_kboard, save_last_command); - Lisp_Object result - = unbind_to (speccount, CALLN (Fapply, Qfuncall_interactively, - function, specs)); - SAFE_FREE (); - return result; + return unbind_to (speccount, CALLN (Fapply, Qfuncall_interactively, + function, specs)); } /* SPECS is set to a string; use it as an interactive prompt. Copy it so that STRING will be valid even if a GC relocates SPECS. */ - SAFE_ALLOCA_STRING (string, specs); - - /* Here if function specifies a string to control parsing the defaults. */ + USE_SAFE_ALLOCA; + ptrdiff_t string_len = SBYTES (specs); + char *string = SAFE_ALLOCA (string_len + 1); + memcpy (string, SDATA (specs), string_len + 1); + char *string_end = string + string_len; - /* Set next_event to point to the first event with parameters. */ + /* The index of the next element of this_command_keys to examine for + the 'e' interactive code. Initialize it to point to the first + event with parameters. */ + ptrdiff_t next_event; for (next_event = 0; next_event < key_count; next_event++) if (EVENT_HAS_PARAMETERS (AREF (keys, next_event))) break; /* Handle special starting chars `*' and `@'. Also `-'. */ /* Note that `+' is reserved for user extensions. */ - while (1) + for (;; string++) { if (*string == '+') error ("`+' is not used in `interactive' for ordinary commands"); else if (*string == '*') { - string++; if (!NILP (BVAR (current_buffer, read_only))) { if (!NILP (record_flag)) { - char *p = string; - while (*p) - { - if (! (*p == 'r' || *p == 'p' || *p == 'P' - || *p == '\n')) - Fbarf_if_buffer_read_only (Qnil); - p++; - } - record_then_fail = 1; + for (char *p = string + 1; p < string_end; p++) + if (! (*p == 'r' || *p == 'p' || *p == 'P' || *p == '\n')) + Fbarf_if_buffer_read_only (Qnil); + record_then_fail = true; } else Fbarf_if_buffer_read_only (Qnil); @@ -432,14 +380,12 @@ invoke it. If KEYS is omitted or nil, the return value of } /* Ignore this for semi-compatibility with Lucid. */ else if (*string == '-') - string++; + ; else if (*string == '@') { - Lisp_Object event, w; - - event = (next_event < key_count - ? AREF (keys, next_event) - : Qnil); + Lisp_Object w, event = (next_event < key_count + ? AREF (keys, next_event) + : Qnil); if (EVENT_HAS_PARAMETERS (event) && (w = XCDR (event), CONSP (w)) && (w = XCAR (w), CONSP (w)) @@ -454,32 +400,23 @@ invoke it. If KEYS is omitted or nil, the return value of Fselect_window (w, Qnil); } - string++; } else if (*string == '^') - { - call0 (Qhandle_shift_selection); - string++; - } + call0 (Qhandle_shift_selection); else break; } /* Count the number of arguments, which is two (the function itself and `funcall-interactively') plus the number of arguments the interactive spec would have us give to the function. */ - tem = string; - for (nargs = 2; *tem; ) + ptrdiff_t nargs = 2; + for (char const *tem = string; tem < string_end; tem++) { /* 'r' specifications ("point and mark as 2 numeric args") produce *two* arguments. */ - if (*tem == 'r') - nargs += 2; - else - nargs++; - tem = strchr (tem, '\n'); - if (tem) - ++tem; - else + nargs += 1 + (*tem == 'r'); + tem = memchr (tem, '\n', string_len - (tem - string)); + if (!tem) break; } @@ -487,21 +424,34 @@ invoke it. If KEYS is omitted or nil, the return value of && MOST_POSITIVE_FIXNUM < nargs) memory_full (SIZE_MAX); - /* Allocate them all at one go. This wastes a bit of memory, but + /* ARGS will contain the array of arguments to pass to the function. + VISARGS will contain the same list but in a nicer form, so that if we + pass it to Fformat_message it will be understandable to a human. + Allocate them all at one go. This wastes a bit of memory, but it's OK to trade space for speed. */ + Lisp_Object *args; SAFE_NALLOCA (args, 3, nargs); - visargs = args + nargs; - varies = (signed char *) (visargs + nargs); + Lisp_Object *visargs = args + nargs; + /* If varies[I] > 0, the Ith argument shouldn't just have its value + in this call quoted in the command history. It should be + recorded as a call to the function named callint_argfuns[varies[I]]. */ + signed char *varies = (signed char *) (visargs + nargs); memclear (args, nargs * (2 * word_size + 1)); + args = ptr_bounds_clip (args, nargs * sizeof *args); + visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs); + varies = ptr_bounds_clip (varies, nargs * sizeof *varies); if (!NILP (enable)) specbind (Qenable_recursive_minibuffers, Qt); - tem = string; - for (i = 2; *tem; i++) + char const *tem = string; + for (ptrdiff_t i = 2; tem < string_end; i++) { - visargs[1] = make_string (tem + 1, strcspn (tem + 1, "\n")); + char *pnl = memchr (tem + 1, '\n', string_len - (tem + 1 - string)); + ptrdiff_t sz = pnl ? pnl - (tem + 1) : string_end - (tem + 1); + + visargs[1] = make_string (tem + 1, sz); callint_message = Fformat_message (i - 1, visargs + 1); switch (*tem) @@ -510,9 +460,7 @@ invoke it. If KEYS is omitted or nil, the return value of visargs[i] = Fcompleting_read (callint_message, Vobarray, Qfboundp, Qt, Qnil, Qnil, Qnil, Qnil); - /* Passing args[i] directly stimulates compiler bug. */ - teml = visargs[i]; - args[i] = Fintern (teml, Qnil); + args[i] = Fintern (visargs[i], Qnil); break; case 'b': /* Name of existing buffer. */ @@ -524,31 +472,29 @@ invoke it. If KEYS is omitted or nil, the return value of case 'B': /* Name of buffer, possibly nonexistent. */ args[i] = Fread_buffer (callint_message, - Fother_buffer (Fcurrent_buffer (), Qnil, Qnil), + Fother_buffer (Fcurrent_buffer (), + Qnil, Qnil), Qnil, Qnil); break; case 'c': /* Character. */ /* Prompt in `minibuffer-prompt' face. */ - Fput_text_property (make_number (0), - make_number (SCHARS (callint_message)), + Fput_text_property (make_fixnum (0), + make_fixnum (SCHARS (callint_message)), Qface, Qminibuffer_prompt, callint_message); args[i] = Fread_char (callint_message, Qnil, Qnil); message1_nolog (0); - /* Passing args[i] directly stimulates compiler bug. */ - teml = args[i]; /* See bug#8479. */ - if (! CHARACTERP (teml)) error ("Non-character input-event"); - visargs[i] = Fchar_to_string (teml); + if (! CHARACTERP (args[i])) + error ("Non-character input-event"); + visargs[i] = Fchar_to_string (args[i]); break; case 'C': /* Command: symbol with interactive function. */ visargs[i] = Fcompleting_read (callint_message, Vobarray, Qcommandp, Qt, Qnil, Qnil, Qnil, Qnil); - /* Passing args[i] directly stimulates compiler bug. */ - teml = visargs[i]; - args[i] = Fintern (teml, Qnil); + args[i] = Fintern (visargs[i], Qnil); break; case 'd': /* Value of point. Does not do I/O. */ @@ -559,8 +505,8 @@ invoke it. If KEYS is omitted or nil, the return value of break; case 'D': /* Directory name. */ - args[i] = read_file_name (BVAR (current_buffer, directory), Qlambda, Qnil, - Qfile_directory_p); + args[i] = read_file_name (BVAR (current_buffer, directory), Qlambda, + Qnil, Qfile_directory_p); break; case 'f': /* Existing file name. */ @@ -585,27 +531,25 @@ invoke it. If KEYS is omitted or nil, the return value of ptrdiff_t speccount1 = SPECPDL_INDEX (); specbind (Qcursor_in_echo_area, Qt); /* Prompt in `minibuffer-prompt' face. */ - Fput_text_property (make_number (0), - make_number (SCHARS (callint_message)), + Fput_text_property (make_fixnum (0), + make_fixnum (SCHARS (callint_message)), Qface, Qminibuffer_prompt, callint_message); args[i] = Fread_key_sequence (callint_message, Qnil, Qnil, Qnil, Qnil); unbind_to (speccount1, Qnil); - teml = args[i]; - visargs[i] = Fkey_description (teml, Qnil); + visargs[i] = Fkey_description (args[i], Qnil); /* If the key sequence ends with a down-event, discard the following up-event. */ - teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1)); + Lisp_Object teml + = Faref (args[i], make_fixnum (XFIXNUM (Flength (args[i])) - 1)); if (CONSP (teml)) teml = XCAR (teml); if (SYMBOLP (teml)) { - Lisp_Object tem2; - teml = Fget (teml, Qevent_symbol_elements); /* Ignore first element, which is the base key. */ - tem2 = Fmemq (Qdown, Fcdr (teml)); + Lisp_Object tem2 = Fmemq (Qdown, Fcdr (teml)); if (! NILP (tem2)) up_event = Fread_event (Qnil, Qnil, Qnil); } @@ -617,27 +561,25 @@ invoke it. If KEYS is omitted or nil, the return value of ptrdiff_t speccount1 = SPECPDL_INDEX (); specbind (Qcursor_in_echo_area, Qt); /* Prompt in `minibuffer-prompt' face. */ - Fput_text_property (make_number (0), - make_number (SCHARS (callint_message)), + Fput_text_property (make_fixnum (0), + make_fixnum (SCHARS (callint_message)), Qface, Qminibuffer_prompt, callint_message); args[i] = Fread_key_sequence_vector (callint_message, Qnil, Qt, Qnil, Qnil); - teml = args[i]; - visargs[i] = Fkey_description (teml, Qnil); + visargs[i] = Fkey_description (args[i], Qnil); unbind_to (speccount1, Qnil); /* If the key sequence ends with a down-event, discard the following up-event. */ - teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1)); + Lisp_Object teml + = Faref (args[i], make_fixnum (XFIXNUM (Flength (args[i])) - 1)); if (CONSP (teml)) teml = XCAR (teml); if (SYMBOLP (teml)) { - Lisp_Object tem2; - teml = Fget (teml, Qevent_symbol_elements); /* Ignore first element, which is the base key. */ - tem2 = Fmemq (Qdown, Fcdr (teml)); + Lisp_Object tem2 = Fmemq (Qdown, Fcdr (teml)); if (! NILP (tem2)) up_event = Fread_event (Qnil, Qnil, Qnil); } @@ -647,10 +589,9 @@ invoke it. If KEYS is omitted or nil, the return value of case 'U': /* Up event from last k or K. */ if (!NILP (up_event)) { - args[i] = Fmake_vector (make_number (1), up_event); + args[i] = make_vector (1, up_event); up_event = Qnil; - teml = args[i]; - visargs[i] = Fkey_description (teml, Qnil); + visargs[i] = Fkey_description (args[i], Qnil); } break; @@ -661,18 +602,18 @@ invoke it. If KEYS is omitted or nil, the return value of ? SSDATA (SYMBOL_NAME (function)) : "command")); args[i] = AREF (keys, next_event); - next_event++; varies[i] = -1; /* Find the next parameterized event. */ - while (next_event < key_count - && !(EVENT_HAS_PARAMETERS (AREF (keys, next_event)))) + do next_event++; + while (next_event < key_count + && ! EVENT_HAS_PARAMETERS (AREF (keys, next_event))); break; case 'm': /* Value of mark. Does not do I/O. */ - check_mark (0); + check_mark (false); /* visargs[i] = Qnil; */ args[i] = BVAR (current_buffer, mark); varies[i] = 2; @@ -690,9 +631,7 @@ invoke it. If KEYS is omitted or nil, the return value of FALLTHROUGH; case 'n': /* Read number from minibuffer. */ args[i] = call1 (Qread_number, callint_message); - /* Passing args[i] directly stimulates compiler bug. */ - teml = args[i]; - visargs[i] = Fnumber_to_string (teml); + visargs[i] = Fnumber_to_string (args[i]); break; case 'P': /* Prefix arg in raw form. Does no I/O. */ @@ -709,15 +648,16 @@ invoke it. If KEYS is omitted or nil, the return value of break; case 'r': /* Region, point and mark as 2 args. */ - check_mark (1); - set_marker_both (point_marker, Qnil, PT, PT_BYTE); - /* visargs[i+1] = Qnil; */ - mark = marker_position (BVAR (current_buffer, mark)); - /* visargs[i] = Qnil; */ - args[i] = PT < mark ? point_marker : BVAR (current_buffer, mark); - varies[i] = 3; - args[++i] = PT > mark ? point_marker : BVAR (current_buffer, mark); - varies[i] = 4; + { + check_mark (true); + set_marker_both (point_marker, Qnil, PT, PT_BYTE); + ptrdiff_t mark = marker_position (BVAR (current_buffer, mark)); + /* visargs[i] = visargs[i + 1] = Qnil; */ + args[i] = PT < mark ? point_marker : BVAR (current_buffer, mark); + varies[i] = 3; + args[++i] = PT > mark ? point_marker : BVAR (current_buffer, mark); + varies[i] = 4; + } break; case 's': /* String read via minibuffer without @@ -729,9 +669,7 @@ invoke it. If KEYS is omitted or nil, the return value of case 'S': /* Any symbol. */ visargs[i] = Fread_string (callint_message, Qnil, Qnil, Qnil, Qnil); - /* Passing args[i] directly stimulates compiler bug. */ - teml = visargs[i]; - args[i] = Fintern (teml, Qnil); + args[i] = Fintern (visargs[i], Qnil); break; case 'v': /* Variable name: symbol that is @@ -777,7 +715,7 @@ invoke it. If KEYS is omitted or nil, the return value of { /* How many bytes are left unprocessed in the specs string? (Note that this excludes the trailing null byte.) */ - ptrdiff_t bytes_left = SBYTES (specs) - (tem - string); + ptrdiff_t bytes_left = string_len - (tem - string); unsigned letter; /* If we have enough bytes left to treat the sequence as a @@ -788,20 +726,21 @@ invoke it. If KEYS is omitted or nil, the return value of else letter = *((unsigned char *) tem); - error ("Invalid control letter `%c' (#o%03o, #x%04x) in interactive calling string", + error (("Invalid control letter `%c' (#o%03o, #x%04x)" + " in interactive calling string"), (int) letter, letter, letter); } } if (varies[i] == 0) - arg_from_tty = 1; + arg_from_tty = true; if (NILP (visargs[i]) && STRINGP (args[i])) visargs[i] = args[i]; - tem = strchr (tem, '\n'); + tem = memchr (tem, '\n', string_len - (tem - string)); if (tem) tem++; - else tem = ""; + else tem = string_end; } unbind_to (speccount, Qnil); @@ -815,27 +754,17 @@ invoke it. If KEYS is omitted or nil, the return value of /* We don't need `visargs' any more, so let's recycle it since we need an array of just the same size. */ visargs[1] = function; - for (i = 2; i < nargs; i++) - { - if (varies[i] > 0) - visargs[i] = list1 (intern (callint_argfuns[varies[i]])); - else - visargs[i] = quotify_arg (args[i]); - } - Vcommand_history = Fcons (Flist (nargs - 1, visargs + 1), - Vcommand_history); - /* Don't keep command history around forever. */ - if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0) - { - teml = Fnthcdr (Vhistory_length, Vcommand_history); - if (CONSP (teml)) - XSETCDR (teml, Qnil); - } + for (ptrdiff_t i = 2; i < nargs; i++) + visargs[i] = (varies[i] > 0 + ? list1 (intern (callint_argfuns[varies[i]])) + : quotify_arg (args[i])); + call4 (intern ("add-to-history"), intern ("command-history"), + Flist (nargs - 1, visargs + 1), Qnil, Qt); } /* If we used a marker to hold point, mark, or an end of the region, temporarily, convert it to an integer now. */ - for (i = 2; i < nargs; i++) + for (ptrdiff_t i = 2; i < nargs; i++) if (varies[i] >= 1 && varies[i] <= 4) XSETINT (args[i], marker_position (args[i])); @@ -847,15 +776,10 @@ invoke it. If KEYS is omitted or nil, the return value of Vreal_this_command = save_real_this_command; kset_last_command (current_kboard, save_last_command); - { - Lisp_Object val; - specbind (Qcommand_debug_status, Qnil); + specbind (Qcommand_debug_status, Qnil); - val = Ffuncall (nargs, args); - val = unbind_to (speccount, val); - SAFE_FREE (); - return val; - } + Lisp_Object val = Ffuncall (nargs, args); + return SAFE_FREE_UNBIND_TO (speccount, val); } DEFUN ("prefix-numeric-value", Fprefix_numeric_value, Sprefix_numeric_value, @@ -871,9 +795,9 @@ Its numeric meaning is what you would get from `(interactive "p")'. */) XSETFASTINT (val, 1); else if (EQ (raw, Qminus)) XSETINT (val, -1); - else if (CONSP (raw) && INTEGERP (XCAR (raw))) - XSETINT (val, XINT (XCAR (raw))); - else if (INTEGERP (raw)) + else if (CONSP (raw) && FIXNUMP (XCAR (raw))) + XSETINT (val, XFIXNUM (XCAR (raw))); + else if (FIXNUMP (raw)) val = raw; else XSETFASTINT (val, 1); diff --git a/src/callproc.c b/src/callproc.c index 3f1d17e345b..19882e60fa3 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -83,7 +83,7 @@ static pid_t synch_process_pid; #ifdef MSDOS static Lisp_Object synch_process_tempfile; #else -# define synch_process_tempfile make_number (0) +# define synch_process_tempfile make_fixnum (0) #endif /* Indexes of file descriptors that need closing on call_process_kill. */ @@ -329,7 +329,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, #ifndef subprocesses /* Without asynchronous processes we cannot have BUFFER == 0. */ if (nargs >= 3 - && (INTEGERP (CONSP (args[2]) ? XCAR (args[2]) : args[2]))) + && (FIXNUMP (CONSP (args[2]) ? XCAR (args[2]) : args[2]))) error ("Operating system cannot handle asynchronous subprocesses"); #endif /* subprocesses */ @@ -408,7 +408,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, buffer = Qnil; } - if (! (NILP (buffer) || EQ (buffer, Qt) || INTEGERP (buffer))) + if (! (NILP (buffer) || EQ (buffer, Qt) || FIXNUMP (buffer))) { Lisp_Object spec_buffer; spec_buffer = buffer; @@ -436,7 +436,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, for (i = 0; i < CALLPROC_FDS; i++) callproc_fd[i] = -1; #ifdef MSDOS - synch_process_tempfile = make_number (0); + synch_process_tempfile = make_fixnum (0); #endif record_unwind_protect_ptr (call_process_kill, callproc_fd); @@ -445,7 +445,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, int ok; ok = openp (Vexec_path, args[0], Vexec_suffixes, &path, - make_number (X_OK), false); + make_fixnum (X_OK), false); if (ok < 0) report_file_error ("Searching for program", args[0]); } @@ -476,7 +476,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, path = ENCODE_FILE (path); new_argv[0] = SSDATA (path); - discard_output = INTEGERP (buffer) || (NILP (buffer) && NILP (output_file)); + discard_output = FIXNUMP (buffer) || (NILP (buffer) && NILP (output_file)); #ifdef MSDOS if (! discard_output && ! STRINGP (output_file)) @@ -604,7 +604,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, Lisp_Object volatile coding_systems_volatile = coding_systems; Lisp_Object volatile current_dir_volatile = current_dir; bool volatile display_p_volatile = display_p; - bool volatile sa_must_free_volatile = sa_must_free; int volatile fd_error_volatile = fd_error; int volatile filefd_volatile = filefd; ptrdiff_t volatile count_volatile = count; @@ -621,7 +620,6 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, coding_systems = coding_systems_volatile; current_dir = current_dir_volatile; display_p = display_p_volatile; - sa_must_free = sa_must_free_volatile; fd_error = fd_error_volatile; filefd = filefd_volatile; count = count_volatile; @@ -645,19 +643,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, #endif unblock_child_signal (&oldset); - -#ifdef DARWIN_OS - /* Darwin doesn't let us run setsid after a vfork, so use - TIOCNOTTY when necessary. */ - int j = emacs_open (DEV_TTY, O_RDWR, 0); - if (j >= 0) - { - ioctl (j, TIOCNOTTY, 0); - emacs_close (j); - } -#else - setsid (); -#endif + dissociate_controlling_tty (); /* Emacs ignores SIGPIPE, but the child should not. */ signal (SIGPIPE, SIG_DFL); @@ -677,7 +663,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, { synch_process_pid = pid; - if (INTEGERP (buffer)) + if (FIXNUMP (buffer)) { if (tempfile_index < 0) record_deleted_pid (pid, Qnil); @@ -710,7 +696,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, #endif /* not MSDOS */ - if (INTEGERP (buffer)) + if (FIXNUMP (buffer)) return unbind_to (count, Qnil); if (BUFFERP (buffer)) @@ -877,7 +863,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, coding-system used to decode the process output. */ if (inherit_process_coding_system) call1 (intern ("after-insert-file-set-buffer-file-coding-system"), - make_number (total_read)); + make_fixnum (total_read)); } bool wait_ok = true; @@ -890,8 +876,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, when exiting. */ synch_process_pid = 0; - SAFE_FREE (); - unbind_to (count, Qnil); + SAFE_FREE_UNBIND_TO (count, Qnil); if (!wait_ok) return build_unibyte_string ("internal error"); @@ -911,7 +896,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, } eassert (WIFEXITED (status)); - return make_number (WEXITSTATUS (status)); + return make_fixnum (WEXITSTATUS (status)); } /* Create a temporary file suitable for storing the input data of @@ -1074,7 +1059,7 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &r validate_region (&args[0], &args[1]); start = args[0]; end = args[1]; - empty_input = XINT (start) == XINT (end); + empty_input = XFIXNUM (start) == XFIXNUM (end); } if (!empty_input) @@ -1652,7 +1637,7 @@ syms_of_callproc (void) staticpro (&Vtemp_file_name_pattern); #ifdef MSDOS - synch_process_tempfile = make_number (0); + synch_process_tempfile = make_fixnum (0); staticpro (&synch_process_tempfile); #endif diff --git a/src/casefiddle.c b/src/casefiddle.c index 1e459437142..3f407eadede 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -152,7 +152,7 @@ case_character_impl (struct casing_str_buf *buf, prop = CHAR_TABLE_REF (ctx->titlecase_char_table, ch); if (CHARACTERP (prop)) { - cased = XFASTINT (prop); + cased = XFIXNAT (prop); cased_is_set = true; } } @@ -225,7 +225,7 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) { int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER | CHAR_SHIFT | CHAR_CTL | CHAR_META); - int ch = XFASTINT (obj); + int ch = XFIXNAT (obj); /* If the character has higher bits set above the flags, return it unchanged. It is not a real character. */ @@ -250,7 +250,7 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) if (! multibyte) MAKE_CHAR_UNIBYTE (cased); - return make_natnum (cased | flags); + return make_fixed_natnum (cased | flags); } static Lisp_Object @@ -319,7 +319,7 @@ casify_object (enum case_action flag, Lisp_Object obj) struct casing_context ctx; prepare_casing_context (&ctx, flag, false); - if (NATNUMP (obj)) + if (FIXNATP (obj)) return do_casify_natnum (&ctx, obj); else if (!STRINGP (obj)) wrong_type_argument (Qchar_or_string_p, obj); @@ -485,8 +485,8 @@ casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e) struct casing_context ctx; validate_region (&b, &e); - ptrdiff_t start = XFASTINT (b); - ptrdiff_t end = XFASTINT (e); + ptrdiff_t start = XFIXNAT (b); + ptrdiff_t end = XFIXNAT (e); if (start == end) /* Not modifying because nothing marked. */ return end; @@ -601,11 +601,11 @@ character positions to operate on. */) static Lisp_Object casify_word (enum case_action flag, Lisp_Object arg) { - CHECK_NUMBER (arg); - ptrdiff_t farend = scan_words (PT, XINT (arg)); + CHECK_FIXNUM (arg); + ptrdiff_t farend = scan_words (PT, XFIXNUM (arg)); if (!farend) - farend = XINT (arg) <= 0 ? BEGV : ZV; - SET_PT (casify_region (flag, make_number (PT), make_number (farend))); + farend = XFIXNUM (arg) <= 0 ? BEGV : ZV; + SET_PT (casify_region (flag, make_fixnum (PT), make_fixnum (farend))); return Qnil; } diff --git a/src/casetab.c b/src/casetab.c index a405fbec76f..b3ee24c4fa0 100644 --- a/src/casetab.c +++ b/src/casetab.c @@ -144,7 +144,8 @@ set_case_table (Lisp_Object table, bool standard) set_char_table_extras (table, 2, eqv); } - /* This is so set_image_of_range_1 in regex.c can find the EQV table. */ + /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV + table. */ set_char_table_extras (canon, 2, eqv); if (standard) @@ -178,7 +179,7 @@ set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt) Lisp_Object up = XCHAR_TABLE (case_table)->extras[0]; Lisp_Object canon = XCHAR_TABLE (case_table)->extras[1]; - if (NATNUMP (elt)) + if (FIXNATP (elt)) Fset_char_table_range (canon, range, Faref (case_table, Faref (up, elt))); } @@ -190,21 +191,21 @@ set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt) static void set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt) { - if (NATNUMP (elt)) + if (FIXNATP (elt)) { int from, to; if (CONSP (c)) { - from = XINT (XCAR (c)); - to = XINT (XCDR (c)); + from = XFIXNUM (XCAR (c)); + to = XFIXNUM (XCDR (c)); } else - from = to = XINT (c); + from = to = XFIXNUM (c); to++; for (; from < to; from++) - CHAR_TABLE_SET (table, from, make_number (from)); + CHAR_TABLE_SET (table, from, make_fixnum (from)); } } @@ -216,24 +217,24 @@ set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt) static void shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt) { - if (NATNUMP (elt)) + if (FIXNATP (elt)) { int from, to; if (CONSP (c)) { - from = XINT (XCAR (c)); - to = XINT (XCDR (c)); + from = XFIXNUM (XCAR (c)); + to = XFIXNUM (XCDR (c)); } else - from = to = XINT (c); + from = to = XFIXNUM (c); to++; for (; from < to; from++) { Lisp_Object tem = Faref (table, elt); - Faset (table, elt, make_number (from)); - Faset (table, make_number (from), tem); + Faset (table, elt, make_fixnum (from)); + Faset (table, make_fixnum (from), tem); } } } @@ -245,7 +246,7 @@ init_casetab_once (void) Lisp_Object down, up, eqv; DEFSYM (Qcase_table, "case-table"); - Fput (Qcase_table, Qchar_table_extra_slots, make_number (3)); + Fput (Qcase_table, Qchar_table_extra_slots, make_fixnum (3)); down = Fmake_char_table (Qcase_table, Qnil); Vascii_downcase_table = down; @@ -254,7 +255,7 @@ init_casetab_once (void) for (i = 0; i < 128; i++) { int c = (i >= 'A' && i <= 'Z') ? i + ('a' - 'A') : i; - CHAR_TABLE_SET (down, i, make_number (c)); + CHAR_TABLE_SET (down, i, make_fixnum (c)); } set_char_table_extras (down, 1, Fcopy_sequence (down)); @@ -265,7 +266,7 @@ init_casetab_once (void) for (i = 0; i < 128; i++) { int c = (i >= 'a' && i <= 'z') ? i + ('A' - 'a') : i; - CHAR_TABLE_SET (up, i, make_number (c)); + CHAR_TABLE_SET (up, i, make_fixnum (c)); } eqv = Fmake_char_table (Qcase_table, Qnil); @@ -275,7 +276,7 @@ init_casetab_once (void) int c = ((i >= 'A' && i <= 'Z') ? i + ('a' - 'A') : ((i >= 'a' && i <= 'z') ? i + ('A' - 'a') : i)); - CHAR_TABLE_SET (eqv, i, make_number (c)); + CHAR_TABLE_SET (eqv, i, make_fixnum (c)); } set_char_table_extras (down, 2, eqv); diff --git a/src/category.c b/src/category.c index dddb1b79aba..c504d2d9921 100644 --- a/src/category.c +++ b/src/category.c @@ -103,7 +103,7 @@ those categories. */) while (--len >= 0) { unsigned char cat = SREF (categories, len); - Lisp_Object category = make_number (cat); + Lisp_Object category = make_fixnum (cat); CHECK_CATEGORY (category); set_category_set (val, cat, 1); @@ -130,11 +130,11 @@ the current buffer's category table. */) CHECK_STRING (docstring); table = check_category_table (table); - if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category)))) - error ("Category `%c' is already defined", (int) XFASTINT (category)); + if (!NILP (CATEGORY_DOCSTRING (table, XFIXNAT (category)))) + error ("Category `%c' is already defined", (int) XFIXNAT (category)); if (!NILP (Vpurify_flag)) docstring = Fpurecopy (docstring); - SET_CATEGORY_DOCSTRING (table, XFASTINT (category), docstring); + SET_CATEGORY_DOCSTRING (table, XFIXNAT (category), docstring); return Qnil; } @@ -148,7 +148,7 @@ category table. */) CHECK_CATEGORY (category); table = check_category_table (table); - return CATEGORY_DOCSTRING (table, XFASTINT (category)); + return CATEGORY_DOCSTRING (table, XFIXNAT (category)); } DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category, @@ -165,7 +165,7 @@ it defaults to the current buffer's category table. */) for (i = ' '; i <= '~'; i++) if (NILP (CATEGORY_DOCSTRING (table, i))) - return make_number (i); + return make_fixnum (i); return Qnil; } @@ -220,9 +220,9 @@ copy_category_entry (Lisp_Object table, Lisp_Object c, Lisp_Object val) { val = Fcopy_sequence (val); if (CONSP (c)) - char_table_set_range (table, XINT (XCAR (c)), XINT (XCDR (c)), val); + char_table_set_range (table, XFIXNUM (XCAR (c)), XFIXNUM (XCDR (c)), val); else - char_table_set (table, XINT (c), val); + char_table_set (table, XFIXNUM (c), val); } /* Return a copy of category table TABLE. We can't simply use the @@ -271,8 +271,7 @@ DEFUN ("make-category-table", Fmake_category_table, Smake_category_table, set_char_table_defalt (val, MAKE_CATEGORY_SET); for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++) set_char_table_contents (val, i, MAKE_CATEGORY_SET); - Fset_char_table_extra_slot (val, make_number (0), - Fmake_vector (make_number (95), Qnil)); + Fset_char_table_extra_slot (val, make_fixnum (0), make_nil_vector (95)); return val; } @@ -303,7 +302,7 @@ usage: (char-category-set CHAR) */) (Lisp_Object ch) { CHECK_CHARACTER (ch); - return CATEGORY_SET (XFASTINT (ch)); + return CATEGORY_SET (XFIXNAT (ch)); } DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics, @@ -346,25 +345,25 @@ then delete CATEGORY from the category set instead of adding it. */) int start, end; int from, to; - if (INTEGERP (character)) + if (FIXNUMP (character)) { CHECK_CHARACTER (character); - start = end = XFASTINT (character); + start = end = XFIXNAT (character); } else { CHECK_CONS (character); CHECK_CHARACTER_CAR (character); CHECK_CHARACTER_CDR (character); - start = XFASTINT (XCAR (character)); - end = XFASTINT (XCDR (character)); + start = XFIXNAT (XCAR (character)); + end = XFIXNAT (XCDR (character)); } CHECK_CATEGORY (category); table = check_category_table (table); - if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category)))) - error ("Undefined category: %c", (int) XFASTINT (category)); + if (NILP (CATEGORY_DOCSTRING (table, XFIXNAT (category)))) + error ("Undefined category: %c", (int) XFIXNAT (category)); set_value = NILP (reset); @@ -372,10 +371,10 @@ then delete CATEGORY from the category set instead of adding it. */) { from = start, to = end; category_set = char_table_ref_and_range (table, start, &from, &to); - if (CATEGORY_MEMBER (XFASTINT (category), category_set) != NILP (reset)) + if (CATEGORY_MEMBER (XFIXNAT (category), category_set) != NILP (reset)) { category_set = Fcopy_sequence (category_set); - set_category_set (category_set, XFASTINT (category), set_value); + set_category_set (category_set, XFIXNAT (category), set_value); category_set = hash_get_category_set (table, category_set); char_table_set_range (table, start, to, category_set); } @@ -423,12 +422,12 @@ word_boundary_p (int c1, int c2) if (CONSP (elt) && (NILP (XCAR (elt)) || (CATEGORYP (XCAR (elt)) - && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1) - && ! CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set2))) + && CATEGORY_MEMBER (XFIXNAT (XCAR (elt)), category_set1) + && ! CATEGORY_MEMBER (XFIXNAT (XCAR (elt)), category_set2))) && (NILP (XCDR (elt)) || (CATEGORYP (XCDR (elt)) - && ! CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set1) - && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2)))) + && ! CATEGORY_MEMBER (XFIXNAT (XCDR (elt)), category_set1) + && CATEGORY_MEMBER (XFIXNAT (XCDR (elt)), category_set2)))) return !default_result; } return default_result; @@ -440,13 +439,13 @@ init_category_once (void) { /* This has to be done here, before we call Fmake_char_table. */ DEFSYM (Qcategory_table, "category-table"); - Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2)); + Fput (Qcategory_table, Qchar_table_extra_slots, make_fixnum (2)); Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil); /* Set a category set which contains nothing to the default. */ set_char_table_defalt (Vstandard_category_table, MAKE_CATEGORY_SET); - Fset_char_table_extra_slot (Vstandard_category_table, make_number (0), - Fmake_vector (make_number (95), Qnil)); + Fset_char_table_extra_slot (Vstandard_category_table, make_fixnum (0), + make_nil_vector (95)); } void diff --git a/src/category.h b/src/category.h index c4feedd358f..cc329904784 100644 --- a/src/category.h +++ b/src/category.h @@ -59,7 +59,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ INLINE_HEADER_BEGIN -#define CATEGORYP(x) RANGED_INTEGERP (0x20, x, 0x7E) +#define CATEGORYP(x) RANGED_FIXNUMP (0x20, x, 0x7E) #define CHECK_CATEGORY(x) \ CHECK_TYPE (CATEGORYP (x), Qcategoryp, x) @@ -68,7 +68,7 @@ INLINE_HEADER_BEGIN (BOOL_VECTOR_P (x) && bool_vector_size (x) == 128) /* Return a new empty category set. */ -#define MAKE_CATEGORY_SET (Fmake_bool_vector (make_number (128), Qnil)) +#define MAKE_CATEGORY_SET (Fmake_bool_vector (make_fixnum (128), Qnil)) #define CHECK_CATEGORY_SET(x) \ CHECK_TYPE (CATEGORY_SET_P (x), Qcategorysetp, x) @@ -77,7 +77,7 @@ INLINE_HEADER_BEGIN #define CATEGORY_SET(c) char_category_set (c) /* Return true if CATEGORY_SET contains CATEGORY. - Faster than '!NILP (Faref (category_set, make_number (category)))'. */ + Faster than '!NILP (Faref (category_set, make_fixnum (category)))'. */ INLINE bool CATEGORY_MEMBER (EMACS_INT category, Lisp_Object category_set) { @@ -98,16 +98,16 @@ CHAR_HAS_CATEGORY (int ch, int category) /* Return the doc string of CATEGORY in category table TABLE. */ #define CATEGORY_DOCSTRING(table, category) \ - AREF (Fchar_table_extra_slot (table, make_number (0)), ((category) - ' ')) + AREF (Fchar_table_extra_slot (table, make_fixnum (0)), ((category) - ' ')) /* Set the doc string of CATEGORY to VALUE in category table TABLE. */ #define SET_CATEGORY_DOCSTRING(table, category, value) \ - ASET (Fchar_table_extra_slot (table, make_number (0)), ((category) - ' '), value) + ASET (Fchar_table_extra_slot (table, make_fixnum (0)), ((category) - ' '), value) /* Return the version number of category table TABLE. Not used for the moment. */ #define CATEGORY_TABLE_VERSION (table) \ - Fchar_table_extra_slot (table, make_number (1)) + Fchar_table_extra_slot (table, make_fixnum (1)) /* Return true if there is a word boundary between two word-constituent characters C1 and C2 if they appear in this order. diff --git a/src/ccl.c b/src/ccl.c index e258b12b01b..ec108e30d86 100644 --- a/src/ccl.c +++ b/src/ccl.c @@ -629,7 +629,7 @@ do \ stack_idx++; \ ccl_prog = called_ccl.prog; \ ic = CCL_HEADER_MAIN; \ - eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]); \ + eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]); \ goto ccl_repeat; \ } \ while (0) @@ -736,7 +736,7 @@ while (0) #define GET_CCL_RANGE(var, ccl_prog, ic, lo, hi) \ do \ { \ - EMACS_INT prog_word = XINT ((ccl_prog)[ic]); \ + EMACS_INT prog_word = XFIXNUM ((ccl_prog)[ic]); \ if (! ASCENDING_ORDER (lo, prog_word, hi)) \ CCL_INVALID_CMD; \ (var) = prog_word; \ @@ -769,12 +769,12 @@ while (0) CCL_INVALID_CMD; \ else if (dst + len <= dst_end) \ { \ - if (XFASTINT (ccl_prog[ic]) & 0x1000000) \ + if (XFIXNAT (ccl_prog[ic]) & 0x1000000) \ for (ccli = 0; ccli < len; ccli++) \ - *dst++ = XFASTINT (ccl_prog[ic + ccli]) & 0xFFFFFF; \ + *dst++ = XFIXNAT (ccl_prog[ic + ccli]) & 0xFFFFFF; \ else \ for (ccli = 0; ccli < len; ccli++) \ - *dst++ = ((XFASTINT (ccl_prog[ic + (ccli / 3)])) \ + *dst++ = ((XFIXNAT (ccl_prog[ic + (ccli / 3)])) \ >> ((2 - (ccli % 3)) * 8)) & 0xFF; \ } \ else \ @@ -926,14 +926,14 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size break; case CCL_SetConst: /* 00000000000000000000rrrXXXXX */ - reg[rrr] = XINT (ccl_prog[ic++]); + reg[rrr] = XFIXNUM (ccl_prog[ic++]); break; case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */ i = reg[RRR]; j = field1 >> 3; if (0 <= i && i < j) - reg[rrr] = XINT (ccl_prog[ic + i]); + reg[rrr] = XFIXNUM (ccl_prog[ic + i]); ic += j; break; @@ -961,13 +961,13 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size break; case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */ - i = XINT (ccl_prog[ic]); + i = XFIXNUM (ccl_prog[ic]); CCL_WRITE_CHAR (i); ic += ADDR; break; case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */ - i = XINT (ccl_prog[ic]); + i = XFIXNUM (ccl_prog[ic]); CCL_WRITE_CHAR (i); ic++; CCL_READ_CHAR (reg[rrr]); @@ -975,17 +975,17 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size break; case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */ - j = XINT (ccl_prog[ic++]); + j = XFIXNUM (ccl_prog[ic++]); CCL_WRITE_STRING (j); ic += ADDR - 1; break; case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */ i = reg[rrr]; - j = XINT (ccl_prog[ic]); + j = XFIXNUM (ccl_prog[ic]); if (0 <= i && i < j) { - i = XINT (ccl_prog[ic + 1 + i]); + i = XFIXNUM (ccl_prog[ic + 1 + i]); CCL_WRITE_CHAR (i); } ic += j + 2; @@ -1004,7 +1004,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */ { int ioff = 0 <= reg[rrr] && reg[rrr] < field1 ? reg[rrr] : field1; - int incr = XINT (ccl_prog[ic + ioff]); + int incr = XFIXNUM (ccl_prog[ic + ioff]); ic += incr; } break; @@ -1023,7 +1023,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */ rrr = 7; i = reg[RRR]; - j = XINT (ccl_prog[ic]); + j = XFIXNUM (ccl_prog[ic]); op = field1 >> 6; jump_address = ic + 1; goto ccl_set_expr; @@ -1056,7 +1056,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size /* If FFF is nonzero, the CCL program ID is in the following code. */ if (rrr) - prog_id = XINT (ccl_prog[ic++]); + prog_id = XFIXNUM (ccl_prog[ic++]); else prog_id = field1; @@ -1081,7 +1081,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size stack_idx++; ccl_prog = XVECTOR (AREF (slot, 1))->contents; ic = CCL_HEADER_MAIN; - eof_ic = XFASTINT (ccl_prog[CCL_HEADER_EOF]); + eof_ic = XFIXNAT (ccl_prog[CCL_HEADER_EOF]); } break; @@ -1099,7 +1099,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size i = reg[rrr]; if (0 <= i && i < field1) { - j = XINT (ccl_prog[ic + i]); + j = XFIXNUM (ccl_prog[ic + i]); CCL_WRITE_CHAR (j); } ic += field1; @@ -1124,7 +1124,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size CCL_SUCCESS; case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */ - i = XINT (ccl_prog[ic++]); + i = XFIXNUM (ccl_prog[ic++]); op = field1 >> 6; goto ccl_expr_self; @@ -1160,7 +1160,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */ i = reg[RRR]; - j = XINT (ccl_prog[ic++]); + j = XFIXNUM (ccl_prog[ic++]); op = field1 >> 6; jump_address = ic; goto ccl_set_expr; @@ -1178,8 +1178,8 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */ i = reg[rrr]; jump_address = ic + ADDR; - op = XINT (ccl_prog[ic++]); - j = XINT (ccl_prog[ic++]); + op = XFIXNUM (ccl_prog[ic++]); + j = XFIXNUM (ccl_prog[ic++]); rrr = 7; goto ccl_set_expr; @@ -1189,7 +1189,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size case CCL_JumpCondExprReg: i = reg[rrr]; jump_address = ic + ADDR; - op = XINT (ccl_prog[ic++]); + op = XFIXNUM (ccl_prog[ic++]); GET_CCL_RANGE (j, ccl_prog, ic++, 0, 7); j = reg[j]; rrr = 7; @@ -1291,7 +1291,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size : -1)); h = GET_HASH_TABLE (eop); - eop = hash_lookup (h, make_number (reg[RRR]), NULL); + eop = hash_lookup (h, make_fixnum (reg[RRR]), NULL); if (eop >= 0) { Lisp_Object opl; @@ -1318,14 +1318,14 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]); h = GET_HASH_TABLE (eop); - eop = hash_lookup (h, make_number (i), NULL); + eop = hash_lookup (h, make_fixnum (i), NULL); if (eop >= 0) { Lisp_Object opl; opl = HASH_VALUE (h, eop); - if (! (INTEGERP (opl) && IN_INT_RANGE (XINT (opl)))) + if (! (FIXNUMP (opl) && IN_INT_RANGE (XFIXNUM (opl)))) CCL_INVALID_CMD; - reg[RRR] = XINT (opl); + reg[RRR] = XFIXNUM (opl); reg[7] = 1; /* r7 true for success */ } else @@ -1340,7 +1340,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size ptrdiff_t size; int fin_ic; - j = XINT (ccl_prog[ic++]); /* number of maps. */ + j = XFIXNUM (ccl_prog[ic++]); /* number of maps. */ fin_ic = ic + j; op = reg[rrr]; if ((j > reg[RRR]) && (j >= 0)) @@ -1359,7 +1359,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size { if (!VECTORP (Vcode_conversion_map_vector)) continue; size = ASIZE (Vcode_conversion_map_vector); - point = XINT (ccl_prog[ic++]); + point = XFIXNUM (ccl_prog[ic++]); if (! (0 <= point && point < size)) continue; map = AREF (Vcode_conversion_map_vector, point); @@ -1375,19 +1375,19 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size /* check map type, [STARTPOINT VAL1 VAL2 ...] or [t ELEMENT STARTPOINT ENDPOINT] */ - if (INTEGERP (content)) + if (FIXNUMP (content)) { - point = XINT (content); + point = XFIXNUM (content); if (!(point <= op && op - point + 1 < size)) continue; content = AREF (map, op - point + 1); } else if (EQ (content, Qt)) { if (size != 4) continue; - if (INTEGERP (AREF (map, 2)) - && XINT (AREF (map, 2)) <= op - && INTEGERP (AREF (map, 3)) - && op < XINT (AREF (map, 3))) + if (FIXNUMP (AREF (map, 2)) + && XFIXNUM (AREF (map, 2)) <= op + && FIXNUMP (AREF (map, 3)) + && op < XFIXNUM (AREF (map, 3))) content = AREF (map, 1); else continue; @@ -1397,10 +1397,10 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size if (NILP (content)) continue; - else if (INTEGERP (content) && IN_INT_RANGE (XINT (content))) + else if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content))) { reg[RRR] = i; - reg[rrr] = XINT (content); + reg[rrr] = XFIXNUM (content); break; } else if (EQ (content, Qt) || EQ (content, Qlambda)) @@ -1412,11 +1412,11 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size { attrib = XCAR (content); value = XCDR (content); - if (! (INTEGERP (attrib) && INTEGERP (value) - && IN_INT_RANGE (XINT (value)))) + if (! (FIXNUMP (attrib) && FIXNUMP (value) + && IN_INT_RANGE (XFIXNUM (value)))) continue; reg[RRR] = i; - reg[rrr] = XINT (value); + reg[rrr] = XFIXNUM (value); break; } else if (SYMBOLP (content)) @@ -1453,7 +1453,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size stack_idx_of_map_multiple = 0; /* Get number of maps and separators. */ - map_set_rest_length = XINT (ccl_prog[ic++]); + map_set_rest_length = XFIXNUM (ccl_prog[ic++]); fin_ic = ic + map_set_rest_length; op = reg[rrr]; @@ -1524,7 +1524,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size do { for (;map_set_rest_length > 0;i++, ic++, map_set_rest_length--) { - point = XINT (ccl_prog[ic]); + point = XFIXNUM (ccl_prog[ic]); if (point < 0) { /* +1 is for including separator. */ @@ -1554,19 +1554,19 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size /* check map type, [STARTPOINT VAL1 VAL2 ...] or [t ELEMENT STARTPOINT ENDPOINT] */ - if (INTEGERP (content)) + if (FIXNUMP (content)) { - point = XINT (content); + point = XFIXNUM (content); if (!(point <= op && op - point + 1 < size)) continue; content = AREF (map, op - point + 1); } else if (EQ (content, Qt)) { if (size != 4) continue; - if (INTEGERP (AREF (map, 2)) - && XINT (AREF (map, 2)) <= op - && INTEGERP (AREF (map, 3)) - && op < XINT (AREF (map, 3))) + if (FIXNUMP (AREF (map, 2)) + && XFIXNUM (AREF (map, 2)) <= op + && FIXNUMP (AREF (map, 3)) + && op < XFIXNUM (AREF (map, 3))) content = AREF (map, 1); else continue; @@ -1578,9 +1578,9 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size continue; reg[RRR] = i; - if (INTEGERP (content) && IN_INT_RANGE (XINT (content))) + if (FIXNUMP (content) && IN_INT_RANGE (XFIXNUM (content))) { - op = XINT (content); + op = XFIXNUM (content); i += map_set_rest_length - 1; ic += map_set_rest_length - 1; POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); @@ -1590,10 +1590,10 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size { attrib = XCAR (content); value = XCDR (content); - if (! (INTEGERP (attrib) && INTEGERP (value) - && IN_INT_RANGE (XINT (value)))) + if (! (FIXNUMP (attrib) && FIXNUMP (value) + && IN_INT_RANGE (XFIXNUM (value)))) continue; - op = XINT (value); + op = XFIXNUM (value); i += map_set_rest_length - 1; ic += map_set_rest_length - 1; POP_MAPPING_STACK (map_set_rest_length, reg[rrr]); @@ -1639,7 +1639,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size { Lisp_Object map, attrib, value, content; int point; - j = XINT (ccl_prog[ic++]); /* map_id */ + j = XFIXNUM (ccl_prog[ic++]); /* map_id */ op = reg[rrr]; if (! (VECTORP (Vcode_conversion_map_vector) && j < ASIZE (Vcode_conversion_map_vector))) @@ -1656,29 +1656,29 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size map = XCDR (map); if (! (VECTORP (map) && 0 < ASIZE (map) - && INTEGERP (AREF (map, 0)) - && XINT (AREF (map, 0)) <= op - && op - XINT (AREF (map, 0)) + 1 < ASIZE (map))) + && FIXNUMP (AREF (map, 0)) + && XFIXNUM (AREF (map, 0)) <= op + && op - XFIXNUM (AREF (map, 0)) + 1 < ASIZE (map))) { reg[RRR] = -1; break; } - point = op - XINT (AREF (map, 0)) + 1; + point = op - XFIXNUM (AREF (map, 0)) + 1; reg[RRR] = 0; content = AREF (map, point); if (NILP (content)) reg[RRR] = -1; - else if (TYPE_RANGED_INTEGERP (int, content)) - reg[rrr] = XINT (content); + else if (TYPE_RANGED_FIXNUMP (int, content)) + reg[rrr] = XFIXNUM (content); else if (EQ (content, Qt)); else if (CONSP (content)) { attrib = XCAR (content); value = XCDR (content); - if (!INTEGERP (attrib) - || !TYPE_RANGED_INTEGERP (int, value)) + if (!FIXNUMP (attrib) + || !TYPE_RANGED_FIXNUMP (int, value)) continue; - reg[rrr] = XINT (value); + reg[rrr] = XFIXNUM (value); break; } else if (SYMBOLP (content)) @@ -1809,7 +1809,7 @@ resolve_symbol_ccl_program (Lisp_Object ccl) for (i = 0; i < veclen; i++) { contents = AREF (result, i); - if (TYPE_RANGED_INTEGERP (int, contents)) + if (TYPE_RANGED_FIXNUMP (int, contents)) continue; else if (CONSP (contents) && SYMBOLP (XCAR (contents)) @@ -1819,7 +1819,7 @@ resolve_symbol_ccl_program (Lisp_Object ccl) (SYMBOL . PROPERTY). (get SYMBOL PROPERTY) should give an index number. */ val = Fget (XCAR (contents), XCDR (contents)); - if (RANGED_INTEGERP (0, val, INT_MAX)) + if (RANGED_FIXNUMP (0, val, INT_MAX)) ASET (result, i, val); else unresolved = 1; @@ -1831,17 +1831,17 @@ resolve_symbol_ccl_program (Lisp_Object ccl) may lead to a bug if, for instance, a translation table and a code conversion map have the same name. */ val = Fget (contents, Qtranslation_table_id); - if (RANGED_INTEGERP (0, val, INT_MAX)) + if (RANGED_FIXNUMP (0, val, INT_MAX)) ASET (result, i, val); else { val = Fget (contents, Qcode_conversion_map_id); - if (RANGED_INTEGERP (0, val, INT_MAX)) + if (RANGED_FIXNUMP (0, val, INT_MAX)) ASET (result, i, val); else { val = Fget (contents, Qccl_program_idx); - if (RANGED_INTEGERP (0, val, INT_MAX)) + if (RANGED_FIXNUMP (0, val, INT_MAX)) ASET (result, i, val); else unresolved = 1; @@ -1852,8 +1852,8 @@ resolve_symbol_ccl_program (Lisp_Object ccl) return Qnil; } - if (! (0 <= XINT (AREF (result, CCL_HEADER_BUF_MAG)) - && ASCENDING_ORDER (0, XINT (AREF (result, CCL_HEADER_EOF)), + if (! (0 <= XFIXNUM (AREF (result, CCL_HEADER_BUF_MAG)) + && ASCENDING_ORDER (0, XFIXNUM (AREF (result, CCL_HEADER_EOF)), ASIZE (ccl)))) return Qnil; @@ -1881,15 +1881,15 @@ ccl_get_compiled_code (Lisp_Object ccl_prog, ptrdiff_t *idx) return Qnil; val = Fget (ccl_prog, Qccl_program_idx); - if (! NATNUMP (val) - || XINT (val) >= ASIZE (Vccl_program_table)) + if (! FIXNATP (val) + || XFIXNUM (val) >= ASIZE (Vccl_program_table)) return Qnil; - slot = AREF (Vccl_program_table, XINT (val)); + slot = AREF (Vccl_program_table, XFIXNUM (val)); if (! VECTORP (slot) || ASIZE (slot) != 4 || ! VECTORP (AREF (slot, 1))) return Qnil; - *idx = XINT (val); + *idx = XFIXNUM (val); if (NILP (AREF (slot, 2))) { val = resolve_symbol_ccl_program (AREF (slot, 1)); @@ -1920,8 +1920,8 @@ setup_ccl_program (struct ccl_program *ccl, Lisp_Object ccl_prog) vp = XVECTOR (ccl_prog); ccl->size = vp->header.size; ccl->prog = vp->contents; - ccl->eof_ic = XINT (vp->contents[CCL_HEADER_EOF]); - ccl->buf_magnification = XINT (vp->contents[CCL_HEADER_BUF_MAG]); + ccl->eof_ic = XFIXNUM (vp->contents[CCL_HEADER_EOF]); + ccl->buf_magnification = XFIXNUM (vp->contents[CCL_HEADER_BUF_MAG]); if (ccl->idx >= 0) { Lisp_Object slot; @@ -1956,8 +1956,8 @@ See the documentation of `define-ccl-program' for the detail of CCL program. */ return Qnil; val = Fget (object, Qccl_program_idx); - return ((! NATNUMP (val) - || XINT (val) >= ASIZE (Vccl_program_table)) + return ((! FIXNATP (val) + || XFIXNUM (val) >= ASIZE (Vccl_program_table)) ? Qnil : Qt); } @@ -1990,8 +1990,8 @@ programs. */) error ("Length of vector REGISTERS is not 8"); for (i = 0; i < 8; i++) - ccl.reg[i] = (TYPE_RANGED_INTEGERP (int, AREF (reg, i)) - ? XINT (AREF (reg, i)) + ccl.reg[i] = (TYPE_RANGED_FIXNUMP (int, AREF (reg, i)) + ? XFIXNUM (AREF (reg, i)) : 0); ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil); @@ -2000,7 +2000,7 @@ programs. */) error ("Error in CCL program at %dth code", ccl.ic); for (i = 0; i < 8; i++) - ASET (reg, i, make_number (ccl.reg[i])); + ASET (reg, i, make_fixnum (ccl.reg[i])); return Qnil; } @@ -2058,13 +2058,13 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY for (i = 0; i < 8; i++) { if (NILP (AREF (status, i))) - ASET (status, i, make_number (0)); - if (TYPE_RANGED_INTEGERP (int, AREF (status, i))) - ccl.reg[i] = XINT (AREF (status, i)); + ASET (status, i, make_fixnum (0)); + if (TYPE_RANGED_FIXNUMP (int, AREF (status, i))) + ccl.reg[i] = XFIXNUM (AREF (status, i)); } - if (INTEGERP (AREF (status, i))) + if (FIXNUMP (AREF (status, i))) { - i = XFASTINT (AREF (status, 8)); + i = XFIXNAT (AREF (status, 8)); if (ccl.ic < i && i < ccl.size) ccl.ic = i; } @@ -2139,8 +2139,8 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY error ("CCL program interrupted at %dth code", ccl.ic); for (i = 0; i < 8; i++) - ASET (status, i, make_number (ccl.reg[i])); - ASET (status, 8, make_number (ccl.ic)); + ASET (status, i, make_fixnum (ccl.reg[i])); + ASET (status, 8, make_fixnum (ccl.ic)); val = make_specified_string ((const char *) outbuf, produced_chars, outp - outbuf, NILP (unibyte_p)); @@ -2193,7 +2193,7 @@ Return index number of the registered CCL program. */) ASET (slot, 1, ccl_prog); ASET (slot, 2, resolved); ASET (slot, 3, Qt); - return make_number (idx); + return make_fixnum (idx); } } @@ -2211,8 +2211,8 @@ Return index number of the registered CCL program. */) ASET (Vccl_program_table, idx, elt); } - Fput (name, Qccl_program_idx, make_number (idx)); - return make_number (idx); + Fput (name, Qccl_program_idx, make_fixnum (idx)); + return make_fixnum (idx); } /* Register code conversion map. @@ -2251,7 +2251,7 @@ Return index number of the registered map. */) if (EQ (symbol, XCAR (slot))) { - idx = make_number (i); + idx = make_fixnum (i); XSETCDR (slot, map); Fput (symbol, Qcode_conversion_map, map); Fput (symbol, Qcode_conversion_map_id, idx); @@ -2263,7 +2263,7 @@ Return index number of the registered map. */) Vcode_conversion_map_vector = larger_vector (Vcode_conversion_map_vector, 1, -1); - idx = make_number (i); + idx = make_fixnum (i); Fput (symbol, Qcode_conversion_map, map); Fput (symbol, Qcode_conversion_map_id, idx); ASET (Vcode_conversion_map_vector, i, Fcons (symbol, map)); @@ -2275,7 +2275,7 @@ void syms_of_ccl (void) { staticpro (&Vccl_program_table); - Vccl_program_table = Fmake_vector (make_number (32), Qnil); + Vccl_program_table = make_nil_vector (32); DEFSYM (Qccl, "ccl"); DEFSYM (Qcclp, "cclp"); @@ -2291,7 +2291,7 @@ syms_of_ccl (void) DEFVAR_LISP ("code-conversion-map-vector", Vcode_conversion_map_vector, doc: /* Vector of code conversion maps. */); - Vcode_conversion_map_vector = Fmake_vector (make_number (16), Qnil); + Vcode_conversion_map_vector = make_nil_vector (16); DEFVAR_LISP ("font-ccl-encoder-alist", Vfont_ccl_encoder_alist, doc: /* Alist of fontname patterns vs corresponding CCL program. diff --git a/src/character.c b/src/character.c index 021ac83cbe0..d14d0df29f8 100644 --- a/src/character.c +++ b/src/character.c @@ -207,7 +207,7 @@ translate_char (Lisp_Object table, int c) ch = CHAR_TABLE_REF (table, c); if (CHARACTERP (ch)) - c = XINT (ch); + c = XFIXNUM (ch); } else { @@ -234,7 +234,7 @@ DEFUN ("max-char", Fmax_char, Smax_char, 0, 0, 0, attributes: const) (void) { - return make_number (MAX_CHAR); + return make_fixnum (MAX_CHAR); } DEFUN ("unibyte-char-to-multibyte", Funibyte_char_to_multibyte, @@ -245,11 +245,11 @@ DEFUN ("unibyte-char-to-multibyte", Funibyte_char_to_multibyte, int c; CHECK_CHARACTER (ch); - c = XFASTINT (ch); + c = XFIXNAT (ch); if (c >= 0x100) error ("Not a unibyte character: %d", c); MAKE_CHAR_MULTIBYTE (c); - return make_number (c); + return make_fixnum (c); } DEFUN ("multibyte-char-to-unibyte", Fmultibyte_char_to_unibyte, @@ -261,7 +261,7 @@ If the multibyte character does not represent a byte, return -1. */) int cm; CHECK_CHARACTER (ch); - cm = XFASTINT (ch); + cm = XFIXNAT (ch); if (cm < 256) /* Can't distinguish a byte read from a unibyte buffer from a latin1 char, so let's let it slide. */ @@ -269,7 +269,7 @@ If the multibyte character does not represent a byte, return -1. */) else { int cu = CHAR_TO_BYTE_SAFE (cm); - return make_number (cu); + return make_fixnum (cu); } } @@ -294,7 +294,7 @@ char_width (int c, struct Lisp_Char_Table *dp) if (GLYPH_CODE_P (ch)) c = GLYPH_CODE_CHAR (ch); else if (CHARACTERP (ch)) - c = XFASTINT (ch); + c = XFIXNUM (ch); if (c >= 0) { int w = CHARACTER_WIDTH (c); @@ -318,9 +318,9 @@ usage: (char-width CHAR) */) ptrdiff_t width; CHECK_CHARACTER (ch); - c = XINT (ch); + c = XFIXNUM (ch); width = char_width (c, buffer_display_table ()); - return make_number (width); + return make_fixnum (width); } /* Return width of string STR of length LEN when displayed in the @@ -861,7 +861,7 @@ usage: (string &rest CHARACTERS) */) for (i = 0; i < n; i++) { CHECK_CHARACTER (args[i]); - c = XINT (args[i]); + c = XFIXNUM (args[i]); p += CHAR_STRING (c, p); } @@ -884,7 +884,7 @@ usage: (unibyte-string &rest BYTES) */) for (i = 0; i < n; i++) { CHECK_RANGED_INTEGER (args[i], 0, 255); - *p++ = XINT (args[i]); + *p++ = XFIXNUM (args[i]); } str = make_string_from_bytes ((char *) buf, n, p - buf); @@ -902,9 +902,9 @@ usage: (char-resolve-modifiers CHAR) */) { EMACS_INT c; - CHECK_NUMBER (character); - c = XINT (character); - return make_number (char_resolve_modifier_mask (c)); + CHECK_FIXNUM (character); + c = XFIXNUM (character); + return make_fixnum (char_resolve_modifier_mask (c)); } DEFUN ("get-byte", Fget_byte, Sget_byte, 0, 2, 0, @@ -931,14 +931,14 @@ character is not ASCII nor 8-bit character, an error is signaled. */) } else { - CHECK_NUMBER_COERCE_MARKER (position); - if (XINT (position) < BEGV || XINT (position) >= ZV) - args_out_of_range_3 (position, make_number (BEGV), make_number (ZV)); - pos = XFASTINT (position); + CHECK_FIXNUM_COERCE_MARKER (position); + if (XFIXNUM (position) < BEGV || XFIXNUM (position) >= ZV) + args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); + pos = XFIXNAT (position); p = CHAR_POS_ADDR (pos); } if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - return make_number (*p); + return make_fixnum (*p); } else { @@ -949,21 +949,21 @@ character is not ASCII nor 8-bit character, an error is signaled. */) } else { - CHECK_NATNUM (position); - if (XINT (position) >= SCHARS (string)) + CHECK_FIXNAT (position); + if (XFIXNUM (position) >= SCHARS (string)) args_out_of_range (string, position); - pos = XFASTINT (position); + pos = XFIXNAT (position); p = SDATA (string) + string_char_to_byte (string, pos); } if (! STRING_MULTIBYTE (string)) - return make_number (*p); + return make_fixnum (*p); } c = STRING_CHAR (p); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); else if (! ASCII_CHAR_P (c)) error ("Not an ASCII nor an 8-bit character: %d", c); - return make_number (c); + return make_fixnum (c); } /* Return true if C is an alphabetic character. */ @@ -971,9 +971,9 @@ bool alphabeticp (int c) { Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); - if (! INTEGERP (category)) + if (! FIXNUMP (category)) return false; - EMACS_INT gen_cat = XINT (category); + EMACS_INT gen_cat = XFIXNUM (category); /* See UTS #18. There are additional characters that should be here, those designated as Other_uppercase, Other_lowercase, @@ -994,9 +994,9 @@ bool alphanumericp (int c) { Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); - if (! INTEGERP (category)) + if (! FIXNUMP (category)) return false; - EMACS_INT gen_cat = XINT (category); + EMACS_INT gen_cat = XFIXNUM (category); /* See UTS #18. Same comment as for alphabeticp applies. FIXME. */ return (gen_cat == UNICODE_CATEGORY_Lu @@ -1016,9 +1016,9 @@ bool graphicp (int c) { Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); - if (! INTEGERP (category)) + if (! FIXNUMP (category)) return false; - EMACS_INT gen_cat = XINT (category); + EMACS_INT gen_cat = XFIXNUM (category); /* See UTS #18. */ return (!(gen_cat == UNICODE_CATEGORY_Zs /* space separator */ @@ -1034,9 +1034,9 @@ bool printablep (int c) { Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); - if (! INTEGERP (category)) + if (! FIXNUMP (category)) return false; - EMACS_INT gen_cat = XINT (category); + EMACS_INT gen_cat = XFIXNUM (category); /* See UTS #18. */ return (!(gen_cat == UNICODE_CATEGORY_Cc /* control */ @@ -1050,10 +1050,36 @@ bool blankp (int c) { Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); - if (! INTEGERP (category)) + if (! FIXNUMP (category)) return false; - return XINT (category) == UNICODE_CATEGORY_Zs; /* separator, space */ + return XFIXNUM (category) == UNICODE_CATEGORY_Zs; /* separator, space */ +} + + +/* Return true for characters that would read as symbol characters, + but graphically may be confused with some kind of punctuation. We + require an escaping backslash, when such characters begin a + symbol. */ +bool +confusable_symbol_character_p (int ch) +{ + switch (ch) + { + case 0x2018: /* LEFT SINGLE QUOTATION MARK */ + case 0x2019: /* RIGHT SINGLE QUOTATION MARK */ + case 0x201B: /* SINGLE HIGH-REVERSED-9 QUOTATION MARK */ + case 0x201C: /* LEFT DOUBLE QUOTATION MARK */ + case 0x201D: /* RIGHT DOUBLE QUOTATION MARK */ + case 0x201F: /* DOUBLE HIGH-REVERSED-9 QUOTATION MARK */ + case 0x301E: /* DOUBLE PRIME QUOTATION MARK */ + case 0xFF02: /* FULLWIDTH QUOTATION MARK */ + case 0xFF07: /* FULLWIDTH APOSTROPHE */ + return true; + + default: + return false; + } } signed char HEXDIGIT_CONST hexdigit[UCHAR_MAX + 1] = @@ -1098,7 +1124,7 @@ syms_of_character (void) Vector recording all translation tables ever defined. Each element is a pair (SYMBOL . TABLE) relating the table to the symbol naming it. The ID of a translation table is an index into this vector. */); - Vtranslation_table_vector = Fmake_vector (make_number (16), Qnil); + Vtranslation_table_vector = make_nil_vector (16); DEFVAR_LISP ("auto-fill-chars", Vauto_fill_chars, doc: /* @@ -1111,26 +1137,26 @@ Such characters have value t in this table. */); DEFVAR_LISP ("char-width-table", Vchar_width_table, doc: /* A char-table for width (columns) of each character. */); - Vchar_width_table = Fmake_char_table (Qnil, make_number (1)); - char_table_set_range (Vchar_width_table, 0x80, 0x9F, make_number (4)); + Vchar_width_table = Fmake_char_table (Qnil, make_fixnum (1)); + char_table_set_range (Vchar_width_table, 0x80, 0x9F, make_fixnum (4)); char_table_set_range (Vchar_width_table, MAX_5_BYTE_CHAR + 1, MAX_CHAR, - make_number (4)); + make_fixnum (4)); DEFVAR_LISP ("printable-chars", Vprintable_chars, doc: /* A char-table for each printable character. */); Vprintable_chars = Fmake_char_table (Qnil, Qnil); Fset_char_table_range (Vprintable_chars, - Fcons (make_number (32), make_number (126)), Qt); + Fcons (make_fixnum (32), make_fixnum (126)), Qt); Fset_char_table_range (Vprintable_chars, - Fcons (make_number (160), - make_number (MAX_5_BYTE_CHAR)), Qt); + Fcons (make_fixnum (160), + make_fixnum (MAX_5_BYTE_CHAR)), Qt); DEFVAR_LISP ("char-script-table", Vchar_script_table, doc: /* Char table of script symbols. It has one extra slot whose value is a list of script symbols. */); DEFSYM (Qchar_script_table, "char-script-table"); - Fput (Qchar_script_table, Qchar_table_extra_slots, make_number (1)); + Fput (Qchar_script_table, Qchar_table_extra_slots, make_fixnum (1)); Vchar_script_table = Fmake_char_table (Qchar_script_table, Qnil); DEFVAR_LISP ("script-representative-chars", Vscript_representative_chars, diff --git a/src/character.h b/src/character.h index bc65759aa2a..5dff85aed47 100644 --- a/src/character.h +++ b/src/character.h @@ -123,7 +123,7 @@ enum #define MAX_MULTIBYTE_LENGTH 5 /* Nonzero iff X is a character. */ -#define CHARACTERP(x) (NATNUMP (x) && XFASTINT (x) <= MAX_CHAR) +#define CHARACTERP(x) (FIXNATP (x) && XFIXNAT (x) <= MAX_CHAR) /* Nonzero iff C is valid as a character code. */ #define CHAR_VALID_P(c) UNSIGNED_CMP (c, <=, MAX_CHAR) @@ -559,7 +559,7 @@ enum /* Return a non-outlandish value for the tab width. */ #define SANE_TAB_WIDTH(buf) \ - sanitize_tab_width (XFASTINT (BVAR (buf, tab_width))) + sanitize_tab_width (XFIXNAT (BVAR (buf, tab_width))) INLINE int sanitize_tab_width (EMACS_INT width) { @@ -595,7 +595,7 @@ sanitize_char_width (EMACS_INT width) #define CHARACTER_WIDTH(c) \ (ASCII_CHAR_P (c) \ ? ASCII_CHAR_WIDTH (c) \ - : sanitize_char_width (XINT (CHAR_TABLE_REF (Vchar_width_table, c)))) + : sanitize_char_width (XFIXNUM (CHAR_TABLE_REF (Vchar_width_table, c)))) /* If C is a variation selector, return the index of the variation selector (1..256). Otherwise, return 0. */ @@ -683,6 +683,8 @@ extern bool graphicp (int); extern bool printablep (int); extern bool blankp (int); +extern bool confusable_symbol_character_p (int ch); + /* Return a translation table of id number ID. */ #define GET_TRANSLATION_TABLE(id) \ (XCDR (XVECTOR (Vtranslation_table_vector)->contents[(id)])) @@ -698,7 +700,7 @@ char_table_translate (Lisp_Object obj, int ch) eassert (CHAR_VALID_P (ch)); eassert (CHAR_TABLE_P (obj)); obj = CHAR_TABLE_REF (obj, ch); - return CHARACTERP (obj) ? XINT (obj) : ch; + return CHARACTERP (obj) ? XFIXNUM (obj) : ch; } #if defined __GNUC__ && !defined __STRICT_ANSI__ diff --git a/src/charset.c b/src/charset.c index 463eb193abe..427349b298a 100644 --- a/src/charset.c +++ b/src/charset.c @@ -261,7 +261,7 @@ load_charset_map (struct charset *charset, struct charset_map_entries *entries, { int n = CODE_POINT_TO_INDEX (charset, max_code) + 1; - vec = Fmake_vector (make_number (n), make_number (-1)); + vec = make_vector (n, make_fixnum (-1)); set_charset_attr (charset, charset_decoder, vec); } else @@ -340,12 +340,12 @@ load_charset_map (struct charset *charset, struct charset_map_entries *entries, { if (charset->method == CHARSET_METHOD_MAP) for (; from_index < lim_index; from_index++, from_c++) - ASET (vec, from_index, make_number (from_c)); + ASET (vec, from_index, make_fixnum (from_c)); else for (; from_index < lim_index; from_index++, from_c++) CHAR_TABLE_SET (Vchar_unify_table, CHARSET_CODE_OFFSET (charset) + from_index, - make_number (from_c)); + make_fixnum (from_c)); } else if (control_flag == 2) { @@ -357,13 +357,13 @@ load_charset_map (struct charset *charset, struct charset_map_entries *entries, code = INDEX_TO_CODE_POINT (charset, code); if (NILP (CHAR_TABLE_REF (table, from_c))) - CHAR_TABLE_SET (table, from_c, make_number (code)); + CHAR_TABLE_SET (table, from_c, make_fixnum (code)); } else for (; from_index < lim_index; from_index++, from_c++) { if (NILP (CHAR_TABLE_REF (table, from_c))) - CHAR_TABLE_SET (table, from_c, make_number (from_index)); + CHAR_TABLE_SET (table, from_c, make_fixnum (from_index)); } } else if (control_flag == 3) @@ -587,14 +587,14 @@ load_charset_map_from_vector (struct charset *charset, Lisp_Object vec, int cont { val2 = XCDR (val); val = XCAR (val); - from = XFASTINT (val); - to = XFASTINT (val2); + from = XFIXNAT (val); + to = XFIXNAT (val2); } else - from = to = XFASTINT (val); + from = to = XFIXNAT (val); val = AREF (vec, i + 1); - CHECK_NATNUM (val); - c = XFASTINT (val); + CHECK_FIXNAT (val); + c = XFIXNAT (val); if (from < min_code || to > max_code || from > to || c > MAX_CHAR) continue; @@ -675,11 +675,11 @@ map_charset_for_dump (void (*c_function) (Lisp_Object, Lisp_Object), if (idx >= from_idx && idx <= to_idx) { if (NILP (XCAR (range))) - XSETCAR (range, make_number (c)); + XSETCAR (range, make_fixnum (c)); } else if (! NILP (XCAR (range))) { - XSETCDR (range, make_number (c - 1)); + XSETCDR (range, make_fixnum (c - 1)); if (c_function) (*c_function) (arg, range); else @@ -692,7 +692,7 @@ map_charset_for_dump (void (*c_function) (Lisp_Object, Lisp_Object), { if (! NILP (XCAR (range))) { - XSETCDR (range, make_number (c)); + XSETCDR (range, make_fixnum (c)); if (c_function) (*c_function) (arg, range); else @@ -734,7 +734,7 @@ map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object fun map_charset_for_dump (c_function, function, arg, from, to); } - range = Fcons (make_number (from_c), make_number (to_c)); + range = Fcons (make_fixnum (from_c), make_fixnum (to_c)); if (NILP (function)) (*c_function) (arg, range); else @@ -757,14 +757,14 @@ map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object fun int offset; subset_info = CHARSET_SUBSET (charset); - charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0))); - offset = XINT (AREF (subset_info, 3)); + charset = CHARSET_FROM_ID (XFIXNAT (AREF (subset_info, 0))); + offset = XFIXNUM (AREF (subset_info, 3)); from -= offset; - if (from < XFASTINT (AREF (subset_info, 1))) - from = XFASTINT (AREF (subset_info, 1)); + if (from < XFIXNAT (AREF (subset_info, 1))) + from = XFIXNAT (AREF (subset_info, 1)); to -= offset; - if (to > XFASTINT (AREF (subset_info, 2))) - to = XFASTINT (AREF (subset_info, 2)); + if (to > XFIXNAT (AREF (subset_info, 2))) + to = XFIXNAT (AREF (subset_info, 2)); map_charset_chars (c_function, function, arg, charset, from, to); } else /* i.e. CHARSET_METHOD_SUPERSET */ @@ -777,8 +777,8 @@ map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object fun int offset; unsigned this_from, this_to; - charset = CHARSET_FROM_ID (XFASTINT (XCAR (XCAR (parents)))); - offset = XINT (XCDR (XCAR (parents))); + charset = CHARSET_FROM_ID (XFIXNAT (XCAR (XCAR (parents)))); + offset = XFIXNUM (XCDR (XCAR (parents))); this_from = from > offset ? from - offset : 0; this_to = to > offset ? to - offset : 0; if (this_from < CHARSET_MIN_CODE (charset)) @@ -811,7 +811,7 @@ range of code points (in CHARSET) of target characters. */) from = CHARSET_MIN_CODE (cs); else { - from = XINT (from_code); + from = XFIXNUM (from_code); if (from < CHARSET_MIN_CODE (cs)) from = CHARSET_MIN_CODE (cs); } @@ -819,7 +819,7 @@ range of code points (in CHARSET) of target characters. */) to = CHARSET_MAX_CODE (cs); else { - to = XINT (to_code); + to = XFIXNUM (to_code); if (to > CHARSET_MAX_CODE (cs)) to = CHARSET_MAX_CODE (cs); } @@ -854,9 +854,9 @@ usage: (define-charset-internal ...) */) if (nargs != charset_arg_max) Fsignal (Qwrong_number_of_arguments, Fcons (intern ("define-charset-internal"), - make_number (nargs))); + make_fixnum (nargs))); - attrs = Fmake_vector (make_number (charset_attr_max), Qnil); + attrs = make_nil_vector (charset_attr_max); CHECK_SYMBOL (args[charset_arg_name]); ASET (attrs, charset_name, args[charset_arg_name]); @@ -867,12 +867,12 @@ usage: (define-charset-internal ...) */) Lisp_Object min_byte_obj, max_byte_obj; int min_byte, max_byte; - min_byte_obj = Faref (val, make_number (i * 2)); - max_byte_obj = Faref (val, make_number (i * 2 + 1)); + min_byte_obj = Faref (val, make_fixnum (i * 2)); + max_byte_obj = Faref (val, make_fixnum (i * 2 + 1)); CHECK_RANGED_INTEGER (min_byte_obj, 0, 255); - min_byte = XINT (min_byte_obj); + min_byte = XFIXNUM (min_byte_obj); CHECK_RANGED_INTEGER (max_byte_obj, min_byte, 255); - max_byte = XINT (max_byte_obj); + max_byte = XFIXNUM (max_byte_obj); charset.code_space[i * 4] = min_byte; charset.code_space[i * 4 + 1] = max_byte; charset.code_space[i * 4 + 2] = max_byte - min_byte + 1; @@ -890,7 +890,7 @@ usage: (define-charset-internal ...) */) else { CHECK_RANGED_INTEGER (val, 1, 4); - charset.dimension = XINT (val); + charset.dimension = XFIXNUM (val); } charset.code_linear_p @@ -929,8 +929,8 @@ usage: (define-charset-internal ...) */) if (code < charset.min_code || code > charset.max_code) - args_out_of_range_3 (make_fixnum_or_float (charset.min_code), - make_fixnum_or_float (charset.max_code), val); + args_out_of_range_3 (INT_TO_INTEGER (charset.min_code), + INT_TO_INTEGER (charset.max_code), val); charset.char_index_offset = CODE_POINT_TO_INDEX (&charset, code); charset.min_code = code; } @@ -942,8 +942,8 @@ usage: (define-charset-internal ...) */) if (code < charset.min_code || code > charset.max_code) - args_out_of_range_3 (make_fixnum_or_float (charset.min_code), - make_fixnum_or_float (charset.max_code), val); + args_out_of_range_3 (INT_TO_INTEGER (charset.min_code), + INT_TO_INTEGER (charset.max_code), val); charset.max_code = code; } @@ -970,10 +970,10 @@ usage: (define-charset-internal ...) */) charset.iso_final = -1; else { - CHECK_NUMBER (val); - if (XINT (val) < '0' || XINT (val) > 127) - error ("Invalid iso-final-char: %"pI"d", XINT (val)); - charset.iso_final = XINT (val); + CHECK_FIXNUM (val); + if (XFIXNUM (val) < '0' || XFIXNUM (val) > 127) + error ("Invalid iso-final-char: %"pI"d", XFIXNUM (val)); + charset.iso_final = XFIXNUM (val); } val = args[charset_arg_iso_revision]; @@ -982,7 +982,7 @@ usage: (define-charset-internal ...) */) else { CHECK_RANGED_INTEGER (val, -1, 63); - charset.iso_revision = XINT (val); + charset.iso_revision = XFIXNUM (val); } val = args[charset_arg_emacs_mule_id]; @@ -990,10 +990,10 @@ usage: (define-charset-internal ...) */) charset.emacs_mule_id = -1; else { - CHECK_NATNUM (val); - if ((XINT (val) > 0 && XINT (val) <= 128) || XINT (val) >= 256) - error ("Invalid emacs-mule-id: %"pI"d", XINT (val)); - charset.emacs_mule_id = XINT (val); + CHECK_FIXNAT (val); + if ((XFIXNUM (val) > 0 && XFIXNUM (val) <= 128) || XFIXNUM (val) >= 256) + error ("Invalid emacs-mule-id: %"pI"d", XFIXNUM (val)); + charset.emacs_mule_id = XFIXNUM (val); } charset.ascii_compatible_p = ! NILP (args[charset_arg_ascii_compatible_p]); @@ -1010,7 +1010,7 @@ usage: (define-charset-internal ...) */) CHECK_CHARACTER (val); charset.method = CHARSET_METHOD_OFFSET; - charset.code_offset = XINT (val); + charset.code_offset = XFIXNUM (val); i = CODE_POINT_TO_INDEX (&charset, charset.max_code); if (MAX_CHAR - charset.code_offset < i) @@ -1043,14 +1043,14 @@ usage: (define-charset-internal ...) */) val = args[charset_arg_subset]; parent = Fcar (val); CHECK_CHARSET_GET_CHARSET (parent, parent_charset); - parent_min_code = Fnth (make_number (1), val); - CHECK_NATNUM (parent_min_code); - parent_max_code = Fnth (make_number (2), val); - CHECK_NATNUM (parent_max_code); - parent_code_offset = Fnth (make_number (3), val); - CHECK_NUMBER (parent_code_offset); + parent_min_code = Fnth (make_fixnum (1), val); + CHECK_FIXNAT (parent_min_code); + parent_max_code = Fnth (make_fixnum (2), val); + CHECK_FIXNAT (parent_max_code); + parent_code_offset = Fnth (make_fixnum (3), val); + CHECK_FIXNUM (parent_code_offset); val = make_uninit_vector (4); - ASET (val, 0, make_number (parent_charset->id)); + ASET (val, 0, make_fixnum (parent_charset->id)); ASET (val, 1, parent_min_code); ASET (val, 2, parent_max_code); ASET (val, 3, parent_code_offset); @@ -1089,14 +1089,14 @@ usage: (define-charset-internal ...) */) cdr_part = XCDR (elt); CHECK_CHARSET_GET_ID (car_part, this_id); CHECK_TYPE_RANGED_INTEGER (int, cdr_part); - offset = XINT (cdr_part); + offset = XFIXNUM (cdr_part); } else { CHECK_CHARSET_GET_ID (elt, this_id); offset = 0; } - XSETCAR (val, Fcons (make_number (this_id), make_number (offset))); + XSETCAR (val, Fcons (make_fixnum (this_id), make_fixnum (offset))); this_charset = CHARSET_FROM_ID (this_id); if (charset.min_char > this_charset->min_char) @@ -1123,7 +1123,7 @@ usage: (define-charset-internal ...) */) if (charset.hash_index >= 0) { new_definition_p = 0; - id = XFASTINT (CHARSET_SYMBOL_ID (args[charset_arg_name])); + id = XFIXNAT (CHARSET_SYMBOL_ID (args[charset_arg_name])); set_hash_value_slot (hash_table, charset.hash_index, attrs); } else @@ -1158,7 +1158,7 @@ usage: (define-charset-internal ...) */) new_definition_p = 1; } - ASET (attrs, charset_id, make_number (id)); + ASET (attrs, charset_id, make_fixnum (id)); charset.id = id; charset_table[id] = charset; @@ -1174,7 +1174,7 @@ usage: (define-charset-internal ...) */) charset.iso_final) = id; if (new_definition_p) Viso_2022_charset_list = nconc2 (Viso_2022_charset_list, - list1 (make_number (id))); + list1 (make_fixnum (id))); if (ISO_CHARSET_TABLE (1, 0, 'J') == id) charset_jisx0201_roman = id; else if (ISO_CHARSET_TABLE (2, 0, '@') == id) @@ -1194,7 +1194,7 @@ usage: (define-charset-internal ...) */) emacs_mule_bytes[charset.emacs_mule_id] = charset.dimension + 2; if (new_definition_p) Vemacs_mule_charset_list = nconc2 (Vemacs_mule_charset_list, - list1 (make_number (id))); + list1 (make_fixnum (id))); } if (new_definition_p) @@ -1202,29 +1202,29 @@ usage: (define-charset-internal ...) */) Vcharset_list = Fcons (args[charset_arg_name], Vcharset_list); if (charset.supplementary_p) Vcharset_ordered_list = nconc2 (Vcharset_ordered_list, - list1 (make_number (id))); + list1 (make_fixnum (id))); else { Lisp_Object tail; for (tail = Vcharset_ordered_list; CONSP (tail); tail = XCDR (tail)) { - struct charset *cs = CHARSET_FROM_ID (XINT (XCAR (tail))); + struct charset *cs = CHARSET_FROM_ID (XFIXNUM (XCAR (tail))); if (cs->supplementary_p) break; } if (EQ (tail, Vcharset_ordered_list)) - Vcharset_ordered_list = Fcons (make_number (id), + Vcharset_ordered_list = Fcons (make_fixnum (id), Vcharset_ordered_list); else if (NILP (tail)) Vcharset_ordered_list = nconc2 (Vcharset_ordered_list, - list1 (make_number (id))); + list1 (make_fixnum (id))); else { val = Fcons (XCAR (tail), XCDR (tail)); XSETCDR (tail, val); - XSETCAR (tail, make_number (id)); + XSETCAR (tail, make_fixnum (id)); } } charset_ordered_list_tick++; @@ -1254,22 +1254,22 @@ define_charset_internal (Lisp_Object name, int i; args[charset_arg_name] = name; - args[charset_arg_dimension] = make_number (dimension); + args[charset_arg_dimension] = make_fixnum (dimension); val = make_uninit_vector (8); for (i = 0; i < 8; i++) - ASET (val, i, make_number (code_space[i])); + ASET (val, i, make_fixnum (code_space[i])); args[charset_arg_code_space] = val; - args[charset_arg_min_code] = make_number (min_code); - args[charset_arg_max_code] = make_number (max_code); + args[charset_arg_min_code] = make_fixnum (min_code); + args[charset_arg_max_code] = make_fixnum (max_code); args[charset_arg_iso_final] - = (iso_final < 0 ? Qnil : make_number (iso_final)); - args[charset_arg_iso_revision] = make_number (iso_revision); + = (iso_final < 0 ? Qnil : make_fixnum (iso_final)); + args[charset_arg_iso_revision] = make_fixnum (iso_revision); args[charset_arg_emacs_mule_id] - = (emacs_mule_id < 0 ? Qnil : make_number (emacs_mule_id)); + = (emacs_mule_id < 0 ? Qnil : make_fixnum (emacs_mule_id)); args[charset_arg_ascii_compatible_p] = ascii_compatible ? Qt : Qnil; args[charset_arg_supplementary_p] = supplementary ? Qt : Qnil; args[charset_arg_invalid_code] = Qnil; - args[charset_arg_code_offset] = make_number (code_offset); + args[charset_arg_code_offset] = make_fixnum (code_offset); args[charset_arg_map] = Qnil; args[charset_arg_subset] = Qnil; args[charset_arg_superset] = Qnil; @@ -1293,7 +1293,7 @@ define_charset_internal (Lisp_Object name, args[charset_arg_code_offset]); Fdefine_charset_internal (charset_arg_max, args); - return XINT (CHARSET_SYMBOL_ID (name)); + return XFIXNUM (CHARSET_SYMBOL_ID (name)); } @@ -1396,19 +1396,19 @@ static bool check_iso_charset_parameter (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char) { - CHECK_NUMBER (dimension); - CHECK_NUMBER (chars); + CHECK_FIXNUM (dimension); + CHECK_FIXNUM (chars); CHECK_CHARACTER (final_char); - if (! (1 <= XINT (dimension) && XINT (dimension) <= 3)) + if (! (1 <= XFIXNUM (dimension) && XFIXNUM (dimension) <= 3)) error ("Invalid DIMENSION %"pI"d, it should be 1, 2, or 3", - XINT (dimension)); + XFIXNUM (dimension)); - bool chars_flag = XINT (chars) == 96; - if (! (chars_flag || XINT (chars) == 94)) - error ("Invalid CHARS %"pI"d, it should be 94 or 96", XINT (chars)); + bool chars_flag = XFIXNUM (chars) == 96; + if (! (chars_flag || XFIXNUM (chars) == 94)) + error ("Invalid CHARS %"pI"d, it should be 94 or 96", XFIXNUM (chars)); - int final_ch = XFASTINT (final_char); + int final_ch = XFIXNAT (final_char); if (! ('0' <= final_ch && final_ch <= '~')) error ("Invalid FINAL-CHAR `%c', it should be `0'..`~'", final_ch); @@ -1428,10 +1428,10 @@ return nil. */) (Lisp_Object dimension, Lisp_Object chars) { bool chars_flag = check_iso_charset_parameter (dimension, chars, - make_number ('0')); + make_fixnum ('0')); for (int final_char = '0'; final_char <= '?'; final_char++) - if (ISO_CHARSET_TABLE (XINT (dimension), chars_flag, final_char) < 0) - return make_number (final_char); + if (ISO_CHARSET_TABLE (XFIXNUM (dimension), chars_flag, final_char) < 0) + return make_fixnum (final_char); return Qnil; } @@ -1449,7 +1449,7 @@ if CHARSET is designated instead. */) CHECK_CHARSET_GET_ID (charset, id); bool chars_flag = check_iso_charset_parameter (dimension, chars, final_char); - ISO_CHARSET_TABLE (XINT (dimension), chars_flag, XFASTINT (final_char)) = id; + ISO_CHARSET_TABLE (XFIXNUM (dimension), chars_flag, XFIXNAT (final_char)) = id; return Qnil; } @@ -1550,8 +1550,8 @@ only `ascii', `eight-bit-control', and `eight-bit-graphic'. */) bool multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters)); validate_region (&beg, &end); - from = XFASTINT (beg); - stop = to = XFASTINT (end); + from = XFIXNAT (beg); + stop = to = XFIXNAT (end); if (from < GPT && GPT < to) { @@ -1563,7 +1563,7 @@ only `ascii', `eight-bit-control', and `eight-bit-graphic'. */) from_byte = CHAR_TO_BYTE (from); - charsets = Fmake_vector (make_number (charset_table_used), Qnil); + charsets = make_nil_vector (charset_table_used); while (1) { find_charsets_in_text (BYTE_POS_ADDR (from_byte), stop - from, @@ -1594,18 +1594,14 @@ If STR is unibyte, the returned list may contain only `ascii', `eight-bit-control', and `eight-bit-graphic'. */) (Lisp_Object str, Lisp_Object table) { - Lisp_Object charsets; - int i; - Lisp_Object val; - CHECK_STRING (str); - charsets = Fmake_vector (make_number (charset_table_used), Qnil); + Lisp_Object charsets = make_nil_vector (charset_table_used); find_charsets_in_text (SDATA (str), SCHARS (str), SBYTES (str), charsets, table, STRING_MULTIBYTE (str)); - val = Qnil; - for (i = charset_table_used - 1; i >= 0; i--) + Lisp_Object val = Qnil; + for (int i = charset_table_used - 1; i >= 0; i--) if (!NILP (AREF (charsets, i))) val = Fcons (CHARSET_NAME (charset_table + i), val); return val; @@ -1621,8 +1617,8 @@ maybe_unify_char (int c, Lisp_Object val) { struct charset *charset; - if (INTEGERP (val)) - return XFASTINT (val); + if (FIXNUMP (val)) + return XFIXNAT (val); if (NILP (val)) return c; @@ -1638,7 +1634,7 @@ maybe_unify_char (int c, Lisp_Object val) { val = CHAR_TABLE_REF (Vchar_unify_table, c); if (! NILP (val)) - c = XFASTINT (val); + c = XFIXNAT (val); } else { @@ -1672,10 +1668,10 @@ decode_char (struct charset *charset, unsigned int code) Lisp_Object subset_info; subset_info = CHARSET_SUBSET (charset); - charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0))); - code -= XINT (AREF (subset_info, 3)); - if (code < XFASTINT (AREF (subset_info, 1)) - || code > XFASTINT (AREF (subset_info, 2))) + charset = CHARSET_FROM_ID (XFIXNAT (AREF (subset_info, 0))); + code -= XFIXNUM (AREF (subset_info, 3)); + if (code < XFIXNAT (AREF (subset_info, 1)) + || code > XFIXNAT (AREF (subset_info, 2))) c = -1; else c = DECODE_CHAR (charset, code); @@ -1688,8 +1684,8 @@ decode_char (struct charset *charset, unsigned int code) c = -1; for (; CONSP (parents); parents = XCDR (parents)) { - int id = XINT (XCAR (XCAR (parents))); - int code_offset = XINT (XCDR (XCAR (parents))); + int id = XFIXNUM (XCAR (XCAR (parents))); + int code_offset = XFIXNUM (XCDR (XCAR (parents))); unsigned this_code = code - code_offset; charset = CHARSET_FROM_ID (id); @@ -1714,7 +1710,7 @@ decode_char (struct charset *charset, unsigned int code) decoder = CHARSET_DECODER (charset); } if (VECTORP (decoder)) - c = XINT (AREF (decoder, char_index)); + c = XFIXNUM (AREF (decoder, char_index)); else c = GET_TEMP_CHARSET_WORK_DECODER (char_index); } @@ -1762,8 +1758,8 @@ encode_char (struct charset *charset, int c) { Lisp_Object deunified = CHAR_TABLE_REF (deunifier, c); - if (INTEGERP (deunified)) - code_index = XINT (deunified); + if (FIXNUMP (deunified)) + code_index = XFIXNUM (deunified); } else { @@ -1779,13 +1775,13 @@ encode_char (struct charset *charset, int c) struct charset *this_charset; subset_info = CHARSET_SUBSET (charset); - this_charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0))); + this_charset = CHARSET_FROM_ID (XFIXNAT (AREF (subset_info, 0))); code = ENCODE_CHAR (this_charset, c); if (code == CHARSET_INVALID_CODE (this_charset) - || code < XFASTINT (AREF (subset_info, 1)) - || code > XFASTINT (AREF (subset_info, 2))) + || code < XFIXNAT (AREF (subset_info, 1)) + || code > XFIXNAT (AREF (subset_info, 2))) return CHARSET_INVALID_CODE (charset); - code += XINT (AREF (subset_info, 3)); + code += XFIXNUM (AREF (subset_info, 3)); return code; } @@ -1796,8 +1792,8 @@ encode_char (struct charset *charset, int c) parents = CHARSET_SUPERSET (charset); for (; CONSP (parents); parents = XCDR (parents)) { - int id = XINT (XCAR (XCAR (parents))); - int code_offset = XINT (XCDR (XCAR (parents))); + int id = XFIXNUM (XCAR (XCAR (parents))); + int code_offset = XFIXNUM (XCDR (XCAR (parents))); struct charset *this_charset = CHARSET_FROM_ID (id); code = ENCODE_CHAR (this_charset, c); @@ -1827,7 +1823,7 @@ encode_char (struct charset *charset, int c) val = CHAR_TABLE_REF (encoder, c); if (NILP (val)) return CHARSET_INVALID_CODE (charset); - code = XINT (val); + code = XFIXNUM (val); if (! CHARSET_COMPACT_CODES_P (charset)) code = INDEX_TO_CODE_POINT (charset, code); } @@ -1852,7 +1848,8 @@ 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). */) +CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE), +although this usage is obsolescent. */) (Lisp_Object charset, Lisp_Object code_point) { int c, id; @@ -1863,13 +1860,15 @@ CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE). */) code = cons_to_unsigned (code_point, UINT_MAX); charsetp = CHARSET_FROM_ID (id); c = DECODE_CHAR (charsetp, code); - return (c >= 0 ? make_number (c) : Qnil); + return (c >= 0 ? make_fixnum (c) : Qnil); } 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. */) +Return the encoded code-point, a fixnum if its value is small enough, +otherwise a bignum. +Return nil if CHARSET doesn't support CH. */) (Lisp_Object ch, Lisp_Object charset) { int c, id; @@ -1878,12 +1877,19 @@ Return nil if CHARSET doesn't include CH. */) CHECK_CHARSET_GET_ID (charset, id); CHECK_CHARACTER (ch); - c = XFASTINT (ch); + c = XFIXNAT (ch); charsetp = CHARSET_FROM_ID (id); code = ENCODE_CHAR (charsetp, c); if (code == CHARSET_INVALID_CODE (charsetp)) return Qnil; - return INTEGER_TO_CONS (code); + /* There are much fewer codepoints in the world than we have positive + fixnums, so it could be argued that we never really need a bignum, + e.g. Unicode codepoints only need 21bit, and China's GB-10830 + can fit in 22bit. Yet we encode GB-10830's chars in a sparse way + (we just take the 4byte sequences as a 32bit int), so some + GB-10830 chars (such as 0x81308130 in etc/charsets/gb108304.map) end + up represented as bignums if EMACS_INT is 32 bits. */ + return INT_TO_INTEGER (code); } @@ -1910,10 +1916,10 @@ is specified. */) ? 0 : CHARSET_MIN_CODE (charsetp)); else { - CHECK_NATNUM (code1); - if (XFASTINT (code1) >= 0x100) - args_out_of_range (make_number (0xFF), code1); - code = XFASTINT (code1); + CHECK_FIXNAT (code1); + if (XFIXNAT (code1) >= 0x100) + args_out_of_range (make_fixnum (0xFF), code1); + code = XFIXNAT (code1); if (dimension > 1) { @@ -1922,10 +1928,10 @@ is specified. */) code |= charsetp->code_space[(dimension - 2) * 4]; else { - CHECK_NATNUM (code2); - if (XFASTINT (code2) >= 0x100) - args_out_of_range (make_number (0xFF), code2); - code |= XFASTINT (code2); + CHECK_FIXNAT (code2); + if (XFIXNAT (code2) >= 0x100) + args_out_of_range (make_fixnum (0xFF), code2); + code |= XFIXNAT (code2); } if (dimension > 2) @@ -1935,10 +1941,10 @@ is specified. */) code |= charsetp->code_space[(dimension - 3) * 4]; else { - CHECK_NATNUM (code3); - if (XFASTINT (code3) >= 0x100) - args_out_of_range (make_number (0xFF), code3); - code |= XFASTINT (code3); + CHECK_FIXNAT (code3); + if (XFIXNAT (code3) >= 0x100) + args_out_of_range (make_fixnum (0xFF), code3); + code |= XFIXNAT (code3); } if (dimension > 3) @@ -1948,10 +1954,10 @@ is specified. */) code |= charsetp->code_space[0]; else { - CHECK_NATNUM (code4); - if (XFASTINT (code4) >= 0x100) - args_out_of_range (make_number (0xFF), code4); - code |= XFASTINT (code4); + CHECK_FIXNAT (code4); + if (XFIXNAT (code4) >= 0x100) + args_out_of_range (make_fixnum (0xFF), code4); + code |= XFIXNAT (code4); } } } @@ -1963,7 +1969,7 @@ is specified. */) c = DECODE_CHAR (charsetp, code); if (c < 0) error ("Invalid code(s)"); - return make_number (c); + return make_fixnum (c); } @@ -1983,7 +1989,7 @@ char_charset (int c, Lisp_Object charset_list, unsigned int *code_return) while (CONSP (charset_list)) { - struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (charset_list))); + struct charset *charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list))); unsigned code = ENCODE_CHAR (charset, c); if (code != CHARSET_INVALID_CODE (charset)) @@ -2018,7 +2024,7 @@ CH in the charset. */) Lisp_Object val; CHECK_CHARACTER (ch); - c = XFASTINT (ch); + c = XFIXNAT (ch); charset = CHAR_CHARSET (c); if (! charset) emacs_abort (); @@ -2028,7 +2034,7 @@ CH in the charset. */) dimension = CHARSET_DIMENSION (charset); for (val = Qnil; dimension > 0; dimension--) { - val = Fcons (make_number (code & 0xFF), val); + val = Fcons (make_fixnum (code & 0xFF), val); code >>= 8; } return Fcons (CHARSET_NAME (charset), val); @@ -2048,12 +2054,12 @@ that case, find the charset from what supported by that coding system. */) CHECK_CHARACTER (ch); if (NILP (restriction)) - charset = CHAR_CHARSET (XINT (ch)); + charset = CHAR_CHARSET (XFIXNUM (ch)); else { if (CONSP (restriction)) { - int c = XFASTINT (ch); + int c = XFIXNAT (ch); for (; CONSP (restriction); restriction = XCDR (restriction)) { @@ -2066,7 +2072,7 @@ that case, find the charset from what supported by that coding system. */) return Qnil; } restriction = coding_system_charset_list (restriction); - charset = char_charset (XINT (ch), restriction, NULL); + charset = char_charset (XFIXNUM (ch), restriction, NULL); if (! charset) return Qnil; } @@ -2085,9 +2091,9 @@ If POS is out of range, the value is nil. */) struct charset *charset; ch = Fchar_after (pos); - if (! INTEGERP (ch)) + if (! FIXNUMP (ch)) return ch; - charset = CHAR_CHARSET (XINT (ch)); + charset = CHAR_CHARSET (XFIXNUM (ch)); return (CHARSET_NAME (charset)); } @@ -2104,8 +2110,8 @@ DIMENSION, CHARS, and FINAL-CHAR. */) (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char) { bool chars_flag = check_iso_charset_parameter (dimension, chars, final_char); - int id = ISO_CHARSET_TABLE (XINT (dimension), chars_flag, - XFASTINT (final_char)); + int id = ISO_CHARSET_TABLE (XFIXNUM (dimension), chars_flag, + XFIXNAT (final_char)); return (id >= 0 ? CHARSET_NAME (CHARSET_FROM_ID (id)) : Qnil); } @@ -2139,11 +2145,11 @@ HIGHESTP non-nil means just return the highest priority one. */) Lisp_Object val = Qnil, list = Vcharset_ordered_list; if (!NILP (highestp)) - return CHARSET_NAME (CHARSET_FROM_ID (XINT (Fcar (list)))); + return CHARSET_NAME (CHARSET_FROM_ID (XFIXNUM (Fcar (list)))); while (!NILP (list)) { - val = Fcons (CHARSET_NAME (CHARSET_FROM_ID (XINT (XCAR (list)))), val); + val = Fcons (CHARSET_NAME (CHARSET_FROM_ID (XFIXNUM (XCAR (list)))), val); list = XCDR (list); } return Fnreverse (val); @@ -2165,10 +2171,10 @@ usage: (set-charset-priority &rest charsets) */) for (i = 0; i < nargs; i++) { CHECK_CHARSET_GET_ID (args[i], id); - if (! NILP (Fmemq (make_number (id), old_list))) + if (! NILP (Fmemq (make_fixnum (id), old_list))) { - old_list = Fdelq (make_number (id), old_list); - new_head = Fcons (make_number (id), new_head); + old_list = Fdelq (make_fixnum (id), old_list); + new_head = Fcons (make_fixnum (id), new_head); } } Vcharset_non_preferred_head = old_list; @@ -2186,7 +2192,7 @@ usage: (set-charset-priority &rest charsets) */) list_emacs_mule = Fcons (XCAR (old_list), list_emacs_mule); if (charset_unibyte < 0) { - struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (old_list))); + struct charset *charset = CHARSET_FROM_ID (XFIXNUM (XCAR (old_list))); if (CHARSET_DIMENSION (charset) == 1 && CHARSET_ASCII_COMPATIBLE_P (charset) @@ -2211,7 +2217,7 @@ Return charset identification number of CHARSET. */) int id; CHECK_CHARSET_GET_ID (charset, id); - return make_number (id); + return make_fixnum (id); } struct charset_sort_data @@ -2237,7 +2243,7 @@ See also `charset-priority-list' and `set-charset-priority'. */) (Lisp_Object charsets) { Lisp_Object len = Flength (charsets); - ptrdiff_t n = XFASTINT (len), i, j; + ptrdiff_t n = XFIXNAT (len), i, j; int done; Lisp_Object tail, elt, attrs; struct charset_sort_data *sort_data; @@ -2252,7 +2258,7 @@ See also `charset-priority-list' and `set-charset-priority'. */) elt = XCAR (tail); CHECK_CHARSET_GET_ATTR (elt, attrs); sort_data[i].charset = elt; - sort_data[i].id = id = XINT (CHARSET_ATTR_ID (attrs)); + sort_data[i].id = id = XFIXNUM (CHARSET_ATTR_ID (attrs)); if (id < min_id) min_id = id; if (id > max_id) @@ -2262,7 +2268,7 @@ See also `charset-priority-list' and `set-charset-priority'. */) done < n && CONSP (tail); tail = XCDR (tail), i++) { elt = XCAR (tail); - id = XFASTINT (elt); + id = XFIXNAT (elt); if (id >= min_id && id <= max_id) for (j = 0; j < n; j++) if (sort_data[j].id == id) @@ -2322,8 +2328,6 @@ init_charset_once (void) charset_ksc5601 = -1; } -#ifdef emacs - /* Allocate an initial charset table that is large enough to handle Emacs while it is bootstrapping. As of September 2011, the size needs to be at least 166; make it a bit bigger to allow for future @@ -2424,5 +2428,3 @@ the value may be a list of mnemonics. */); MAX_5_BYTE_CHAR + 1); charset_unibyte = charset_iso_8859_1; } - -#endif /* emacs */ diff --git a/src/charset.h b/src/charset.h index 1ecbb55052d..0822f2d12fe 100644 --- a/src/charset.h +++ b/src/charset.h @@ -355,7 +355,7 @@ set_charset_attr (struct charset *charset, enum charset_attr_index idx, \ if (! SYMBOLP (x) || (idx = CHARSET_SYMBOL_HASH_INDEX (x)) < 0) \ wrong_type_argument (Qcharsetp, (x)); \ - id = XINT (AREF (HASH_VALUE (XHASH_TABLE (Vcharset_hash_table), idx), \ + id = XFIXNUM (AREF (HASH_VALUE (XHASH_TABLE (Vcharset_hash_table), idx), \ charset_id)); \ } while (false) @@ -416,7 +416,7 @@ extern Lisp_Object Vchar_charset_set; : (charset)->method == CHARSET_METHOD_MAP \ ? (((charset)->code_linear_p \ && VECTORP (CHARSET_DECODER (charset))) \ - ? XINT (AREF (CHARSET_DECODER (charset), \ + ? XFIXNUM (AREF (CHARSET_DECODER (charset), \ (code) - (charset)->min_code)) \ : decode_char ((charset), (code))) \ : decode_char ((charset), (code))) @@ -447,7 +447,7 @@ extern Lisp_Object charset_work; ? (charset_work = CHAR_TABLE_REF (CHARSET_ENCODER (charset), c), \ (NILP (charset_work) \ ? (charset)->invalid_code \ - : (unsigned) XFASTINT (charset_work))) \ + : (unsigned) XFIXNAT (charset_work))) \ : encode_char (charset, c)) \ : encode_char (charset, c)))) diff --git a/src/chartab.c b/src/chartab.c index 065ae4f9f20..16017f4a49a 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -118,14 +118,14 @@ the char-table has no extra slot. */) n_extras = 0; else { - CHECK_NATNUM (n); - if (XINT (n) > 10) + CHECK_FIXNAT (n); + if (XFIXNUM (n) > 10) args_out_of_range (n, Qnil); - n_extras = XINT (n); + n_extras = XFIXNUM (n); } size = CHAR_TABLE_STANDARD_SLOTS + n_extras; - vector = Fmake_vector (make_number (size), init); + vector = make_vector (size, init); XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE); set_char_table_parent (vector, Qnil); set_char_table_purpose (vector, purpose); @@ -184,16 +184,13 @@ copy_sub_char_table (Lisp_Object table) Lisp_Object copy_char_table (Lisp_Object table) { - Lisp_Object copy; int size = PVSIZE (table); - int i; - - copy = Fmake_vector (make_number (size), Qnil); + Lisp_Object copy = make_nil_vector (size); XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE); set_char_table_defalt (copy, XCHAR_TABLE (table)->defalt); set_char_table_parent (copy, XCHAR_TABLE (table)->parent); set_char_table_purpose (copy, XCHAR_TABLE (table)->purpose); - for (i = 0; i < chartab_size[0]; i++) + for (int i = 0; i < chartab_size[0]; i++) set_char_table_contents (copy, i, (SUB_CHAR_TABLE_P (XCHAR_TABLE (table)->contents[i]) @@ -201,7 +198,7 @@ copy_char_table (Lisp_Object table) : XCHAR_TABLE (table)->contents[i])); set_char_table_ascii (copy, char_table_ascii (copy)); size -= CHAR_TABLE_STANDARD_SLOTS; - for (i = 0; i < size; i++) + for (int i = 0; i < size; i++) set_char_table_extras (copy, i, XCHAR_TABLE (table)->extras[i]); XSETCHAR_TABLE (copy, XCHAR_TABLE (copy)); @@ -571,12 +568,12 @@ DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot, (Lisp_Object char_table, Lisp_Object n) { CHECK_CHAR_TABLE (char_table); - CHECK_NUMBER (n); - if (XINT (n) < 0 - || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) + CHECK_FIXNUM (n); + if (XFIXNUM (n) < 0 + || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) args_out_of_range (char_table, n); - return XCHAR_TABLE (char_table)->extras[XINT (n)]; + return XCHAR_TABLE (char_table)->extras[XFIXNUM (n)]; } DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot, @@ -586,12 +583,12 @@ DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot, (Lisp_Object char_table, Lisp_Object n, Lisp_Object value) { CHECK_CHAR_TABLE (char_table); - CHECK_NUMBER (n); - if (XINT (n) < 0 - || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) + CHECK_FIXNUM (n); + if (XFIXNUM (n) < 0 + || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table))) args_out_of_range (char_table, n); - set_char_table_extras (char_table, XINT (n), value); + set_char_table_extras (char_table, XFIXNUM (n), value); return value; } @@ -605,18 +602,18 @@ a cons of character codes (for characters in the range), or a character code. * Lisp_Object val; CHECK_CHAR_TABLE (char_table); - if (EQ (range, Qnil)) + if (NILP (range)) val = XCHAR_TABLE (char_table)->defalt; else if (CHARACTERP (range)) - val = CHAR_TABLE_REF (char_table, XFASTINT (range)); + val = CHAR_TABLE_REF (char_table, XFIXNAT (range)); else if (CONSP (range)) { int from, to; CHECK_CHARACTER_CAR (range); CHECK_CHARACTER_CDR (range); - from = XFASTINT (XCAR (range)); - to = XFASTINT (XCDR (range)); + from = XFIXNAT (XCAR (range)); + to = XFIXNAT (XCDR (range)); val = char_table_ref_and_range (char_table, from, &from, &to); /* Not yet implemented. */ } @@ -642,16 +639,16 @@ or a character code. Return VALUE. */) for (i = 0; i < chartab_size[0]; i++) set_char_table_contents (char_table, i, value); } - else if (EQ (range, Qnil)) + else if (NILP (range)) set_char_table_defalt (char_table, value); else if (CHARACTERP (range)) - char_table_set (char_table, XINT (range), value); + char_table_set (char_table, XFIXNUM (range), value); else if (CONSP (range)) { CHECK_CHARACTER_CAR (range); CHECK_CHARACTER_CDR (range); char_table_set_range (char_table, - XINT (XCAR (range)), XINT (XCDR (range)), value); + XFIXNUM (XCAR (range)), XFIXNUM (XCDR (range)), value); } else error ("Invalid RANGE argument to `set-char-table-range'"); @@ -742,7 +739,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), int min_char, max_char; /* Number of characters covered by one element of TABLE. */ int chars_in_block; - int from = XINT (XCAR (range)), to = XINT (XCDR (range)); + int from = XFIXNUM (XCAR (range)), to = XFIXNUM (XCDR (range)); int i, c; bool is_uniprop = UNIPROP_TABLE_P (top); uniprop_decoder_t decoder = UNIPROP_GET_DECODER (top); @@ -783,7 +780,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), if (SUB_CHAR_TABLE_P (this)) { if (to >= nextc) - XSETCDR (range, make_number (nextc - 1)); + XSETCDR (range, make_fixnum (nextc - 1)); val = map_sub_char_table (c_function, function, this, arg, val, range, top); } @@ -807,7 +804,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), set_char_table_parent (parent, Qnil); val = CHAR_TABLE_REF (parent, from); set_char_table_parent (parent, temp); - XSETCDR (range, make_number (c - 1)); + XSETCDR (range, make_fixnum (c - 1)); val = map_sub_char_table (c_function, function, parent, arg, val, range, parent); @@ -817,7 +814,7 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), } if (! NILP (val) && different_value) { - XSETCDR (range, make_number (c - 1)); + XSETCDR (range, make_fixnum (c - 1)); if (EQ (XCAR (range), XCDR (range))) { if (c_function) @@ -843,10 +840,10 @@ map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), } val = this; from = c; - XSETCAR (range, make_number (c)); + XSETCAR (range, make_fixnum (c)); } } - XSETCDR (range, make_number (to)); + XSETCDR (range, make_fixnum (to)); } return val; } @@ -864,7 +861,7 @@ map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object range, val, parent; uniprop_decoder_t decoder = UNIPROP_GET_DECODER (table); - range = Fcons (make_number (0), make_number (MAX_CHAR)); + range = Fcons (make_fixnum (0), make_fixnum (MAX_CHAR)); parent = XCHAR_TABLE (table)->parent; val = XCHAR_TABLE (table)->ascii; @@ -878,7 +875,7 @@ map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent)) { Lisp_Object temp; - int from = XINT (XCAR (range)); + int from = XFIXNUM (XCAR (range)); parent = XCHAR_TABLE (table)->parent; temp = XCHAR_TABLE (parent)->parent; @@ -957,7 +954,7 @@ map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object), { if (! NILP (XCAR (range))) { - XSETCDR (range, make_number (c - 1)); + XSETCDR (range, make_fixnum (c - 1)); if (c_function) (*c_function) (arg, range); else @@ -980,7 +977,7 @@ map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object), { if (! NILP (XCAR (range))) { - XSETCDR (range, make_number (c - 1)); + XSETCDR (range, make_fixnum (c - 1)); if (c_function) (*c_function) (arg, range); else @@ -991,7 +988,7 @@ map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object), else { if (NILP (XCAR (range))) - XSETCAR (range, make_number (c)); + XSETCAR (range, make_fixnum (c)); } } } @@ -1041,7 +1038,7 @@ map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object), { if (! NILP (XCAR (range))) { - XSETCDR (range, make_number (c - 1)); + XSETCDR (range, make_fixnum (c - 1)); if (c_function) (*c_function) (arg, range); else @@ -1052,7 +1049,7 @@ map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object), } if (! NILP (XCAR (range))) { - XSETCDR (range, make_number (c - 1)); + XSETCDR (range, make_fixnum (c - 1)); if (c_function) (*c_function) (arg, range); else @@ -1125,7 +1122,7 @@ uniprop_table_uncompress (Lisp_Object table, int idx) { int v = STRING_CHAR_ADVANCE (p); set_sub_char_table_contents - (sub, idx++, v > 0 ? make_number (v) : Qnil); + (sub, idx++, v > 0 ? make_fixnum (v) : Qnil); } } else if (*p == 2) @@ -1150,7 +1147,7 @@ uniprop_table_uncompress (Lisp_Object table, int idx) } } while (count-- > 0) - set_sub_char_table_contents (sub, idx++, make_number (v)); + set_sub_char_table_contents (sub, idx++, make_fixnum (v)); } } /* It seems that we don't need this function because C code won't need @@ -1174,8 +1171,8 @@ uniprop_decode_value_run_length (Lisp_Object table, Lisp_Object value) { Lisp_Object valvec = XCHAR_TABLE (table)->extras[4]; - if (XINT (value) >= 0 && XINT (value) < ASIZE (valvec)) - value = AREF (valvec, XINT (value)); + if (XFIXNUM (value) >= 0 && XFIXNUM (value) < ASIZE (valvec)) + value = AREF (valvec, XFIXNUM (value)); } return value; } @@ -1192,9 +1189,9 @@ uniprop_get_decoder (Lisp_Object table) { EMACS_INT i; - if (! INTEGERP (XCHAR_TABLE (table)->extras[1])) + if (! FIXNUMP (XCHAR_TABLE (table)->extras[1])) return NULL; - i = XINT (XCHAR_TABLE (table)->extras[1]); + i = XFIXNUM (XCHAR_TABLE (table)->extras[1]); if (i < 0 || i >= uniprop_decoder_count) return NULL; return uniprop_decoder[i]; @@ -1227,7 +1224,7 @@ uniprop_encode_value_run_length (Lisp_Object table, Lisp_Object value) break; if (i == size) wrong_type_argument (build_string ("Unicode property value"), value); - return make_number (i); + return make_fixnum (i); } @@ -1240,17 +1237,17 @@ uniprop_encode_value_numeric (Lisp_Object table, Lisp_Object value) Lisp_Object *value_table = XVECTOR (XCHAR_TABLE (table)->extras[4])->contents; int i, size = ASIZE (XCHAR_TABLE (table)->extras[4]); - CHECK_NUMBER (value); + CHECK_FIXNUM (value); for (i = 0; i < size; i++) if (EQ (value, value_table[i])) break; - value = make_number (i); + value = make_fixnum (i); if (i == size) set_char_table_extras (table, 4, CALLN (Fvconcat, XCHAR_TABLE (table)->extras[4], - Fmake_vector (make_number (1), value))); - return make_number (i); + make_vector (1, value))); + return make_fixnum (i); } static uniprop_encoder_t uniprop_encoder[] = @@ -1267,9 +1264,9 @@ uniprop_get_encoder (Lisp_Object table) { EMACS_INT i; - if (! INTEGERP (XCHAR_TABLE (table)->extras[2])) + if (! FIXNUMP (XCHAR_TABLE (table)->extras[2])) return NULL; - i = XINT (XCHAR_TABLE (table)->extras[2]); + i = XFIXNUM (XCHAR_TABLE (table)->extras[2]); if (i < 0 || i >= uniprop_encoder_count) return NULL; return uniprop_encoder[i]; @@ -1300,8 +1297,8 @@ uniprop_table (Lisp_Object prop) || ! UNIPROP_TABLE_P (table)) return Qnil; val = XCHAR_TABLE (table)->extras[1]; - if (INTEGERP (val) - ? (XINT (val) < 0 || XINT (val) >= uniprop_decoder_count) + if (FIXNUMP (val) + ? (XFIXNUM (val) < 0 || XFIXNUM (val) >= uniprop_decoder_count) : ! NILP (val)) return Qnil; /* Prepare ASCII values in advance for CHAR_TABLE_REF. */ @@ -1337,7 +1334,7 @@ CHAR-TABLE must be what returned by `unicode-property-table-internal'. */) CHECK_CHARACTER (ch); if (! UNIPROP_TABLE_P (char_table)) error ("Invalid Unicode property table"); - val = CHAR_TABLE_REF (char_table, XINT (ch)); + val = CHAR_TABLE_REF (char_table, XFIXNUM (ch)); decoder = uniprop_get_decoder (char_table); return (decoder ? decoder (char_table, val) : val); } @@ -1357,7 +1354,7 @@ CHAR-TABLE must be what returned by `unicode-property-table-internal'. */) encoder = uniprop_get_encoder (char_table); if (encoder) value = encoder (char_table, value); - CHAR_TABLE_SET (char_table, XINT (ch), value); + CHAR_TABLE_SET (char_table, XFIXNUM (ch), value); return Qnil; } diff --git a/src/cmds.c b/src/cmds.c index c92df6a8356..1f81b9986a7 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -35,9 +35,9 @@ DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0, doc: /* Return buffer position N characters after (before if N negative) point. */) (Lisp_Object n) { - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - return make_number (PT + XINT (n)); + return make_fixnum (PT + XFIXNUM (n)); } /* Add N to point; or subtract N if FORWARD is false. N defaults to 1. @@ -45,7 +45,7 @@ DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0, static Lisp_Object move_point (Lisp_Object n, bool forward) { - /* This used to just set point to point + XINT (n), and then check + /* This used to just set point to point + XFIXNUM (n), and then check to see if it was within boundaries. But now that SET_PT can potentially do a lot of stuff (calling entering and exiting hooks, etcetera), that's not a good approach. So we validate the @@ -56,9 +56,9 @@ move_point (Lisp_Object n, bool forward) if (NILP (n)) XSETFASTINT (n, 1); else - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - new_point = PT + (forward ? XINT (n) : - XINT (n)); + new_point = PT + (forward ? XFIXNUM (n) : - XFIXNUM (n)); if (new_point < BEGV) { @@ -127,8 +127,8 @@ go to its beginning. */) count = 1; else { - CHECK_NUMBER (n); - count = XINT (n); + CHECK_FIXNUM (n); + count = XFIXNUM (n); } shortage = scan_newline_from_point (count, &pos, &pos_byte); @@ -142,7 +142,7 @@ go to its beginning. */) && (FETCH_BYTE (PT_BYTE - 1) != '\n')))) shortage--; - return make_number (count <= 0 ? - shortage : shortage); + return make_fixnum (count <= 0 ? - shortage : shortage); } DEFUN ("beginning-of-line", Fbeginning_of_line, Sbeginning_of_line, 0, 1, "^p", @@ -162,9 +162,9 @@ instead. For instance, `(forward-line 0)' does the same thing as if (NILP (n)) XSETFASTINT (n, 1); else - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - SET_PT (XINT (Fline_beginning_position (n))); + SET_PT (XFIXNUM (Fline_beginning_position (n))); return Qnil; } @@ -187,11 +187,11 @@ to t. */) if (NILP (n)) XSETFASTINT (n, 1); else - CHECK_NUMBER (n); + CHECK_FIXNUM (n); while (1) { - newpos = XINT (Fline_end_position (n)); + newpos = XFIXNUM (Fline_end_position (n)); SET_PT (newpos); if (PT > newpos @@ -210,7 +210,7 @@ to t. */) /* If we skipped something intangible and now we're not really at eol, keep going. */ - n = make_number (1); + n = make_fixnum (1); else break; } @@ -230,15 +230,15 @@ because it respects values of `delete-active-region' and `overwrite-mode'. */) { EMACS_INT pos; - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - if (eabs (XINT (n)) < 2) + if (eabs (XFIXNUM (n)) < 2) call0 (Qundo_auto_amalgamate); - pos = PT + XINT (n); + pos = PT + XFIXNUM (n); if (NILP (killflag)) { - if (XINT (n) < 0) + if (XFIXNUM (n) < 0) { if (pos < BEGV) xsignal0 (Qbeginning_of_buffer); @@ -260,11 +260,10 @@ because it respects values of `delete-active-region' and `overwrite-mode'. */) return Qnil; } -/* Note that there's code in command_loop_1 which typically avoids - calling this. */ -DEFUN ("self-insert-command", Fself_insert_command, Sself_insert_command, 1, 1, "p", +DEFUN ("self-insert-command", Fself_insert_command, Sself_insert_command, 1, 2, + "(list (prefix-numeric-value current-prefix-arg) last-command-event)", doc: /* Insert the character you type. -Whichever character you type to run this command is inserted. +Whichever character C you type to run this command is inserted. The numeric prefix argument N says how many times to repeat the insertion. Before insertion, `expand-abbrev' is executed if the inserted character does not have word syntax and the previous character in the buffer does. @@ -272,23 +271,27 @@ After insertion, `internal-auto-fill' is called if `auto-fill-function' is non-nil and if the `auto-fill-chars' table has a non-nil value for the inserted character. At the end, it runs `post-self-insert-hook'. */) - (Lisp_Object n) + (Lisp_Object n, Lisp_Object c) { - CHECK_NUMBER (n); + CHECK_FIXNUM (n); + + /* Backward compatibility. */ + if (NILP (c)) + c = last_command_event; - if (XINT (n) < 0) - error ("Negative repetition argument %"pI"d", XINT (n)); + if (XFIXNUM (n) < 0) + error ("Negative repetition argument %"pI"d", XFIXNUM (n)); - if (XFASTINT (n) < 2) + if (XFIXNAT (n) < 2) call0 (Qundo_auto_amalgamate); /* Barf if the key that invoked this was not a character. */ - if (!CHARACTERP (last_command_event)) + if (!CHARACTERP (c)) bitch_at_user (); else { int character = translate_char (Vtranslation_table_for_input, - XINT (last_command_event)); - int val = internal_self_insert (character, XFASTINT (n)); + XFIXNUM (c)); + int val = internal_self_insert (character, XFIXNAT (n)); if (val == 2) Fset (Qundo_auto__this_command_amalgamating, Qnil); frame_make_pointer_invisible (SELECTED_FRAME ()); @@ -360,7 +363,7 @@ internal_self_insert (int c, EMACS_INT n) if (EQ (overwrite, Qoverwrite_mode_binary)) chars_to_delete = min (n, PTRDIFF_MAX); else if (c != '\n' && c2 != '\n' - && (cwidth = XFASTINT (Fchar_width (make_number (c)))) != 0) + && (cwidth = XFIXNAT (Fchar_width (make_fixnum (c)))) != 0) { ptrdiff_t pos = PT; ptrdiff_t pos_byte = PT_BYTE; @@ -378,7 +381,7 @@ internal_self_insert (int c, EMACS_INT n) character. In that case, the new point is set after that character. */ ptrdiff_t actual_clm - = XFASTINT (Fmove_to_column (make_number (target_clm), Qnil)); + = XFIXNAT (Fmove_to_column (make_fixnum (target_clm), Qnil)); chars_to_delete = PT - pos; @@ -408,8 +411,8 @@ internal_self_insert (int c, EMACS_INT n) && NILP (BVAR (current_buffer, read_only)) && PT > BEGV && (SYNTAX (!NILP (BVAR (current_buffer, enable_multibyte_characters)) - ? XFASTINT (Fprevious_char ()) - : UNIBYTE_TO_CHAR (XFASTINT (Fprevious_char ()))) + ? XFIXNAT (Fprevious_char ()) + : UNIBYTE_TO_CHAR (XFIXNAT (Fprevious_char ()))) == Sword)) { EMACS_INT modiff = MODIFF; @@ -439,17 +442,18 @@ internal_self_insert (int c, EMACS_INT n) int mc = ((NILP (BVAR (current_buffer, enable_multibyte_characters)) && SINGLE_BYTE_CHAR_P (c)) ? UNIBYTE_TO_CHAR (c) : c); - Lisp_Object string = Fmake_string (make_number (n), make_number (mc)); + Lisp_Object string = Fmake_string (make_fixnum (n), make_fixnum (mc), + Qnil); if (spaces_to_insert) { - tem = Fmake_string (make_number (spaces_to_insert), - make_number (' ')); + tem = Fmake_string (make_fixnum (spaces_to_insert), + make_fixnum (' '), Qnil); string = concat2 (string, tem); } replace_range (PT, PT + chars_to_delete, string, 1, 1, 1, 0); - Fforward_char (make_number (n)); + Fforward_char (make_fixnum (n)); } else if (n > 1) { diff --git a/src/coding.c b/src/coding.c index 249abd9dd4e..0297c8a100d 100644 --- a/src/coding.c +++ b/src/coding.c @@ -307,16 +307,12 @@ Lisp_Object Vcoding_system_hash_table; file and process), not for in-buffer or Lisp string encoding. */ static Lisp_Object system_eol_type; -#ifdef emacs - /* Coding-systems are handed between Emacs Lisp programs and C internal routines by the following three variables. */ /* Coding system to be used to encode text for terminal display when terminal coding system is nil. */ struct coding_system safe_terminal_coding; -#endif /* emacs */ - /* Two special coding systems. */ static Lisp_Object Vsjis_coding_system; static Lisp_Object Vbig5_coding_system; @@ -324,7 +320,7 @@ static Lisp_Object Vbig5_coding_system; /* ISO2022 section */ #define CODING_ISO_INITIAL(coding, reg) \ - (XINT (AREF (AREF (CODING_ID_ATTRS ((coding)->id), \ + (XFIXNUM (AREF (AREF (CODING_ID_ATTRS ((coding)->id), \ coding_attr_iso_initial), \ reg))) @@ -617,23 +613,7 @@ inhibit_flag (int encoded_flag, bool var) do { \ (attrs) = CODING_ID_ATTRS ((coding)->id); \ (charset_list) = CODING_ATTR_CHARSET_LIST (attrs); \ - } while (0) - -static void -CHECK_NATNUM_CAR (Lisp_Object x) -{ - Lisp_Object tmp = XCAR (x); - CHECK_NATNUM (tmp); - XSETCAR (x, tmp); -} - -static void -CHECK_NATNUM_CDR (Lisp_Object x) -{ - Lisp_Object tmp = XCDR (x); - CHECK_NATNUM (tmp); - XSETCDR (x, tmp); -} + } while (false) /* True if CODING's destination can be grown. */ @@ -2622,7 +2602,7 @@ encode_coding_emacs_mule (struct coding_system *coding) case CODING_ANNOTATE_CHARSET_MASK: preferred_charset_id = charbuf[3]; if (preferred_charset_id >= 0 - && NILP (Fmemq (make_number (preferred_charset_id), + && NILP (Fmemq (make_fixnum (preferred_charset_id), charset_list))) preferred_charset_id = -1; break; @@ -2888,7 +2868,7 @@ setup_iso_safe_charsets (Lisp_Object attrs) Lisp_Object reg_usage; Lisp_Object tail; EMACS_INT reg94, reg96; - int flags = XINT (AREF (attrs, coding_attr_iso_flags)); + int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags)); int max_charset_id; charset_list = CODING_ATTR_CHARSET_LIST (attrs); @@ -2906,7 +2886,7 @@ setup_iso_safe_charsets (Lisp_Object attrs) max_charset_id = 0; for (tail = charset_list; CONSP (tail); tail = XCDR (tail)) { - int id = XINT (XCAR (tail)); + int id = XFIXNUM (XCAR (tail)); if (max_charset_id < id) max_charset_id = id; } @@ -2915,8 +2895,8 @@ setup_iso_safe_charsets (Lisp_Object attrs) memset (SDATA (safe_charsets), 255, max_charset_id + 1); request = AREF (attrs, coding_attr_iso_request); reg_usage = AREF (attrs, coding_attr_iso_usage); - reg94 = XINT (XCAR (reg_usage)); - reg96 = XINT (XCDR (reg_usage)); + reg94 = XFIXNUM (XCAR (reg_usage)); + reg96 = XFIXNUM (XCDR (reg_usage)); for (tail = charset_list; CONSP (tail); tail = XCDR (tail)) { @@ -2925,19 +2905,19 @@ setup_iso_safe_charsets (Lisp_Object attrs) struct charset *charset; id = XCAR (tail); - charset = CHARSET_FROM_ID (XINT (id)); + charset = CHARSET_FROM_ID (XFIXNUM (id)); reg = Fcdr (Fassq (id, request)); if (! NILP (reg)) - SSET (safe_charsets, XINT (id), XINT (reg)); + SSET (safe_charsets, XFIXNUM (id), XFIXNUM (reg)); else if (charset->iso_chars_96) { if (reg96 < 4) - SSET (safe_charsets, XINT (id), reg96); + SSET (safe_charsets, XFIXNUM (id), reg96); } else { if (reg94 < 4) - SSET (safe_charsets, XINT (id), reg94); + SSET (safe_charsets, XFIXNUM (id), reg94); } } ASET (attrs, coding_attr_safe_charsets, safe_charsets); @@ -4459,7 +4439,7 @@ encode_coding_iso_2022 (struct coding_system *coding) case CODING_ANNOTATE_CHARSET_MASK: preferred_charset_id = charbuf[2]; if (preferred_charset_id >= 0 - && NILP (Fmemq (make_number (preferred_charset_id), + && NILP (Fmemq (make_fixnum (preferred_charset_id), charset_list))) preferred_charset_id = -1; break; @@ -4612,7 +4592,7 @@ detect_coding_sjis (struct coding_system *coding, CODING_GET_INFO (coding, attrs, charset_list); max_first_byte_of_2_byte_code - = (XINT (Flength (charset_list)) > 3 ? 0xFC : 0xEF); + = (XFIXNUM (Flength (charset_list)) > 3 ? 0xFC : 0xEF); detect_info->checked |= CATEGORY_MASK_SJIS; /* A coding system of this category is always ASCII compatible. */ @@ -4725,10 +4705,10 @@ decode_coding_sjis (struct coding_system *coding) CODING_GET_INFO (coding, attrs, charset_list); val = charset_list; - charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_kana = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_kanji = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XINT (XCAR (val))); + charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_kana = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_kanji = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XFIXNUM (XCAR (val))); while (1) { @@ -4840,8 +4820,8 @@ decode_coding_big5 (struct coding_system *coding) CODING_GET_INFO (coding, attrs, charset_list); val = charset_list; - charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_big5 = CHARSET_FROM_ID (XINT (XCAR (val))); + charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_big5 = CHARSET_FROM_ID (XFIXNUM (XCAR (val))); while (1) { @@ -4936,9 +4916,9 @@ encode_coding_sjis (struct coding_system *coding) CODING_GET_INFO (coding, attrs, charset_list); val = XCDR (charset_list); - charset_kana = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_kanji = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XINT (XCAR (val))); + charset_kana = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_kanji = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_kanji2 = NILP (val) ? NULL : CHARSET_FROM_ID (XFIXNUM (XCAR (val))); ascii_compatible = ! NILP (CODING_ATTR_ASCII_COMPAT (attrs)); @@ -5029,7 +5009,7 @@ encode_coding_big5 (struct coding_system *coding) CODING_GET_INFO (coding, attrs, charset_list); val = XCDR (charset_list); - charset_big5 = CHARSET_FROM_ID (XINT (XCAR (val))); + charset_big5 = CHARSET_FROM_ID (XFIXNUM (XCAR (val))); ascii_compatible = ! NILP (CODING_ATTR_ASCII_COMPAT (attrs)); while (charbuf < charbuf_end) @@ -5440,9 +5420,9 @@ detect_coding_charset (struct coding_system *coding, break; found = CATEGORY_MASK_CHARSET; } - if (INTEGERP (val)) + if (FIXNUMP (val)) { - charset = CHARSET_FROM_ID (XFASTINT (val)); + charset = CHARSET_FROM_ID (XFIXNAT (val)); dim = CHARSET_DIMENSION (charset); for (idx = 1; idx < dim; idx++) { @@ -5461,7 +5441,7 @@ detect_coding_charset (struct coding_system *coding, idx = 1; for (; CONSP (val); val = XCDR (val)) { - charset = CHARSET_FROM_ID (XFASTINT (XCAR (val))); + charset = CHARSET_FROM_ID (XFIXNAT (XCAR (val))); dim = CHARSET_DIMENSION (charset); while (idx < dim) { @@ -5551,11 +5531,11 @@ decode_coding_charset (struct coding_system *coding) code = c; val = AREF (valids, c); - if (! INTEGERP (val) && ! CONSP (val)) + if (! FIXNUMP (val) && ! CONSP (val)) goto invalid_code; - if (INTEGERP (val)) + if (FIXNUMP (val)) { - charset = CHARSET_FROM_ID (XFASTINT (val)); + charset = CHARSET_FROM_ID (XFIXNAT (val)); dim = CHARSET_DIMENSION (charset); while (len < dim) { @@ -5573,7 +5553,7 @@ decode_coding_charset (struct coding_system *coding) comes first). */ while (CONSP (val)) { - charset = CHARSET_FROM_ID (XFASTINT (XCAR (val))); + charset = CHARSET_FROM_ID (XFIXNAT (XCAR (val))); dim = CHARSET_DIMENSION (charset); while (len < dim) { @@ -5726,7 +5706,7 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding) val = CODING_ATTR_SAFE_CHARSETS (attrs); coding->max_charset_id = SCHARS (val) - 1; coding->safe_charsets = SDATA (val); - coding->default_char = XINT (CODING_ATTR_DEFAULT_CHAR (attrs)); + coding->default_char = XFIXNUM (CODING_ATTR_DEFAULT_CHAR (attrs)); coding->carryover_bytes = 0; coding->raw_destination = 0; @@ -5749,7 +5729,7 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding) else if (EQ (coding_type, Qiso_2022)) { int i; - int flags = XINT (AREF (attrs, coding_attr_iso_flags)); + int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags)); /* Invoke graphic register 0 to plane 0. */ CODING_ISO_INVOCATION (coding, 0) = 0; @@ -5852,13 +5832,13 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding) for (tail = Vemacs_mule_charset_list; CONSP (tail); tail = XCDR (tail)) - if (max_charset_id < XFASTINT (XCAR (tail))) - max_charset_id = XFASTINT (XCAR (tail)); + if (max_charset_id < XFIXNAT (XCAR (tail))) + max_charset_id = XFIXNAT (XCAR (tail)); safe_charsets = make_uninit_string (max_charset_id + 1); memset (SDATA (safe_charsets), 255, max_charset_id + 1); for (tail = Vemacs_mule_charset_list; CONSP (tail); tail = XCDR (tail)) - SSET (safe_charsets, XFASTINT (XCAR (tail)), 0); + SSET (safe_charsets, XFIXNAT (XCAR (tail)), 0); coding->max_charset_id = max_charset_id; coding->safe_charsets = SDATA (safe_charsets); } @@ -5908,7 +5888,7 @@ coding_charset_list (struct coding_system *coding) CODING_GET_INFO (coding, attrs, charset_list); if (EQ (CODING_ATTR_TYPE (attrs), Qiso_2022)) { - int flags = XINT (AREF (attrs, coding_attr_iso_flags)); + int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags)); if (flags & CODING_ISO_FLAG_FULL_SUPPORT) charset_list = Viso_2022_charset_list; @@ -5934,7 +5914,7 @@ coding_system_charset_list (Lisp_Object coding_system) if (EQ (CODING_ATTR_TYPE (attrs), Qiso_2022)) { - int flags = XINT (AREF (attrs, coding_attr_iso_flags)); + int flags = XFIXNUM (AREF (attrs, coding_attr_iso_flags)); if (flags & CODING_ISO_FLAG_FULL_SUPPORT) charset_list = Viso_2022_charset_list; @@ -6356,6 +6336,27 @@ check_utf_8 (struct coding_system *coding) } +/* Return whether STRING is a valid UTF-8 string. STRING must be a + unibyte string. */ + +bool +utf8_string_p (Lisp_Object string) +{ + eassert (!STRING_MULTIBYTE (string)); + struct coding_system coding; + setup_coding_system (Qutf_8_unix, &coding); + /* We initialize only the fields that check_utf_8 accesses. */ + coding.head_ascii = -1; + coding.src_pos = 0; + coding.src_pos_byte = 0; + coding.src_chars = SCHARS (string); + coding.src_bytes = SBYTES (string); + coding.src_object = string; + coding.eol_seen = EOL_SEEN_NONE; + return check_utf_8 (&coding) != -1; +} + + /* Detect how end-of-line of a text of length SRC_BYTES pointed by SOURCE is encoded. If CATEGORY is one of coding_category_utf_16_XXXX, assume that CR and LF are encoded by @@ -6693,7 +6694,7 @@ detect_coding (struct coding_system *coding) } } } - else if (XINT (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id))) + else if (XFIXNUM (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id))) == coding_category_utf_8_auto) { Lisp_Object coding_systems; @@ -6719,7 +6720,7 @@ detect_coding (struct coding_system *coding) } } } - else if (XINT (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id))) + else if (XFIXNUM (CODING_ATTR_CATEGORY (CODING_ID_ATTRS (coding->id))) == coding_category_utf_16_auto) { Lisp_Object coding_systems; @@ -6903,8 +6904,8 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup) && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (translation_table)) > 1) { val = XCHAR_TABLE (translation_table)->extras[1]; - if (NATNUMP (val) && *max_lookup < XFASTINT (val)) - *max_lookup = min (XFASTINT (val), MAX_LOOKUP_MAX); + if (FIXNATP (val) && *max_lookup < XFIXNAT (val)) + *max_lookup = min (XFIXNAT (val), MAX_LOOKUP_MAX); } else if (CONSP (translation_table)) { @@ -6915,8 +6916,8 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup) && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (XCAR (tail))) > 1) { Lisp_Object tailval = XCHAR_TABLE (XCAR (tail))->extras[1]; - if (NATNUMP (tailval) && *max_lookup < XFASTINT (tailval)) - *max_lookup = min (XFASTINT (tailval), MAX_LOOKUP_MAX); + if (FIXNATP (tailval) && *max_lookup < XFIXNAT (tailval)) + *max_lookup = min (XFIXNAT (tailval), MAX_LOOKUP_MAX); } } } @@ -6930,7 +6931,7 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup) { \ trans = CHAR_TABLE_REF (table, c); \ if (CHARACTERP (trans)) \ - c = XFASTINT (trans), trans = Qnil; \ + c = XFIXNAT (trans), trans = Qnil; \ } \ else if (CONSP (table)) \ { \ @@ -6941,7 +6942,7 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup) { \ trans = CHAR_TABLE_REF (XCAR (tail), c); \ if (CHARACTERP (trans)) \ - c = XFASTINT (trans), trans = Qnil; \ + c = XFIXNAT (trans), trans = Qnil; \ else if (! NILP (trans)) \ break; \ } \ @@ -6960,7 +6961,7 @@ get_translation_table (Lisp_Object attrs, bool encodep, int *max_lookup) static Lisp_Object get_translation (Lisp_Object trans, int *buf, int *buf_end, ptrdiff_t *nchars) { - if (INTEGERP (trans) || VECTORP (trans)) + if (FIXNUMP (trans) || VECTORP (trans)) { *nchars = 1; return trans; @@ -6976,7 +6977,7 @@ get_translation (Lisp_Object trans, int *buf, int *buf_end, ptrdiff_t *nchars) { if (buf + i == buf_end) return Qt; - if (XINT (AREF (from, i)) != buf[i]) + if (XFIXNUM (AREF (from, i)) != buf[i]) break; } if (i == len) @@ -7027,12 +7028,12 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, if (! NILP (trans)) { trans = get_translation (trans, buf, buf_end, &from_nchars); - if (INTEGERP (trans)) - c = XINT (trans); + if (FIXNUMP (trans)) + c = XFIXNUM (trans); else if (VECTORP (trans)) { to_nchars = ASIZE (trans); - c = XINT (AREF (trans, 0)); + c = XFIXNUM (AREF (trans, 0)); } else if (EQ (trans, Qt) && ! last_block) break; @@ -7060,7 +7061,7 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, for (i = 0; i < to_nchars; i++) { if (i > 0) - c = XINT (AREF (trans, i)); + c = XFIXNUM (AREF (trans, i)); if (coding->dst_multibyte || ! CHAR_BYTE8_P (c)) CHAR_STRING_ADVANCE_NO_UNIFY (c, dst); @@ -7218,11 +7219,11 @@ produce_composition (struct coding_system *coding, int *charbuf, ptrdiff_t pos) for (i = j = 0; i < len && charbuf[i] != -1; i++, j++) { if (charbuf[i] >= 0) - args[j] = make_number (charbuf[i]); + args[j] = make_fixnum (charbuf[i]); else { i++; - args[j] = make_number (charbuf[i] % 0x100); + args[j] = make_fixnum (charbuf[i] % 0x100); } } components = (i == j ? Fstring (j, args) : Fvector (j, args)); @@ -7242,7 +7243,7 @@ produce_charset (struct coding_system *coding, int *charbuf, ptrdiff_t pos) ptrdiff_t from = pos - charbuf[2]; struct charset *charset = CHARSET_FROM_ID (charbuf[3]); - Fput_text_property (make_number (from), make_number (pos), + Fput_text_property (make_fixnum (from), make_fixnum (pos), Qcharset, CHARSET_NAME (charset), coding->dst_object); } @@ -7513,7 +7514,7 @@ handle_composition_annotation (ptrdiff_t pos, ptrdiff_t limit, { len = ASIZE (components); for (i = 0; i < len; i++) - *buf++ = XINT (AREF (components, i)); + *buf++ = XFIXNUM (AREF (components, i)); } else if (STRINGP (components)) { @@ -7525,16 +7526,16 @@ handle_composition_annotation (ptrdiff_t pos, ptrdiff_t limit, buf++; } } - else if (INTEGERP (components)) + else if (FIXNUMP (components)) { len = 1; - *buf++ = XINT (components); + *buf++ = XFIXNUM (components); } else if (CONSP (components)) { for (len = 0; CONSP (components); len++, components = XCDR (components)) - *buf++ = XINT (XCAR (components)); + *buf++ = XFIXNUM (XCAR (components)); } else emacs_abort (); @@ -7570,16 +7571,16 @@ handle_charset_annotation (ptrdiff_t pos, ptrdiff_t limit, Lisp_Object val, next; int id; - val = Fget_text_property (make_number (pos), Qcharset, coding->src_object); + val = Fget_text_property (make_fixnum (pos), Qcharset, coding->src_object); if (! NILP (val) && CHARSETP (val)) - id = XINT (CHARSET_SYMBOL_ID (val)); + id = XFIXNUM (CHARSET_SYMBOL_ID (val)); else id = -1; ADD_CHARSET_DATA (buf, 0, id); - next = Fnext_single_property_change (make_number (pos), Qcharset, + next = Fnext_single_property_change (make_fixnum (pos), Qcharset, coding->src_object, - make_number (limit)); - *stop = XINT (next); + make_fixnum (limit)); + *stop = XFIXNUM (next); return buf; } @@ -7688,20 +7689,20 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, lookup_buf_end = lookup_buf + i; trans = get_translation (trans, lookup_buf, lookup_buf_end, &from_nchars); - if (INTEGERP (trans)) - c = XINT (trans); + if (FIXNUMP (trans)) + c = XFIXNUM (trans); else if (VECTORP (trans)) { to_nchars = ASIZE (trans); if (buf_end - buf < to_nchars) break; - c = XINT (AREF (trans, 0)); + c = XFIXNUM (AREF (trans, 0)); } else break; *buf++ = c; for (i = 1; i < to_nchars; i++) - *buf++ = XINT (AREF (trans, i)); + *buf++ = XFIXNUM (AREF (trans, i)); for (i = 1; i < from_nchars; i++, pos++) src += MULTIBYTE_LENGTH_NO_CHECK (src); } @@ -7984,18 +7985,16 @@ 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); + make_fixnum (coding->produced_char)); + CHECK_FIXNAT (val); coding->produced_char += Z - prev_Z; coding->produced += Z_BYTE - prev_Z_BYTE; - unbind_to (count1, Qnil); } unbind_to (count, Qnil); @@ -8144,8 +8143,8 @@ decode_coding_object (struct coding_system *coding, 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); + make_fixnum (coding->produced_char)); + CHECK_FIXNAT (val); coding->produced_char += Z - prev_Z; coding->produced += Z_BYTE - prev_Z_BYTE; unbind_to (count1, Qnil); @@ -8274,7 +8273,7 @@ encode_coding_object (struct coding_system *coding, } safe_call2 (CODING_ATTR_PRE_WRITE (attrs), - make_number (BEG), make_number (Z)); + make_fixnum (BEG), make_fixnum (Z)); if (XBUFFER (coding->src_object) != current_buffer) kill_src_buffer = 1; coding->src_object = Fcurrent_buffer (); @@ -8440,7 +8439,7 @@ from_unicode (Lisp_Object str) if (!STRING_MULTIBYTE (str) && SBYTES (str) & 1) { - str = Fsubstring (str, make_number (0), make_number (-1)); + str = Fsubstring (str, make_fixnum (0), make_fixnum (-1)); } return code_convert_string_norecord (str, Qutf_16le, 0); @@ -8475,7 +8474,6 @@ to_unicode (Lisp_Object str, Lisp_Object *buf) #endif /* WINDOWSNT || CYGWIN */ -#ifdef emacs /*** 8. Emacs Lisp library functions ***/ DEFUN ("coding-system-p", Fcoding_system_p, Scoding_system_p, 1, 1, 0, @@ -8524,7 +8522,7 @@ are lower-case). */) val = Fcompleting_read (prompt, Vcoding_system_alist, Qnil, Qt, Qnil, Qcoding_system_history, default_coding_system, Qnil); - unbind_to (count, Qnil); + val = unbind_to (count, val); return (SCHARS (val) == 0 ? Qnil : Fintern (val, Qnil)); } @@ -8599,7 +8597,7 @@ detect_coding_system (const unsigned char *src, detect_info.checked = detect_info.found = detect_info.rejected = 0; /* At first, detect text-format if necessary. */ - base_category = XINT (CODING_ATTR_CATEGORY (attrs)); + base_category = XFIXNUM (CODING_ATTR_CATEGORY (attrs)); if (base_category == coding_category_undecided) { enum coding_category category UNINIT; @@ -8722,20 +8720,20 @@ detect_coding_system (const unsigned char *src, { detect_info.found = CATEGORY_MASK_RAW_TEXT; id = CODING_SYSTEM_ID (Qno_conversion); - val = list1 (make_number (id)); + val = list1 (make_fixnum (id)); } else if (! detect_info.rejected && ! detect_info.found) { detect_info.found = CATEGORY_MASK_ANY; id = coding_categories[coding_category_undecided].id; - val = list1 (make_number (id)); + val = list1 (make_fixnum (id)); } else if (highest) { if (detect_info.found) { detect_info.found = 1 << category; - val = list1 (make_number (this->id)); + val = list1 (make_fixnum (this->id)); } else for (i = 0; i < coding_category_raw_text; i++) @@ -8743,7 +8741,7 @@ detect_coding_system (const unsigned char *src, { detect_info.found = 1 << coding_priorities[i]; id = coding_categories[coding_priorities[i]].id; - val = list1 (make_number (id)); + val = list1 (make_fixnum (id)); break; } } @@ -8760,7 +8758,7 @@ detect_coding_system (const unsigned char *src, found |= 1 << category; id = coding_categories[category].id; if (id >= 0) - val = list1 (make_number (id)); + val = list1 (make_fixnum (id)); } } for (i = coding_category_raw_text - 1; i >= 0; i--) @@ -8769,7 +8767,7 @@ detect_coding_system (const unsigned char *src, if (detect_info.found & (1 << category)) { id = coding_categories[category].id; - val = Fcons (make_number (id), val); + val = Fcons (make_fixnum (id), val); } } detect_info.found |= found; @@ -8785,7 +8783,7 @@ detect_coding_system (const unsigned char *src, this = coding_categories + coding_category_utf_8_sig; else this = coding_categories + coding_category_utf_8_nosig; - val = list1 (make_number (this->id)); + val = list1 (make_fixnum (this->id)); } } else if (base_category == coding_category_utf_16_auto) @@ -8802,13 +8800,13 @@ detect_coding_system (const unsigned char *src, this = coding_categories + coding_category_utf_16_be_nosig; else this = coding_categories + coding_category_utf_16_le_nosig; - val = list1 (make_number (this->id)); + val = list1 (make_fixnum (this->id)); } } else { - detect_info.found = 1 << XINT (CODING_ATTR_CATEGORY (attrs)); - val = list1 (make_number (coding.id)); + detect_info.found = 1 << XFIXNUM (CODING_ATTR_CATEGORY (attrs)); + val = list1 (make_fixnum (coding.id)); } /* Then, detect eol-format if necessary. */ @@ -8850,9 +8848,9 @@ detect_coding_system (const unsigned char *src, enum coding_category category; int this_eol; - id = XINT (XCAR (tail)); + id = XFIXNUM (XCAR (tail)); attrs = CODING_ID_ATTRS (id); - category = XINT (CODING_ATTR_CATEGORY (attrs)); + category = XFIXNUM (CODING_ATTR_CATEGORY (attrs)); eol_type = CODING_ID_EOL_TYPE (id); if (VECTORP (eol_type)) { @@ -8903,7 +8901,7 @@ highest priority. */) ptrdiff_t from_byte, to_byte; validate_region (&start, &end); - from = XINT (start), to = XINT (end); + from = XFIXNUM (start), to = XFIXNUM (end); from_byte = CHAR_TO_BYTE (from); to_byte = CHAR_TO_BYTE (to); @@ -8956,7 +8954,7 @@ char_encodable_p (int c, Lisp_Object attrs) for (tail = CODING_ATTR_CHARSET_LIST (attrs); CONSP (tail); tail = XCDR (tail)) { - charset = CHARSET_FROM_ID (XINT (XCAR (tail))); + charset = CHARSET_FROM_ID (XFIXNUM (XCAR (tail))); if (CHAR_CHARSET_P (c, charset)) break; } @@ -8992,23 +8990,23 @@ DEFUN ("find-coding-systems-region-internal", } else { - CHECK_NUMBER_COERCE_MARKER (start); - CHECK_NUMBER_COERCE_MARKER (end); - if (XINT (start) < BEG || XINT (end) > Z || XINT (start) > XINT (end)) + CHECK_FIXNUM_COERCE_MARKER (start); + CHECK_FIXNUM_COERCE_MARKER (end); + if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qt; - start_byte = CHAR_TO_BYTE (XINT (start)); - end_byte = CHAR_TO_BYTE (XINT (end)); - if (XINT (end) - XINT (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (XFIXNUM (start)); + end_byte = CHAR_TO_BYTE (XFIXNUM (end)); + if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) return Qt; - if (XINT (start) < GPT && XINT (end) > GPT) + if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) { - if ((GPT - XINT (start)) < (XINT (end) - GPT)) - move_gap_both (XINT (start), start_byte); + if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) + move_gap_both (XFIXNUM (start), start_byte); else - move_gap_both (XINT (end), end_byte); + move_gap_both (XFIXNUM (end), end_byte); } } @@ -9127,8 +9125,8 @@ to the string and treated as in `substring'. */) if (NILP (string)) { validate_region (&start, &end); - from = XINT (start); - to = XINT (end); + from = XFIXNUM (start); + to = XFIXNUM (end); if (NILP (BVAR (current_buffer, enable_multibyte_characters)) || (ascii_compatible && (to - from) == (CHAR_TO_BYTE (to) - (CHAR_TO_BYTE (from))))) @@ -9156,8 +9154,8 @@ to the string and treated as in `substring'. */) n = 1; else { - CHECK_NATNUM (count); - n = XINT (count); + CHECK_FIXNAT (count); + n = XFIXNUM (count); } positions = Qnil; @@ -9182,7 +9180,7 @@ to the string and treated as in `substring'. */) && ! char_charset (translate_char (translation_table, c), charset_list, NULL)) { - positions = Fcons (make_number (from), positions); + positions = Fcons (make_fixnum (from), positions); n--; if (n == 0) break; @@ -9246,25 +9244,25 @@ is nil. */) } else { - CHECK_NUMBER_COERCE_MARKER (start); - CHECK_NUMBER_COERCE_MARKER (end); - if (XINT (start) < BEG || XINT (end) > Z || XINT (start) > XINT (end)) + CHECK_FIXNUM_COERCE_MARKER (start); + CHECK_FIXNUM_COERCE_MARKER (end); + if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qnil; - start_byte = CHAR_TO_BYTE (XINT (start)); - end_byte = CHAR_TO_BYTE (XINT (end)); - if (XINT (end) - XINT (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (XFIXNUM (start)); + end_byte = CHAR_TO_BYTE (XFIXNUM (end)); + if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) return Qnil; - if (XINT (start) < GPT && XINT (end) > GPT) + if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) { - if ((GPT - XINT (start)) < (XINT (end) - GPT)) - move_gap_both (XINT (start), start_byte); + if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) + move_gap_both (XFIXNUM (start), start_byte); else - move_gap_both (XINT (end), end_byte); + move_gap_both (XFIXNUM (end), end_byte); } - pos = XINT (start); + pos = XFIXNUM (start); } list = Qnil; @@ -9299,7 +9297,7 @@ is nil. */) { elt = XCDR (XCAR (tail)); if (! char_encodable_p (c, XCAR (elt))) - XSETCDR (elt, Fcons (make_number (pos), XCDR (elt))); + XSETCDR (elt, Fcons (make_fixnum (pos), XCDR (elt))); } if (charset_map_loaded) { @@ -9350,9 +9348,9 @@ code_convert_region (Lisp_Object start, Lisp_Object end, CHECK_BUFFER (dst_object); validate_region (&start, &end); - from = XFASTINT (start); + from = XFIXNAT (start); from_byte = CHAR_TO_BYTE (from); - to = XFASTINT (end); + to = XFIXNAT (end); to_byte = CHAR_TO_BYTE (to); setup_coding_system (coding_system, &coding); @@ -9376,7 +9374,7 @@ code_convert_region (Lisp_Object start, Lisp_Object end, Vlast_coding_system_used = CODING_ID_NAME (coding.id); return (BUFFERP (dst_object) - ? make_number (coding.produced_char) + ? make_fixnum (coding.produced_char) : coding.dst_object); } @@ -9472,7 +9470,7 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system, Vlast_coding_system_used = CODING_ID_NAME (coding.id); return (BUFFERP (dst_object) - ? make_number (coding.produced_char) + ? make_fixnum (coding.produced_char) : coding.dst_object); } @@ -9591,8 +9589,8 @@ Return the corresponding character. */) EMACS_INT ch; int c; - CHECK_NATNUM (code); - ch = XFASTINT (code); + CHECK_FIXNAT (code); + ch = XFIXNAT (code); CHECK_CODING_SYSTEM_GET_SPEC (Vsjis_coding_system, spec); attrs = AREF (spec, 0); @@ -9601,9 +9599,9 @@ Return the corresponding character. */) return code; val = CODING_ATTR_CHARSET_LIST (attrs); - charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_kana = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_kanji = CHARSET_FROM_ID (XINT (XCAR (val))); + charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_kana = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_kanji = CHARSET_FROM_ID (XFIXNUM (XCAR (val))); if (ch <= 0x7F) { @@ -9630,7 +9628,7 @@ Return the corresponding character. */) c = DECODE_CHAR (charset, c); if (c < 0) error ("Invalid code: %"pI"d", ch); - return make_number (c); + return make_fixnum (c); } @@ -9645,7 +9643,7 @@ Return the corresponding code in SJIS. */) unsigned code; CHECK_CHARACTER (ch); - c = XFASTINT (ch); + c = XFIXNAT (ch); CHECK_CODING_SYSTEM_GET_SPEC (Vsjis_coding_system, spec); attrs = AREF (spec, 0); @@ -9659,7 +9657,7 @@ Return the corresponding code in SJIS. */) error ("Can't encode by shift_jis encoding: %c", c); JIS_TO_SJIS (code); - return make_number (code); + return make_fixnum (code); } DEFUN ("decode-big5-char", Fdecode_big5_char, Sdecode_big5_char, 1, 1, 0, @@ -9672,8 +9670,8 @@ Return the corresponding character. */) EMACS_INT ch; int c; - CHECK_NATNUM (code); - ch = XFASTINT (code); + CHECK_FIXNAT (code); + ch = XFIXNAT (code); CHECK_CODING_SYSTEM_GET_SPEC (Vbig5_coding_system, spec); attrs = AREF (spec, 0); @@ -9682,8 +9680,8 @@ Return the corresponding character. */) return code; val = CODING_ATTR_CHARSET_LIST (attrs); - charset_roman = CHARSET_FROM_ID (XINT (XCAR (val))), val = XCDR (val); - charset_big5 = CHARSET_FROM_ID (XINT (XCAR (val))); + charset_roman = CHARSET_FROM_ID (XFIXNUM (XCAR (val))), val = XCDR (val); + charset_big5 = CHARSET_FROM_ID (XFIXNUM (XCAR (val))); if (ch <= 0x7F) { @@ -9703,7 +9701,7 @@ Return the corresponding character. */) c = DECODE_CHAR (charset, c); if (c < 0) error ("Invalid code: %"pI"d", ch); - return make_number (c); + return make_fixnum (c); } DEFUN ("encode-big5-char", Fencode_big5_char, Sencode_big5_char, 1, 1, 0, @@ -9717,7 +9715,7 @@ Return the corresponding character code in Big5. */) unsigned code; CHECK_CHARACTER (ch); - c = XFASTINT (ch); + c = XFIXNAT (ch); CHECK_CODING_SYSTEM_GET_SPEC (Vbig5_coding_system, spec); attrs = AREF (spec, 0); if (ASCII_CHAR_P (c) @@ -9729,7 +9727,7 @@ Return the corresponding character code in Big5. */) if (code == CHARSET_INVALID_CODE (charset)) error ("Can't encode by Big5 encoding: %c", c); - return make_number (code); + return make_fixnum (code); } @@ -9751,7 +9749,7 @@ DEFUN ("set-terminal-coding-system-internal", Fset_terminal_coding_system_intern tset_charset_list (term, (terminal_coding->common_flags & CODING_REQUIRE_ENCODING_MASK ? coding_charset_list (terminal_coding) - : list1 (make_number (charset_ascii)))); + : list1 (make_fixnum (charset_ascii)))); return Qnil; } @@ -9864,19 +9862,19 @@ usage: (find-operation-coding-system OPERATION ARGUMENTS...) */) error ("Too few arguments"); operation = args[0]; if (!SYMBOLP (operation) - || (target_idx = Fget (operation, Qtarget_idx), !NATNUMP (target_idx))) + || (target_idx = Fget (operation, Qtarget_idx), !FIXNATP (target_idx))) error ("Invalid first argument"); - if (nargs <= 1 + XFASTINT (target_idx)) + if (nargs <= 1 + XFIXNAT (target_idx)) error ("Too few arguments for operation `%s'", SDATA (SYMBOL_NAME (operation))); - target = args[XFASTINT (target_idx) + 1]; + target = args[XFIXNAT (target_idx) + 1]; if (!(STRINGP (target) || (EQ (operation, Qinsert_file_contents) && CONSP (target) && STRINGP (XCAR (target)) && BUFFERP (XCDR (target))) || (EQ (operation, Qopen_network_stream) - && (INTEGERP (target) || EQ (target, Qt))))) + && (FIXNUMP (target) || EQ (target, Qt))))) error ("Invalid argument %"pI"d of operation `%s'", - XFASTINT (target_idx) + 1, SDATA (SYMBOL_NAME (operation))); + XFIXNAT (target_idx) + 1, SDATA (SYMBOL_NAME (operation))); if (CONSP (target)) target = XCAR (target); @@ -9898,7 +9896,7 @@ usage: (find-operation-coding-system OPERATION ARGUMENTS...) */) && ((STRINGP (target) && STRINGP (XCAR (elt)) && fast_string_match (XCAR (elt), target) >= 0) - || (INTEGERP (target) && EQ (target, XCAR (elt))))) + || (FIXNUMP (target) && EQ (target, XCAR (elt))))) { val = XCDR (elt); /* Here, if VAL is both a valid coding system and a valid @@ -9948,7 +9946,7 @@ usage: (set-coding-system-priority &rest coding-systems) */) CHECK_CODING_SYSTEM_GET_SPEC (args[i], spec); attrs = AREF (spec, 0); - category = XINT (CODING_ATTR_CATEGORY (attrs)); + category = XFIXNUM (CODING_ATTR_CATEGORY (attrs)); if (changed[category]) /* Ignore this coding system because a coding system of the same category already had a higher priority. */ @@ -10043,36 +10041,28 @@ DEFUN ("define-coding-system-internal", Fdefine_coding_system_internal, usage: (define-coding-system-internal ...) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object name; - Lisp_Object spec_vec; /* [ ATTRS ALIASE EOL_TYPE ] */ - Lisp_Object attrs; /* Vector of attributes. */ - Lisp_Object eol_type; - Lisp_Object aliases; - Lisp_Object coding_type, charset_list, safe_charsets; enum coding_category category; - Lisp_Object tail, val; int max_charset_id = 0; - int i; if (nargs < coding_arg_max) goto short_args; - attrs = Fmake_vector (make_number (coding_attr_last_index), Qnil); + Lisp_Object attrs = make_nil_vector (coding_attr_last_index); - name = args[coding_arg_name]; + Lisp_Object name = args[coding_arg_name]; CHECK_SYMBOL (name); ASET (attrs, coding_attr_base_name, name); - val = args[coding_arg_mnemonic]; + Lisp_Object val = args[coding_arg_mnemonic]; if (! STRINGP (val)) CHECK_CHARACTER (val); ASET (attrs, coding_attr_mnemonic, val); - coding_type = args[coding_arg_coding_type]; + Lisp_Object coding_type = args[coding_arg_coding_type]; CHECK_SYMBOL (coding_type); ASET (attrs, coding_attr_type, coding_type); - charset_list = args[coding_arg_charset_list]; + Lisp_Object charset_list = args[coding_arg_charset_list]; if (SYMBOLP (charset_list)) { if (EQ (charset_list, Qiso_2022)) @@ -10087,18 +10077,18 @@ usage: (define-coding-system-internal ...) */) error ("Invalid charset-list"); charset_list = Vemacs_mule_charset_list; } - for (tail = charset_list; CONSP (tail); tail = XCDR (tail)) + for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail)) { - if (! RANGED_INTEGERP (0, XCAR (tail), INT_MAX - 1)) + if (! RANGED_FIXNUMP (0, XCAR (tail), INT_MAX - 1)) error ("Invalid charset-list"); - if (max_charset_id < XFASTINT (XCAR (tail))) - max_charset_id = XFASTINT (XCAR (tail)); + if (max_charset_id < XFIXNAT (XCAR (tail))) + max_charset_id = XFIXNAT (XCAR (tail)); } } else { charset_list = Fcopy_sequence (charset_list); - for (tail = charset_list; CONSP (tail); tail = XCDR (tail)) + for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail)) { struct charset *charset; @@ -10112,17 +10102,17 @@ usage: (define-coding-system-internal ...) */) error ("Can't handle charset `%s'", SDATA (SYMBOL_NAME (CHARSET_NAME (charset)))); - XSETCAR (tail, make_number (charset->id)); + XSETCAR (tail, make_fixnum (charset->id)); if (max_charset_id < charset->id) max_charset_id = charset->id; } } ASET (attrs, coding_attr_charset_list, charset_list); - safe_charsets = make_uninit_string (max_charset_id + 1); + Lisp_Object safe_charsets = make_uninit_string (max_charset_id + 1); memset (SDATA (safe_charsets), 255, max_charset_id + 1); - for (tail = charset_list; CONSP (tail); tail = XCDR (tail)) - SSET (safe_charsets, XFASTINT (XCAR (tail)), 0); + for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail)) + SSET (safe_charsets, XFIXNAT (XCAR (tail)), 0); ASET (attrs, coding_attr_safe_charsets, safe_charsets); ASET (attrs, coding_attr_ascii_compat, args[coding_arg_ascii_compatible_p]); @@ -10147,7 +10137,7 @@ usage: (define-coding-system-internal ...) */) val = args[coding_arg_default_char]; if (NILP (val)) - ASET (attrs, coding_attr_default_char, make_number (' ')); + ASET (attrs, coding_attr_default_char, make_fixnum (' ')); else { CHECK_CHARACTER (val); @@ -10175,18 +10165,18 @@ usage: (define-coding-system-internal ...) */) If Nth element is a list of charset IDs, N is the first byte of one of them. The list is sorted by dimensions of the charsets. A charset of smaller dimension comes first. */ - val = Fmake_vector (make_number (256), Qnil); + val = make_nil_vector (256); - for (tail = charset_list; CONSP (tail); tail = XCDR (tail)) + for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail)) { - struct charset *charset = CHARSET_FROM_ID (XFASTINT (XCAR (tail))); + struct charset *charset = CHARSET_FROM_ID (XFIXNAT (XCAR (tail))); int dim = CHARSET_DIMENSION (charset); int idx = (dim - 1) * 4; if (CHARSET_ASCII_COMPATIBLE_P (charset)) ASET (attrs, coding_attr_ascii_compat, Qt); - for (i = charset->code_space[idx]; + for (int i = charset->code_space[idx]; i <= charset->code_space[idx + 1]; i++) { Lisp_Object tmp, tmp2; @@ -10195,9 +10185,9 @@ usage: (define-coding-system-internal ...) */) tmp = AREF (val, i); if (NILP (tmp)) tmp = XCAR (tail); - else if (NUMBERP (tmp)) + else if (FIXNATP (tmp)) { - dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFASTINT (tmp))); + dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFIXNAT (tmp))); if (dim < dim2) tmp = list2 (XCAR (tail), tmp); else @@ -10207,7 +10197,7 @@ usage: (define-coding-system-internal ...) */) { for (tmp2 = tmp; CONSP (tmp2); tmp2 = XCDR (tmp2)) { - dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFASTINT (XCAR (tmp2)))); + dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFIXNAT (XCAR (tmp2)))); if (dim < dim2) break; } @@ -10245,33 +10235,27 @@ usage: (define-coding-system-internal ...) */) ASET (attrs, coding_attr_ccl_encoder, val); val = args[coding_arg_ccl_valids]; - valids = Fmake_string (make_number (256), make_number (0)); - for (tail = val; CONSP (tail); tail = XCDR (tail)) + valids = Fmake_string (make_fixnum (256), make_fixnum (0), Qnil); + for (Lisp_Object tail = val; CONSP (tail); tail = XCDR (tail)) { int from, to; val = XCAR (tail); - if (INTEGERP (val)) + if (FIXNUMP (val)) { - if (! (0 <= XINT (val) && XINT (val) <= 255)) - args_out_of_range_3 (val, make_number (0), make_number (255)); - from = to = XINT (val); + if (! (0 <= XFIXNUM (val) && XFIXNUM (val) <= 255)) + args_out_of_range_3 (val, make_fixnum (0), make_fixnum (255)); + from = to = XFIXNUM (val); } else { CHECK_CONS (val); - CHECK_NATNUM_CAR (val); - CHECK_NUMBER_CDR (val); - if (XINT (XCAR (val)) > 255) - args_out_of_range_3 (XCAR (val), - make_number (0), make_number (255)); - from = XINT (XCAR (val)); - if (! (from <= XINT (XCDR (val)) && XINT (XCDR (val)) <= 255)) - args_out_of_range_3 (XCDR (val), - XCAR (val), make_number (255)); - to = XINT (XCDR (val)); + CHECK_RANGED_INTEGER (XCAR (val), 0, 255); + from = XFIXNUM (XCAR (val)); + CHECK_RANGED_INTEGER (XCDR (val), from, 255); + to = XFIXNUM (XCDR (val)); } - for (i = from; i <= to; i++) + for (int i = from; i <= to; i++) SSET (valids, i, 1); } ASET (attrs, coding_attr_ccl_valids, valids); @@ -10325,7 +10309,7 @@ usage: (define-coding-system-internal ...) */) initial = Fcopy_sequence (args[coding_arg_iso2022_initial]); CHECK_VECTOR (initial); - for (i = 0; i < 4; i++) + for (int i = 0; i < 4; i++) { val = AREF (initial, i); if (! NILP (val)) @@ -10333,41 +10317,37 @@ usage: (define-coding-system-internal ...) */) struct charset *charset; CHECK_CHARSET_GET_CHARSET (val, charset); - ASET (initial, i, make_number (CHARSET_ID (charset))); + ASET (initial, i, make_fixnum (CHARSET_ID (charset))); if (i == 0 && CHARSET_ASCII_COMPATIBLE_P (charset)) ASET (attrs, coding_attr_ascii_compat, Qt); } else - ASET (initial, i, make_number (-1)); + ASET (initial, i, make_fixnum (-1)); } reg_usage = args[coding_arg_iso2022_reg_usage]; CHECK_CONS (reg_usage); - CHECK_NUMBER_CAR (reg_usage); - CHECK_NUMBER_CDR (reg_usage); + CHECK_FIXNUM (XCAR (reg_usage)); + CHECK_FIXNUM (XCDR (reg_usage)); request = Fcopy_sequence (args[coding_arg_iso2022_request]); - for (tail = request; CONSP (tail); tail = XCDR (tail)) + for (Lisp_Object tail = request; CONSP (tail); tail = XCDR (tail)) { int id; - Lisp_Object tmp1; val = XCAR (tail); CHECK_CONS (val); - tmp1 = XCAR (val); - CHECK_CHARSET_GET_ID (tmp1, id); - CHECK_NATNUM_CDR (val); - if (XINT (XCDR (val)) >= 4) - error ("Invalid graphic register number: %"pI"d", XINT (XCDR (val))); - XSETCAR (val, make_number (id)); + CHECK_CHARSET_GET_ID (XCAR (val), id); + CHECK_RANGED_INTEGER (XCDR (val), 0, 3); + XSETCAR (val, make_fixnum (id)); } flags = args[coding_arg_iso2022_flags]; - CHECK_NATNUM (flags); - i = XINT (flags) & INT_MAX; + CHECK_FIXNAT (flags); + int i = XFIXNUM (flags) & INT_MAX; if (EQ (args[coding_arg_charset_list], Qiso_2022)) i |= CODING_ISO_FLAG_FULL_SUPPORT; - flags = make_number (i); + flags = make_fixnum (i); ASET (attrs, coding_attr_iso_initial, initial); ASET (attrs, coding_attr_iso_usage, reg_usage); @@ -10384,7 +10364,7 @@ usage: (define-coding-system-internal ...) */) : coding_category_iso_7_tight); else { - int id = XINT (AREF (initial, 1)); + int id = XFIXNUM (AREF (initial, 1)); category = (((i & CODING_ISO_FLAG_LOCKING_SHIFT) || EQ (args[coding_arg_charset_list], Qiso_2022) @@ -10410,11 +10390,11 @@ usage: (define-coding-system-internal ...) */) struct charset *charset; - if (XINT (Flength (charset_list)) != 3 - && XINT (Flength (charset_list)) != 4) + if (XFIXNUM (Flength (charset_list)) != 3 + && XFIXNUM (Flength (charset_list)) != 4) error ("There should be three or four charsets"); - charset = CHARSET_FROM_ID (XINT (XCAR (charset_list))); + charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list))); if (CHARSET_DIMENSION (charset) != 1) error ("Dimension of charset %s is not one", SDATA (SYMBOL_NAME (CHARSET_NAME (charset)))); @@ -10422,13 +10402,13 @@ usage: (define-coding-system-internal ...) */) ASET (attrs, coding_attr_ascii_compat, Qt); charset_list = XCDR (charset_list); - charset = CHARSET_FROM_ID (XINT (XCAR (charset_list))); + charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list))); if (CHARSET_DIMENSION (charset) != 1) error ("Dimension of charset %s is not one", SDATA (SYMBOL_NAME (CHARSET_NAME (charset)))); charset_list = XCDR (charset_list); - charset = CHARSET_FROM_ID (XINT (XCAR (charset_list))); + charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list))); if (CHARSET_DIMENSION (charset) != 2) error ("Dimension of charset %s is not two", SDATA (SYMBOL_NAME (CHARSET_NAME (charset)))); @@ -10436,7 +10416,7 @@ usage: (define-coding-system-internal ...) */) charset_list = XCDR (charset_list); if (! NILP (charset_list)) { - charset = CHARSET_FROM_ID (XINT (XCAR (charset_list))); + charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list))); if (CHARSET_DIMENSION (charset) != 2) error ("Dimension of charset %s is not two", SDATA (SYMBOL_NAME (CHARSET_NAME (charset)))); @@ -10449,10 +10429,10 @@ usage: (define-coding-system-internal ...) */) { struct charset *charset; - if (XINT (Flength (charset_list)) != 2) + if (XFIXNUM (Flength (charset_list)) != 2) error ("There should be just two charsets"); - charset = CHARSET_FROM_ID (XINT (XCAR (charset_list))); + charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list))); if (CHARSET_DIMENSION (charset) != 1) error ("Dimension of charset %s is not one", SDATA (SYMBOL_NAME (CHARSET_NAME (charset)))); @@ -10460,7 +10440,7 @@ usage: (define-coding-system-internal ...) */) ASET (attrs, coding_attr_ascii_compat, Qt); charset_list = XCDR (charset_list); - charset = CHARSET_FROM_ID (XINT (XCAR (charset_list))); + charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list))); if (CHARSET_DIMENSION (charset) != 2) error ("Dimension of charset %s is not two", SDATA (SYMBOL_NAME (CHARSET_NAME (charset)))); @@ -10513,7 +10493,7 @@ usage: (define-coding-system-internal ...) */) error ("Invalid coding system type: %s", SDATA (SYMBOL_NAME (coding_type))); - ASET (attrs, coding_attr_category, make_number (category)); + ASET (attrs, coding_attr_category, make_fixnum (category)); ASET (attrs, coding_attr_plist, Fcons (QCcategory, Fcons (AREF (Vcoding_category_table, category), @@ -10523,19 +10503,19 @@ usage: (define-coding-system-internal ...) */) Fcons (CODING_ATTR_ASCII_COMPAT (attrs), CODING_ATTR_PLIST (attrs)))); - eol_type = args[coding_arg_eol_type]; + Lisp_Object eol_type = args[coding_arg_eol_type]; if (! NILP (eol_type) && ! EQ (eol_type, Qunix) && ! EQ (eol_type, Qdos) && ! EQ (eol_type, Qmac)) error ("Invalid eol-type"); - aliases = list1 (name); + Lisp_Object aliases = list1 (name); if (NILP (eol_type)) { eol_type = make_subsidiaries (name); - for (i = 0; i < 3; i++) + for (int i = 0; i < 3; i++) { Lisp_Object this_spec, this_name, this_aliases, this_eol_type; @@ -10556,7 +10536,7 @@ usage: (define-coding-system-internal ...) */) } } - spec_vec = make_uninit_vector (3); + Lisp_Object spec_vec = make_uninit_vector (3); ASET (spec_vec, 0, attrs); ASET (spec_vec, 1, aliases); ASET (spec_vec, 2, eol_type); @@ -10568,19 +10548,16 @@ usage: (define-coding-system-internal ...) */) Vcoding_system_alist = Fcons (Fcons (Fsymbol_name (name), Qnil), Vcoding_system_alist); - { - int id = coding_categories[category].id; - - if (id < 0 || EQ (name, CODING_ID_NAME (id))) + int id = coding_categories[category].id; + if (id < 0 || EQ (name, CODING_ID_NAME (id))) setup_coding_system (name, &coding_categories[category]); - } return Qnil; short_args: Fsignal (Qwrong_number_of_arguments, Fcons (intern ("define-coding-system-internal"), - make_number (nargs))); + make_fixnum (nargs))); } @@ -10602,7 +10579,7 @@ DEFUN ("coding-system-put", Fcoding_system_put, Scoding_system_put, else if (EQ (prop, QCdefault_char)) { if (NILP (val)) - val = make_number (' '); + val = make_fixnum (' '); else CHECK_CHARACTER (val); ASET (attrs, coding_attr_default_char, val); @@ -10747,11 +10724,9 @@ coding system whose eol-type is N. */) if (VECTORP (eol_type)) return Fcopy_sequence (eol_type); n = EQ (eol_type, Qunix) ? 0 : EQ (eol_type, Qdos) ? 1 : 2; - return make_number (n); + return make_fixnum (n); } -#endif /* emacs */ - /*** 9. Post-amble ***/ @@ -10795,8 +10770,6 @@ init_coding_once (void) emacs_mule_bytes[EMACS_MULE_LEADING_CODE_PRIVATE_22] = 4; } -#ifdef emacs - void syms_of_coding (void) { @@ -10823,25 +10796,25 @@ syms_of_coding (void) Fset (Qcoding_system_history, Qnil); /* Target FILENAME is the first argument. */ - Fput (Qinsert_file_contents, Qtarget_idx, make_number (0)); + Fput (Qinsert_file_contents, Qtarget_idx, make_fixnum (0)); /* Target FILENAME is the third argument. */ - Fput (Qwrite_region, Qtarget_idx, make_number (2)); + Fput (Qwrite_region, Qtarget_idx, make_fixnum (2)); DEFSYM (Qcall_process, "call-process"); /* Target PROGRAM is the first argument. */ - Fput (Qcall_process, Qtarget_idx, make_number (0)); + Fput (Qcall_process, Qtarget_idx, make_fixnum (0)); DEFSYM (Qcall_process_region, "call-process-region"); /* Target PROGRAM is the third argument. */ - Fput (Qcall_process_region, Qtarget_idx, make_number (2)); + Fput (Qcall_process_region, Qtarget_idx, make_fixnum (2)); DEFSYM (Qstart_process, "start-process"); /* Target PROGRAM is the third argument. */ - Fput (Qstart_process, Qtarget_idx, make_number (2)); + Fput (Qstart_process, Qtarget_idx, make_fixnum (2)); DEFSYM (Qopen_network_stream, "open-network-stream"); /* Target SERVICE is the fourth argument. */ - Fput (Qopen_network_stream, Qtarget_idx, make_number (3)); + Fput (Qopen_network_stream, Qtarget_idx, make_fixnum (3)); DEFSYM (Qunix, "unix"); DEFSYM (Qdos, "dos"); @@ -10855,6 +10828,7 @@ syms_of_coding (void) DEFSYM (Qiso_2022, "iso-2022"); DEFSYM (Qutf_8, "utf-8"); + DEFSYM (Qutf_8_unix, "utf-8-unix"); DEFSYM (Qutf_8_emacs, "utf-8-emacs"); #if defined (WINDOWSNT) || defined (CYGWIN) @@ -10879,7 +10853,7 @@ syms_of_coding (void) build_pure_c_string ("Invalid coding system")); DEFSYM (Qtranslation_table, "translation-table"); - Fput (Qtranslation_table, Qchar_table_extra_slots, make_number (2)); + Fput (Qtranslation_table, Qchar_table_extra_slots, make_fixnum (2)); DEFSYM (Qtranslation_table_id, "translation-table-id"); /* Coding system emacs-mule and raw-text are for converting only @@ -10895,8 +10869,7 @@ syms_of_coding (void) DEFSYM (QCpre_write_conversion, ":pre-write-conversion"); DEFSYM (QCascii_compatible_p, ":ascii-compatible-p"); - Vcoding_category_table - = Fmake_vector (make_number (coding_category_max), Qnil); + Vcoding_category_table = make_nil_vector (coding_category_max); staticpro (&Vcoding_category_table); /* Followings are target of code detection. */ ASET (Vcoding_category_table, coding_category_iso_7, @@ -11200,7 +11173,7 @@ a coding system of ISO 2022 variant which has a flag `accept-latin-extra-code' t (e.g. iso-latin-1) on reading a file or reading output of a subprocess. Only 128th through 159th elements have a meaning. */); - Vlatin_extra_code_table = Fmake_vector (make_number (256), Qnil); + Vlatin_extra_code_table = make_nil_vector (256); DEFVAR_LISP ("select-safe-coding-system-function", Vselect_safe_coding_system_function, @@ -11289,13 +11262,13 @@ internal character representation. */); QCname, args[coding_arg_name] = Qno_conversion, QCmnemonic, - args[coding_arg_mnemonic] = make_number ('='), + args[coding_arg_mnemonic] = make_fixnum ('='), intern_c_string (":coding-type"), args[coding_arg_coding_type] = Qraw_text, QCascii_compatible_p, args[coding_arg_ascii_compatible_p] = Qt, QCdefault_char, - args[coding_arg_default_char] = make_number (0), + args[coding_arg_default_char] = make_fixnum (0), intern_c_string (":for-unibyte"), args[coding_arg_for_unibyte] = Qt, intern_c_string (":docstring"), @@ -11312,7 +11285,7 @@ internal character representation. */); Fdefine_coding_system_internal (coding_arg_max, args); plist[1] = args[coding_arg_name] = Qundecided; - plist[3] = args[coding_arg_mnemonic] = make_number ('-'); + plist[3] = args[coding_arg_mnemonic] = make_fixnum ('-'); plist[5] = args[coding_arg_coding_type] = Qundecided; /* This is already set. plist[7] = args[coding_arg_ascii_compatible_p] = Qt; */ @@ -11323,8 +11296,8 @@ internal character representation. */); "automatic conversion on decoding."); plist[15] = args[coding_arg_eol_type] = Qnil; args[coding_arg_plist] = CALLMANY (Flist, plist); - args[coding_arg_undecided_inhibit_null_byte_detection] = make_number (0); - args[coding_arg_undecided_inhibit_iso_escape_detection] = make_number (0); + args[coding_arg_undecided_inhibit_null_byte_detection] = make_fixnum (0); + args[coding_arg_undecided_inhibit_iso_escape_detection] = make_fixnum (0); Fdefine_coding_system_internal (coding_arg_undecided_max, args); setup_coding_system (Qno_conversion, &safe_terminal_coding); @@ -11339,4 +11312,3 @@ internal character representation. */); #endif staticpro (&system_eol_type); } -#endif /* emacs */ diff --git a/src/coding.h b/src/coding.h index 57fd196af32..337ec46315e 100644 --- a/src/coding.h +++ b/src/coding.h @@ -676,21 +676,10 @@ struct coding_system #define UTF_16_LOW_SURROGATE_P(val) \ (((val) & 0xFC00) == 0xDC00) -/* Return the Unicode code point for the given UTF-16 surrogates. */ - -INLINE int -surrogates_to_codepoint (int low, int high) -{ - eassert (0 <= low && low <= 0xFFFF); - eassert (0 <= high && high <= 0xFFFF); - eassert (UTF_16_LOW_SURROGATE_P (low)); - eassert (UTF_16_HIGH_SURROGATE_P (high)); - return 0x10000 + (low - 0xDC00) + ((high - 0xD800) * 0x400); -} - /* Extern declarations. */ extern Lisp_Object code_conversion_save (bool, bool); extern bool encode_coding_utf_8 (struct coding_system *); +extern bool utf8_string_p (Lisp_Object); extern void setup_coding_system (Lisp_Object, struct coding_system *); extern Lisp_Object coding_charset_list (struct coding_system *); extern Lisp_Object coding_system_charset_list (Lisp_Object); @@ -713,6 +702,8 @@ extern void decode_coding_object (struct coding_system *, extern void encode_coding_object (struct coding_system *, Lisp_Object, ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, Lisp_Object); +/* Defined in this file. */ +INLINE int surrogates_to_codepoint (int, int); #if defined (WINDOWSNT) || defined (CYGWIN) @@ -757,17 +748,24 @@ extern Lisp_Object from_unicode_buffer (const wchar_t *wstr); } while (false) -extern Lisp_Object preferred_coding_system (void); +/* Return the Unicode code point for the given UTF-16 surrogates. */ +INLINE int +surrogates_to_codepoint (int low, int high) +{ + eassert (0 <= low && low <= 0xFFFF); + eassert (0 <= high && high <= 0xFFFF); + eassert (UTF_16_LOW_SURROGATE_P (low)); + eassert (UTF_16_HIGH_SURROGATE_P (high)); + return 0x10000 + (low - 0xDC00) + ((high - 0xD800) * 0x400); +} -#ifdef emacs +extern Lisp_Object preferred_coding_system (void); /* Coding system to be used to encode text for terminal display when terminal coding system is nil. */ extern struct coding_system safe_terminal_coding; -#endif - extern char emacs_mule_bytes[256]; INLINE_HEADER_END diff --git a/src/composite.c b/src/composite.c index ec533a6969b..cd8364a2936 100644 --- a/src/composite.c +++ b/src/composite.c @@ -193,12 +193,12 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, goto invalid_composition; id = XCAR (prop); - if (INTEGERP (id)) + if (FIXNUMP (id)) { /* PROP should be Form-B. */ - if (XINT (id) < 0 || XINT (id) >= n_compositions) + if (XFIXNUM (id) < 0 || XFIXNUM (id) >= n_compositions) goto invalid_composition; - return XINT (id); + return XFIXNUM (id); } /* PROP should be Form-A. @@ -206,7 +206,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, if (!CONSP (id)) goto invalid_composition; length = XCAR (id); - if (!INTEGERP (length) || XINT (length) != nchars) + if (!FIXNUMP (length) || XFIXNUM (length) != nchars) goto invalid_composition; components = XCDR (id); @@ -215,8 +215,8 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, by consulting composition_hash_table. The key for this table is COMPONENTS (converted to a vector COMPONENTS-VEC) or, if it is nil, vector of characters in the composition range. */ - if (INTEGERP (components)) - key = Fmake_vector (make_number (1), components); + if (FIXNUMP (components)) + key = make_vector (1, components); else if (STRINGP (components) || CONSP (components)) key = Fvconcat (1, &components); else if (VECTORP (components)) @@ -228,13 +228,13 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, for (i = 0; i < nchars; i++) { FETCH_STRING_CHAR_ADVANCE (ch, string, charpos, bytepos); - ASET (key, i, make_number (ch)); + ASET (key, i, make_fixnum (ch)); } else for (i = 0; i < nchars; i++) { FETCH_CHAR_ADVANCE (ch, charpos, bytepos); - ASET (key, i, make_number (ch)); + ASET (key, i, make_fixnum (ch)); } } else @@ -250,8 +250,8 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, key = HASH_KEY (hash_table, hash_index); id = HASH_VALUE (hash_table, hash_index); XSETCAR (prop, id); - XSETCDR (prop, Fcons (make_number (nchars), Fcons (key, XCDR (prop)))); - return XINT (id); + XSETCDR (prop, Fcons (make_fixnum (nchars), Fcons (key, XCDR (prop)))); + return XFIXNUM (id); } /* This composition is a new one. We must register it. */ @@ -289,7 +289,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, composition rule). */ for (i = 0; i < len; i++) { - if (!INTEGERP (key_contents[i])) + if (!FIXNUMP (key_contents[i])) goto invalid_composition; } } @@ -298,14 +298,14 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, the cons cell of PROP because it is not shared. */ XSETFASTINT (id, n_compositions); XSETCAR (prop, id); - XSETCDR (prop, Fcons (make_number (nchars), Fcons (key, XCDR (prop)))); + XSETCDR (prop, Fcons (make_fixnum (nchars), Fcons (key, XCDR (prop)))); /* Register the composition in composition_hash_table. */ hash_index = hash_put (hash_table, key, id, hash_code); method = (NILP (components) ? COMPOSITION_RELATIVE - : ((INTEGERP (components) || STRINGP (components)) + : ((FIXNUMP (components) || STRINGP (components)) ? COMPOSITION_WITH_ALTCHARS : COMPOSITION_WITH_RULE_ALTCHARS)); @@ -332,7 +332,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, for (i = 0; i < glyph_len; i++) { int this_width; - ch = XINT (key_contents[i]); + ch = XFIXNUM (key_contents[i]); /* TAB in a composition means display glyphs with padding space on the left or right. */ this_width = (ch == '\t' ? 1 : CHARACTER_WIDTH (ch)); @@ -345,7 +345,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, /* Rule-base composition. */ double leftmost = 0.0, rightmost; - ch = XINT (key_contents[0]); + ch = XFIXNUM (key_contents[0]); rightmost = ch != '\t' ? CHARACTER_WIDTH (ch) : 1; for (i = 1; i < glyph_len; i += 2) @@ -354,8 +354,8 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, int this_width; double this_left; - rule = XINT (key_contents[i]); - ch = XINT (key_contents[i + 1]); + rule = XFIXNUM (key_contents[i]); + ch = XFIXNUM (key_contents[i + 1]); this_width = ch != '\t' ? CHARACTER_WIDTH (ch) : 1; /* A composition rule is specified by an integer value @@ -431,9 +431,9 @@ find_composition (ptrdiff_t pos, ptrdiff_t limit, if (limit > pos) /* search forward */ { - val = Fnext_single_property_change (make_number (pos), Qcomposition, - object, make_number (limit)); - pos = XINT (val); + val = Fnext_single_property_change (make_fixnum (pos), Qcomposition, + object, make_fixnum (limit)); + pos = XFIXNUM (val); if (pos == limit) return 0; } @@ -442,9 +442,9 @@ find_composition (ptrdiff_t pos, ptrdiff_t limit, if (get_property_and_range (pos - 1, Qcomposition, prop, start, end, object)) return 1; - val = Fprevious_single_property_change (make_number (pos), Qcomposition, - object, make_number (limit)); - pos = XINT (val); + val = Fprevious_single_property_change (make_fixnum (pos), Qcomposition, + object, make_fixnum (limit)); + pos = XFIXNUM (val); if (pos == limit) return 0; pos--; @@ -474,7 +474,7 @@ run_composition_function (ptrdiff_t from, ptrdiff_t to, Lisp_Object prop) && !composition_valid_p (start, end, prop)) to = end; if (!NILP (Ffboundp (func))) - call2 (func, make_number (from), make_number (to)); + call2 (func, make_fixnum (from), make_fixnum (to)); } /* Make invalid compositions adjacent to or inside FROM and TO valid. @@ -519,7 +519,7 @@ update_compositions (ptrdiff_t from, ptrdiff_t to, int check_mask) if (end > to) max_pos = end; if (from < end) - Fput_text_property (make_number (from), make_number (end), + Fput_text_property (make_fixnum (from), make_fixnum (end), Qcomposition, Fcons (XCAR (prop), XCDR (prop)), Qnil); run_composition_function (start, end, prop); @@ -560,7 +560,7 @@ update_compositions (ptrdiff_t from, ptrdiff_t to, int check_mask) the former to the copy of it. */ if (to < end) { - Fput_text_property (make_number (start), make_number (to), + Fput_text_property (make_fixnum (start), make_fixnum (to), Qcomposition, Fcons (XCAR (prop), XCDR (prop)), Qnil); max_pos = end; @@ -582,8 +582,8 @@ update_compositions (ptrdiff_t from, ptrdiff_t to, int check_mask) specbind (Qinhibit_read_only, Qt); specbind (Qinhibit_modification_hooks, Qt); specbind (Qinhibit_point_motion_hooks, Qt); - Fremove_list_of_text_properties (make_number (min_pos), - make_number (max_pos), + Fremove_list_of_text_properties (make_fixnum (min_pos), + make_fixnum (max_pos), list1 (Qauto_composed), Qnil); unbind_to (count, Qnil); } @@ -625,9 +625,9 @@ compose_text (ptrdiff_t start, ptrdiff_t end, Lisp_Object components, { Lisp_Object prop; - prop = Fcons (Fcons (make_number (end - start), components), + prop = Fcons (Fcons (make_fixnum (end - start), components), modification_func); - Fput_text_property (make_number (start), make_number (end), + Fput_text_property (make_fixnum (start), make_fixnum (end), Qcomposition, prop, string); } @@ -654,27 +654,22 @@ Lisp_Object composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len) { struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); - EMACS_UINT hash; - Lisp_Object header, copy; - ptrdiff_t i; - - header = LGSTRING_HEADER (gstring); - hash = h->test.hashfn (&h->test, header); + Lisp_Object header = LGSTRING_HEADER (gstring); + EMACS_UINT hash = h->test.hashfn (&h->test, header); if (len < 0) { - ptrdiff_t j, glyph_len = LGSTRING_GLYPH_LEN (gstring); - for (j = 0; j < glyph_len; j++) - if (NILP (LGSTRING_GLYPH (gstring, j))) + ptrdiff_t glyph_len = LGSTRING_GLYPH_LEN (gstring); + for (len = 0; len < glyph_len; len++) + if (NILP (LGSTRING_GLYPH (gstring, len))) break; - len = j; } - copy = Fmake_vector (make_number (len + 2), Qnil); + Lisp_Object copy = make_nil_vector (len + 2); LGSTRING_SET_HEADER (copy, Fcopy_sequence (header)); - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) LGSTRING_SET_GLYPH (copy, i, Fcopy_sequence (LGSTRING_GLYPH (gstring, i))); - i = hash_put (h, LGSTRING_HEADER (copy), copy, hash); - LGSTRING_SET_ID (copy, make_number (i)); + ptrdiff_t id = hash_put (h, LGSTRING_HEADER (copy), copy, hash); + LGSTRING_SET_ID (copy, make_fixnum (id)); return copy; } @@ -692,7 +687,7 @@ DEFUN ("clear-composition-cache", Fclear_composition_cache, Clear composition cache. */) (void) { - Lisp_Object args[] = {QCtest, Qequal, QCsize, make_number (311)}; + Lisp_Object args[] = {QCtest, Qequal, QCsize, make_fixnum (311)}; gstring_hash_table = CALLMANY (Fmake_hash_table, args); /* Fixme: We call Fclear_face_cache to force complete re-building of display glyphs. But, it may be better to call this function from @@ -716,9 +711,9 @@ composition_gstring_p (Lisp_Object gstring) && ! CODING_SYSTEM_P (LGSTRING_FONT (gstring)))) return 0; for (i = 1; i < ASIZE (LGSTRING_HEADER (gstring)); i++) - if (! NATNUMP (AREF (LGSTRING_HEADER (gstring), i))) + if (! FIXNATP (AREF (LGSTRING_HEADER (gstring), i))) return 0; - if (! NILP (LGSTRING_ID (gstring)) && ! NATNUMP (LGSTRING_ID (gstring))) + if (! NILP (LGSTRING_ID (gstring)) && ! FIXNATP (LGSTRING_ID (gstring))) return 0; for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++) { @@ -801,7 +796,7 @@ fill_gstring_header (Lisp_Object header, ptrdiff_t from, ptrdiff_t from_byte, if (VECTORP (header)) { if (ASIZE (header) != len + 1) - args_out_of_range (header, make_number (len + 1)); + args_out_of_range (header, make_fixnum (len + 1)); } else { @@ -820,7 +815,7 @@ fill_gstring_header (Lisp_Object header, ptrdiff_t from, ptrdiff_t from_byte, FETCH_CHAR_ADVANCE_NO_CHECK (c, from, from_byte); else FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, from, from_byte); - ASET (header, i + 1, make_number (c)); + ASET (header, i + 1, make_fixnum (c)); } return header; } @@ -836,7 +831,7 @@ fill_gstring_body (Lisp_Object gstring) for (i = 0; i < len; i++) { Lisp_Object g = LGSTRING_GLYPH (gstring, i); - int c = XFASTINT (AREF (header, i + 1)); + int c = XFIXNAT (AREF (header, i + 1)); if (NILP (g)) { @@ -852,7 +847,7 @@ fill_gstring_body (Lisp_Object gstring) } else { - int width = XFASTINT (CHAR_TABLE_REF (Vchar_width_table, c)); + int width = XFIXNAT (CHAR_TABLE_REF (Vchar_width_table, c)); LGLYPH_SET_CODE (g, c); LGLYPH_SET_LBEARING (g, 0); @@ -881,7 +876,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos, Lisp_Object string) { ptrdiff_t count = SPECPDL_INDEX (); - Lisp_Object pos = make_number (charpos); + Lisp_Object pos = make_fixnum (charpos); ptrdiff_t to; ptrdiff_t pt = PT, pt_byte = PT_BYTE; Lisp_Object re, font_object, lgstring; @@ -917,7 +912,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos, return unbind_to (count, Qnil); } #endif - lgstring = Fcomposition_get_gstring (pos, make_number (to), font_object, + lgstring = Fcomposition_get_gstring (pos, make_fixnum (to), font_object, string); if (NILP (LGSTRING_ID (lgstring))) { @@ -926,7 +921,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos, record_unwind_protect (restore_point_unwind, build_marker (current_buffer, pt, pt_byte)); lgstring = safe_call (6, Vauto_composition_function, AREF (rule, 2), - pos, make_number (to), font_object, string); + pos, make_fixnum (to), font_object, string); } return unbind_to (count, lgstring); } @@ -941,7 +936,7 @@ char_composable_p (int c) return (c > ' ' && (c == ZERO_WIDTH_NON_JOINER || c == ZERO_WIDTH_JOINER || (val = CHAR_TABLE_REF (Vunicode_category_table, c), - (INTEGERP (val) && (XINT (val) <= UNICODE_CATEGORY_So))))); + (FIXNUMP (val) && (XFIXNUM (val) <= UNICODE_CATEGORY_So))))); } /* Update cmp_it->stop_pos to the next position after CHARPOS (and @@ -1030,11 +1025,11 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, { Lisp_Object elt = XCAR (val); if (VECTORP (elt) && ASIZE (elt) == 3 - && NATNUMP (AREF (elt, 1)) - && charpos - 1 - XFASTINT (AREF (elt, 1)) >= start) + && FIXNATP (AREF (elt, 1)) + && charpos - 1 - XFIXNAT (AREF (elt, 1)) >= start) { cmp_it->rule_idx = ridx; - cmp_it->lookback = XFASTINT (AREF (elt, 1)); + cmp_it->lookback = XFIXNAT (AREF (elt, 1)); cmp_it->stop_pos = charpos - 1 - cmp_it->lookback; cmp_it->ch = c; return; @@ -1081,10 +1076,10 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, { Lisp_Object elt = XCAR (val); if (VECTORP (elt) && ASIZE (elt) == 3 - && NATNUMP (AREF (elt, 1)) - && charpos - XFASTINT (AREF (elt, 1)) > endpos) + && FIXNATP (AREF (elt, 1)) + && charpos - XFIXNAT (AREF (elt, 1)) > endpos) { - ptrdiff_t back = XFASTINT (AREF (elt, 1)); + ptrdiff_t back = XFIXNAT (AREF (elt, 1)); ptrdiff_t cpos = charpos - back, bpos; if (back == 0) @@ -1221,9 +1216,9 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos, { elt = XCAR (val); if (! VECTORP (elt) || ASIZE (elt) != 3 - || ! INTEGERP (AREF (elt, 1))) + || ! FIXNUMP (AREF (elt, 1))) continue; - if (XFASTINT (AREF (elt, 1)) != cmp_it->lookback) + if (XFIXNAT (AREF (elt, 1)) != cmp_it->lookback) goto no_composition; lgstring = autocmp_chars (elt, charpos, bytepos, endpos, w, face, string); @@ -1262,7 +1257,7 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos, goto no_composition; if (NILP (LGSTRING_ID (lgstring))) lgstring = composition_gstring_put_cache (lgstring, -1); - cmp_it->id = XINT (LGSTRING_ID (lgstring)); + cmp_it->id = XFIXNUM (LGSTRING_ID (lgstring)); int i; for (i = 0; i < LGSTRING_GLYPH_LEN (lgstring); i++) if (NILP (LGSTRING_GLYPH (lgstring, i))) @@ -1391,7 +1386,7 @@ composition_update_it (struct composition_it *cmp_it, ptrdiff_t charpos, ptrdiff cmp_it->width = 0; for (i = cmp_it->nchars - 1; i >= 0; i--) { - c = XINT (LGSTRING_CHAR (gstring, from + i)); + c = XFIXNUM (LGSTRING_CHAR (gstring, from + i)); cmp_it->nbytes += CHAR_BYTES (c); cmp_it->width += CHARACTER_WIDTH (c); } @@ -1559,9 +1554,9 @@ find_automatic_composition (ptrdiff_t pos, ptrdiff_t limit, { Lisp_Object elt = XCAR (val); - if (VECTORP (elt) && ASIZE (elt) == 3 && NATNUMP (AREF (elt, 1))) + if (VECTORP (elt) && ASIZE (elt) == 3 && FIXNATP (AREF (elt, 1))) { - EMACS_INT check_pos = cur.pos - XFASTINT (AREF (elt, 1)); + EMACS_INT check_pos = cur.pos - XFIXNAT (AREF (elt, 1)); struct position_record check; if (check_pos < head @@ -1739,8 +1734,8 @@ should be ignored. */) if (NILP (BVAR (current_buffer, enable_multibyte_characters))) error ("Attempt to shape unibyte text"); validate_region (&from, &to); - frompos = XFASTINT (from); - topos = XFASTINT (to); + frompos = XFIXNAT (from); + topos = XFIXNAT (to); frombyte = CHAR_TO_BYTE (frompos); } else @@ -1759,7 +1754,7 @@ should be ignored. */) return gstring; if (LGSTRING_GLYPH_LEN (gstring_work) < topos - frompos) - gstring_work = Fmake_vector (make_number (topos - frompos + 2), Qnil); + gstring_work = make_nil_vector (topos - frompos + 2); LGSTRING_SET_HEADER (gstring_work, header); LGSTRING_SET_ID (gstring_work, Qnil); fill_gstring_body (gstring_work); @@ -1780,12 +1775,12 @@ for the composition. See `compose-region' for more details. */) { validate_region (&start, &end); if (!NILP (components) - && !INTEGERP (components) + && !FIXNUMP (components) && !CONSP (components) && !STRINGP (components)) CHECK_VECTOR (components); - compose_text (XINT (start), XINT (end), components, modification_func, Qnil); + compose_text (XFIXNUM (start), XFIXNUM (end), components, modification_func, Qnil); return Qnil; } @@ -1820,11 +1815,11 @@ See `find-composition' for more details. */) ptrdiff_t start, end, from, to; int id; - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); if (!NILP (limit)) { - CHECK_NUMBER_COERCE_MARKER (limit); - to = min (XINT (limit), ZV); + CHECK_FIXNUM_COERCE_MARKER (limit); + to = min (XFIXNUM (limit), ZV); } else to = -1; @@ -1832,15 +1827,15 @@ See `find-composition' for more details. */) if (!NILP (string)) { CHECK_STRING (string); - if (XINT (pos) < 0 || XINT (pos) > SCHARS (string)) + if (XFIXNUM (pos) < 0 || XFIXNUM (pos) > SCHARS (string)) args_out_of_range (string, pos); } else { - if (XINT (pos) < BEGV || XINT (pos) > ZV) + if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) > ZV) args_out_of_range (Fcurrent_buffer (), pos); } - from = XINT (pos); + from = XFIXNUM (pos); if (!find_composition (from, to, &start, &end, &prop, string)) { @@ -1848,21 +1843,21 @@ See `find-composition' for more details. */) && ! NILP (Vauto_composition_mode) && find_automatic_composition (from, to, &start, &end, &gstring, string)) - return list3 (make_number (start), make_number (end), gstring); + return list3 (make_fixnum (start), make_fixnum (end), gstring); return Qnil; } - if ((end <= XINT (pos) || start > XINT (pos))) + if ((end <= XFIXNUM (pos) || start > XFIXNUM (pos))) { ptrdiff_t s, e; if (find_automatic_composition (from, to, &s, &e, &gstring, string) - && (e <= XINT (pos) ? e > end : s < start)) - return list3 (make_number (s), make_number (e), gstring); + && (e <= XFIXNUM (pos) ? e > end : s < start)) + return list3 (make_fixnum (s), make_fixnum (e), gstring); } if (!composition_valid_p (start, end, prop)) - return list3 (make_number (start), make_number (end), Qnil); + return list3 (make_fixnum (start), make_fixnum (end), Qnil); if (NILP (detail_p)) - return list3 (make_number (start), make_number (end), Qt); + return list3 (make_fixnum (start), make_fixnum (end), Qt); if (composition_registered_p (prop)) id = COMPOSITION_ID (prop); @@ -1884,12 +1879,12 @@ See `find-composition' for more details. */) relative_p = (method == COMPOSITION_WITH_RULE_ALTCHARS ? Qnil : Qt); mod_func = COMPOSITION_MODIFICATION_FUNC (prop); - tail = list4 (components, relative_p, mod_func, make_number (width)); + tail = list4 (components, relative_p, mod_func, make_fixnum (width)); } else tail = Qnil; - return Fcons (make_number (start), Fcons (make_number (end), tail)); + return Fcons (make_fixnum (start), Fcons (make_fixnum (end), tail)); } @@ -1906,7 +1901,7 @@ syms_of_composite (void) created compositions are repeatedly used in an Emacs session, and thus it's not worth to save memory in such a way. So, we make the table not weak. */ - Lisp_Object args[] = {QCtest, Qequal, QCsize, make_number (311)}; + Lisp_Object args[] = {QCtest, Qequal, QCsize, make_fixnum (311)}; composition_hash_table = CALLMANY (Fmake_hash_table, args); staticpro (&composition_hash_table); @@ -1917,9 +1912,9 @@ syms_of_composite (void) staticpro (&gstring_work_headers); gstring_work_headers = make_uninit_vector (8); for (i = 0; i < 8; i++) - ASET (gstring_work_headers, i, Fmake_vector (make_number (i + 2), Qnil)); + ASET (gstring_work_headers, i, make_nil_vector (i + 2)); staticpro (&gstring_work); - gstring_work = Fmake_vector (make_number (10), Qnil); + gstring_work = make_nil_vector (10); /* Text property `composition' should be nonsticky by default. */ Vtext_property_default_nonsticky diff --git a/src/composite.h b/src/composite.h index de138225c01..86751633c27 100644 --- a/src/composite.h +++ b/src/composite.h @@ -59,17 +59,17 @@ enum composition_method { INLINE bool composition_registered_p (Lisp_Object prop) { - return INTEGERP (XCAR (prop)); + return FIXNUMP (XCAR (prop)); } /* Return ID number of the already registered composition. */ -#define COMPOSITION_ID(prop) XINT (XCAR (prop)) +#define COMPOSITION_ID(prop) XFIXNUM (XCAR (prop)) /* Return length of the composition. */ #define COMPOSITION_LENGTH(prop) \ (composition_registered_p (prop) \ - ? XINT (XCAR (XCDR (prop))) \ - : XINT (XCAR (XCAR (prop)))) + ? XFIXNUM (XCAR (XCDR (prop))) \ + : XFIXNUM (XCAR (XCAR (prop)))) /* Return components of the composition. */ #define COMPOSITION_COMPONENTS(prop) \ @@ -86,7 +86,7 @@ composition_registered_p (Lisp_Object prop) /* Return the Nth glyph of composition specified by CMP. CMP is a pointer to `struct composition'. */ #define COMPOSITION_GLYPH(cmp, n) \ - XINT (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \ + XFIXNUM (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \ ->key_and_value) \ ->contents[cmp->hash_index * 2]) \ ->contents[cmp->method == COMPOSITION_WITH_RULE_ALTCHARS \ @@ -96,7 +96,7 @@ composition_registered_p (Lisp_Object prop) rule-base composition specified by CMP. CMP is a pointer to `struct composition'. */ #define COMPOSITION_RULE(cmp, n) \ - XINT (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \ + XFIXNUM (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \ ->key_and_value) \ ->contents[cmp->hash_index * 2]) \ ->contents[(n) * 2 - 1]) @@ -213,7 +213,7 @@ composition_method (Lisp_Object prop) Lisp_Object temp = XCDR (XCAR (prop)); return (NILP (temp) ? COMPOSITION_RELATIVE - : INTEGERP (temp) || STRINGP (temp) + : FIXNUMP (temp) || STRINGP (temp) ? COMPOSITION_WITH_ALTCHARS : COMPOSITION_WITH_RULE_ALTCHARS); } @@ -234,7 +234,7 @@ composition_valid_p (ptrdiff_t start, ptrdiff_t end, Lisp_Object prop) && (NILP (XCDR (XCAR (prop))) || STRINGP (XCDR (XCAR (prop))) || VECTORP (XCDR (XCAR (prop))) - || INTEGERP (XCDR (XCAR (prop))) + || FIXNUMP (XCDR (XCAR (prop))) || CONSP (XCDR (XCAR (prop)))))) && COMPOSITION_LENGTH (prop) == end - start); } @@ -274,41 +274,41 @@ enum lglyph_indices LGLYPH_SIZE }; -#define LGLYPH_NEW() Fmake_vector (make_number (LGLYPH_SIZE), Qnil) -#define LGLYPH_FROM(g) XINT (AREF ((g), LGLYPH_IX_FROM)) -#define LGLYPH_TO(g) XINT (AREF ((g), LGLYPH_IX_TO)) -#define LGLYPH_CHAR(g) XINT (AREF ((g), LGLYPH_IX_CHAR)) +#define LGLYPH_NEW() make_nil_vector (LGLYPH_SIZE) +#define LGLYPH_FROM(g) XFIXNUM (AREF ((g), LGLYPH_IX_FROM)) +#define LGLYPH_TO(g) XFIXNUM (AREF ((g), LGLYPH_IX_TO)) +#define LGLYPH_CHAR(g) XFIXNUM (AREF ((g), LGLYPH_IX_CHAR)) #define LGLYPH_CODE(g) \ (NILP (AREF ((g), LGLYPH_IX_CODE)) \ ? FONT_INVALID_CODE \ : cons_to_unsigned (AREF (g, LGLYPH_IX_CODE), TYPE_MAXIMUM (unsigned))) -#define LGLYPH_WIDTH(g) XINT (AREF ((g), LGLYPH_IX_WIDTH)) -#define LGLYPH_LBEARING(g) XINT (AREF ((g), LGLYPH_IX_LBEARING)) -#define LGLYPH_RBEARING(g) XINT (AREF ((g), LGLYPH_IX_RBEARING)) -#define LGLYPH_ASCENT(g) XINT (AREF ((g), LGLYPH_IX_ASCENT)) -#define LGLYPH_DESCENT(g) XINT (AREF ((g), LGLYPH_IX_DESCENT)) +#define LGLYPH_WIDTH(g) XFIXNUM (AREF ((g), LGLYPH_IX_WIDTH)) +#define LGLYPH_LBEARING(g) XFIXNUM (AREF ((g), LGLYPH_IX_LBEARING)) +#define LGLYPH_RBEARING(g) XFIXNUM (AREF ((g), LGLYPH_IX_RBEARING)) +#define LGLYPH_ASCENT(g) XFIXNUM (AREF ((g), LGLYPH_IX_ASCENT)) +#define LGLYPH_DESCENT(g) XFIXNUM (AREF ((g), LGLYPH_IX_DESCENT)) #define LGLYPH_ADJUSTMENT(g) AREF ((g), LGLYPH_IX_ADJUSTMENT) -#define LGLYPH_SET_FROM(g, val) ASET ((g), LGLYPH_IX_FROM, make_number (val)) -#define LGLYPH_SET_TO(g, val) ASET ((g), LGLYPH_IX_TO, make_number (val)) -#define LGLYPH_SET_CHAR(g, val) ASET ((g), LGLYPH_IX_CHAR, make_number (val)) +#define LGLYPH_SET_FROM(g, val) ASET ((g), LGLYPH_IX_FROM, make_fixnum (val)) +#define LGLYPH_SET_TO(g, val) ASET ((g), LGLYPH_IX_TO, make_fixnum (val)) +#define LGLYPH_SET_CHAR(g, val) ASET ((g), LGLYPH_IX_CHAR, make_fixnum (val)) /* Callers must assure that VAL is not negative! */ #define LGLYPH_SET_CODE(g, val) \ ASET (g, LGLYPH_IX_CODE, \ - val == FONT_INVALID_CODE ? Qnil : INTEGER_TO_CONS (val)) + val == FONT_INVALID_CODE ? Qnil : INT_TO_INTEGER (val)) -#define LGLYPH_SET_WIDTH(g, val) ASET ((g), LGLYPH_IX_WIDTH, make_number (val)) -#define LGLYPH_SET_LBEARING(g, val) ASET ((g), LGLYPH_IX_LBEARING, make_number (val)) -#define LGLYPH_SET_RBEARING(g, val) ASET ((g), LGLYPH_IX_RBEARING, make_number (val)) -#define LGLYPH_SET_ASCENT(g, val) ASET ((g), LGLYPH_IX_ASCENT, make_number (val)) -#define LGLYPH_SET_DESCENT(g, val) ASET ((g), LGLYPH_IX_DESCENT, make_number (val)) +#define LGLYPH_SET_WIDTH(g, val) ASET ((g), LGLYPH_IX_WIDTH, make_fixnum (val)) +#define LGLYPH_SET_LBEARING(g, val) ASET ((g), LGLYPH_IX_LBEARING, make_fixnum (val)) +#define LGLYPH_SET_RBEARING(g, val) ASET ((g), LGLYPH_IX_RBEARING, make_fixnum (val)) +#define LGLYPH_SET_ASCENT(g, val) ASET ((g), LGLYPH_IX_ASCENT, make_fixnum (val)) +#define LGLYPH_SET_DESCENT(g, val) ASET ((g), LGLYPH_IX_DESCENT, make_fixnum (val)) #define LGLYPH_SET_ADJUSTMENT(g, val) ASET ((g), LGLYPH_IX_ADJUSTMENT, (val)) #define LGLYPH_XOFF(g) (VECTORP (LGLYPH_ADJUSTMENT (g)) \ - ? XINT (AREF (LGLYPH_ADJUSTMENT (g), 0)) : 0) + ? XFIXNUM (AREF (LGLYPH_ADJUSTMENT (g), 0)) : 0) #define LGLYPH_YOFF(g) (VECTORP (LGLYPH_ADJUSTMENT (g)) \ - ? XINT (AREF (LGLYPH_ADJUSTMENT (g), 1)) : 0) + ? XFIXNUM (AREF (LGLYPH_ADJUSTMENT (g), 1)) : 0) #define LGLYPH_WADJUST(g) (VECTORP (LGLYPH_ADJUSTMENT (g)) \ - ? XINT (AREF (LGLYPH_ADJUSTMENT (g), 2)) : 0) + ? XFIXNUM (AREF (LGLYPH_ADJUSTMENT (g), 2)) : 0) extern Lisp_Object composition_gstring_put_cache (Lisp_Object, ptrdiff_t); extern Lisp_Object composition_gstring_from_id (ptrdiff_t); diff --git a/src/conf_post.h b/src/conf_post.h index 3c87d87ec26..002ef6c65bc 100644 --- a/src/conf_post.h +++ b/src/conf_post.h @@ -20,9 +20,16 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* 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. + example, undefs here are not commented out. */ - To help make dependencies clearer elsewhere, this file typically +/* Disable 'assert' unless enabling checking. Do this early, in + case some misguided implementation depends on NDEBUG in some + include file other than assert.h. */ +#if !defined ENABLE_CHECKING && !defined NDEBUG +# define NDEBUG +#endif + +/* 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 @@ -69,14 +76,7 @@ typedef bool bool_bf; # define __has_attribute_externally_visible GNUC_PREREQ (4, 1, 0) # define __has_attribute_no_address_safety_analysis false # 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) +# define __has_attribute_no_sanitize_undefined GNUC_PREREQ (4, 9, 0) #endif /* Simulate __has_feature on compilers that lack it. It is used only @@ -92,11 +92,6 @@ 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 #if defined emacs && !defined CANNOT_DUMP #define malloc unexec_malloc @@ -220,7 +215,7 @@ extern void _DebPrint (const char *fmt, ...); /* Tell regex.c to use a type compatible with Emacs. */ #define RE_TRANSLATE_TYPE Lisp_Object #define RE_TRANSLATE(TBL, C) char_table_translate (TBL, C) -#define RE_TRANSLATE_P(TBL) (!EQ (TBL, make_number (0))) +#define RE_TRANSLATE_P(TBL) (!EQ (TBL, make_fixnum (0))) #endif /* Tell time_rz.c to use Emacs's getter and setter for TZ. @@ -284,6 +279,7 @@ extern int emacs_setenv_TZ (char const *); #define ATTRIBUTE_FORMAT_PRINTF(string_index, first_to_check) \ ATTRIBUTE_FORMAT ((PRINTF_ARCHETYPE, string_index, first_to_check)) +#define ARG_NONNULL _GL_ARG_NONNULL #define ATTRIBUTE_CONST _GL_ATTRIBUTE_CONST #define ATTRIBUTE_UNUSED _GL_UNUSED @@ -340,12 +336,28 @@ extern int emacs_setenv_TZ (char const *); # define ATTRIBUTE_NO_SANITIZE_ADDRESS #endif -/* gcc -fsanitize=address does not work with vfork in Fedora 25 x86-64. +/* Attribute of functions whose undefined behavior should not be sanitized. */ + +#if __has_attribute (no_sanitize_undefined) +# define ATTRIBUTE_NO_SANITIZE_UNDEFINED __attribute__ ((no_sanitize_undefined)) +#elif __has_attribute (no_sanitize) +# define ATTRIBUTE_NO_SANITIZE_UNDEFINED \ + __attribute__ ((no_sanitize ("undefined"))) +#else +# define ATTRIBUTE_NO_SANITIZE_UNDEFINED +#endif + +/* gcc -fsanitize=address does not work with vfork in Fedora 28 x86-64. See: + https://lists.gnu.org/r/emacs-devel/2017-05/msg00464.html For now, assume that this problem occurs on all platforms. */ #if ADDRESS_SANITIZER && !defined vfork # define vfork fork #endif +#if ! (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__) +# undef PROFILING +#endif + /* Some versions of GNU/Linux define noinline in their headers. */ #ifdef noinline #undef noinline diff --git a/src/data.c b/src/data.c index 571114802a1..1c124740815 100644 --- a/src/data.c +++ b/src/data.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <intprops.h> #include "lisp.h" +#include "bignum.h" #include "puresize.h" #include "character.h" #include "buffer.h" @@ -74,7 +75,7 @@ XKBOARD_OBJFWD (union Lisp_Fwd *a) return &a->u_kboard_objfwd; } static struct Lisp_Intfwd * -XINTFWD (union Lisp_Fwd *a) +XFIXNUMFWD (union Lisp_Fwd *a) { eassert (INTFWDP (a)); return &a->u_intfwd; @@ -132,13 +133,13 @@ set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val) static _Noreturn void wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3) { - Lisp_Object size1 = make_number (bool_vector_size (a1)); - Lisp_Object size2 = make_number (bool_vector_size (a2)); + Lisp_Object size1 = make_fixnum (bool_vector_size (a1)); + Lisp_Object size2 = make_fixnum (bool_vector_size (a2)); if (NILP (a3)) xsignal2 (Qwrong_length_argument, size1, size2); else xsignal3 (Qwrong_length_argument, size1, size2, - make_number (bool_vector_size (a3))); + make_fixnum (bool_vector_size (a3))); } _Noreturn void @@ -221,27 +222,17 @@ for example, (type-of 1) returns `integer'. */) case Lisp_Cons: return Qcons; - case Lisp_Misc: - switch (XMISCTYPE (object)) - { - case Lisp_Misc_Marker: - return Qmarker; - case Lisp_Misc_Overlay: - return Qoverlay; - case Lisp_Misc_Finalizer: - return Qfinalizer; -#ifdef HAVE_MODULES - case Lisp_Misc_User_Ptr: - return Quser_ptr; -#endif - default: - emacs_abort (); - } - case Lisp_Vectorlike: switch (PSEUDOVECTOR_TYPE (XVECTOR (object))) { case PVEC_NORMAL_VECTOR: return Qvector; + case PVEC_BIGNUM: return Qinteger; + case PVEC_MARKER: return Qmarker; + case PVEC_OVERLAY: return Qoverlay; + case PVEC_FINALIZER: return Qfinalizer; +#ifdef HAVE_MODULES + case PVEC_USER_PTR: return Quser_ptr; +#endif case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration; case PVEC_PROCESS: return Qprocess; case PVEC_WINDOW: return Qwindow; @@ -281,6 +272,7 @@ for example, (type-of 1) returns `integer'. */) case PVEC_XWIDGET_VIEW: return Qxwidget_view; /* "Impossible" cases. */ + case PVEC_MISC_PTR: case PVEC_OTHER: case PVEC_SUB_CHAR_TABLE: case PVEC_FREE: ; @@ -534,9 +526,9 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, attributes: const) (Lisp_Object object) { - if (NATNUMP (object)) - return Qt; - return Qnil; + return ((FIXNUMP (object) ? 0 <= XFIXNUM (object) + : BIGNUMP (object) && 0 <= mpz_sgn (XBIGNUM (object)->value)) + ? Qt : Qnil); } DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, @@ -768,7 +760,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)) + if (NILP (symbol) && !NILP (definition)) + /* There are so many other ways to shoot oneself in the foot, I don't + think this one little sanity check is worth its cost, but anyway. */ xsignal1 (Qsetting_constant, symbol); function = XSYMBOL (symbol)->u.s.function; @@ -858,10 +852,10 @@ function with `&rest' args, or `unevalled' for a special form. */) CHECK_SUBR (subr); minargs = XSUBR (subr)->min_args; maxargs = XSUBR (subr)->max_args; - return Fcons (make_number (minargs), + return Fcons (make_fixnum (minargs), maxargs == MANY ? Qmany : maxargs == UNEVALLED ? Qunevalled - : make_number (maxargs)); + : make_fixnum (maxargs)); } DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, @@ -992,7 +986,7 @@ do_symval_forwarding (register union Lisp_Fwd *valcontents) switch (XFWDTYPE (valcontents)) { case Lisp_Fwd_Int: - XSETINT (val, *XINTFWD (valcontents)->intvar); + XSETINT (val, *XFIXNUMFWD (valcontents)->intvar); return val; case Lisp_Fwd_Bool: @@ -1029,7 +1023,7 @@ do_symval_forwarding (register union Lisp_Fwd *valcontents) void wrong_choice (Lisp_Object choice, Lisp_Object wrong) { - ptrdiff_t i = 0, len = XINT (Flength (choice)); + ptrdiff_t i = 0, len = XFIXNUM (Flength (choice)); Lisp_Object obj, *args; AUTO_STRING (one_of, "One of "); AUTO_STRING (comma, ", "); @@ -1049,7 +1043,10 @@ wrong_choice (Lisp_Object choice, Lisp_Object wrong) } obj = Fconcat (i, args); - SAFE_FREE (); + + /* No need to call SAFE_FREE, since signaling does that for us. */ + (void) sa_count; + xsignal2 (Qerror, obj, wrong); } @@ -1081,8 +1078,8 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva switch (XFWDTYPE (valcontents)) { case Lisp_Fwd_Int: - CHECK_NUMBER (newval); - *XINTFWD (valcontents)->intvar = XINT (newval); + CHECK_FIXNUM (newval); + *XFIXNUMFWD (valcontents)->intvar = XFIXNUM (newval); break; case Lisp_Fwd_Bool: @@ -1710,11 +1707,21 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value, set it in the buffers that don't nominally have a local value. */ if (idx > 0) { - struct buffer *b; + Lisp_Object buf, tail; + + /* Do this only in live buffers, so that if there are + a lot of buffers which are dead, that doesn't slow + down let-binding of variables that are + automatically local when set, like + case-fold-search. This is for Lisp programs that + let-bind such variables in their inner loops. */ + FOR_EACH_LIVE_BUFFER (tail, buf) + { + struct buffer *b = XBUFFER (buf); - FOR_EACH_BUFFER (b) - if (!PER_BUFFER_VALUE_P (b, idx)) - set_per_buffer_value (b, offset, value); + if (!PER_BUFFER_VALUE_P (b, idx)) + set_per_buffer_value (b, offset, value); + } } } else @@ -1851,7 +1858,7 @@ The function `default-value' gets the default value and `set-default' sets it. } if (SYMBOL_CONSTANT_P (variable)) - error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); + xsignal1 (Qsetting_constant, variable); if (!blv) { @@ -1914,8 +1921,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) } if (sym->u.s.trapped_write == SYMBOL_NOWRITE) - error ("Symbol %s may not be buffer-local", - SDATA (SYMBOL_NAME (variable))); + xsignal1 (Qsetting_constant, variable); if (blv ? blv->local_if_set : (forwarded && BUFFER_OBJFWDP (valcontents.fwd))) @@ -2154,47 +2160,6 @@ If the current binding is global (the default), the value is nil. */) } } -/* This code is disabled now that we use the selected frame to return - keyboard-local-values. */ -#if 0 -extern struct terminal *get_terminal (Lisp_Object display, int); - -DEFUN ("terminal-local-value", Fterminal_local_value, - Sterminal_local_value, 2, 2, 0, - doc: /* Return the terminal-local value of SYMBOL on TERMINAL. -If SYMBOL is not a terminal-local variable, then return its normal -value, like `symbol-value'. - -TERMINAL may be a terminal object, a frame, or nil (meaning the -selected frame's terminal device). */) - (Lisp_Object symbol, Lisp_Object terminal) -{ - Lisp_Object result; - struct terminal *t = get_terminal (terminal, 1); - push_kboard (t->kboard); - result = Fsymbol_value (symbol); - pop_kboard (); - return result; -} - -DEFUN ("set-terminal-local-value", Fset_terminal_local_value, - Sset_terminal_local_value, 3, 3, 0, - doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE. -If VARIABLE is not a terminal-local variable, then set its normal -binding, like `set'. - -TERMINAL may be a terminal object, a frame, or nil (meaning the -selected frame's terminal device). */) - (Lisp_Object symbol, Lisp_Object terminal, Lisp_Object value) -{ - Lisp_Object result; - struct terminal *t = get_terminal (terminal, 1); - push_kboard (d->kboard); - result = Fset (symbol, value); - pop_kboard (); - return result; -} -#endif /* Find the function at the end of a chain of symbol function indirections. */ @@ -2261,8 +2226,8 @@ or a byte-code object. IDX starts at 0. */) { register EMACS_INT idxval; - CHECK_NUMBER (idx); - idxval = XINT (idx); + CHECK_FIXNUM (idx); + idxval = XFIXNUM (idx); if (STRINGP (array)) { int c; @@ -2271,11 +2236,11 @@ or a byte-code object. IDX starts at 0. */) if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); if (! STRING_MULTIBYTE (array)) - return make_number ((unsigned char) SREF (array, idxval)); + return make_fixnum ((unsigned char) SREF (array, idxval)); idxval_byte = string_char_to_byte (array, idxval); c = STRING_CHAR (SDATA (array) + idxval_byte); - return make_number (c); + return make_fixnum (c); } else if (BOOL_VECTOR_P (array)) { @@ -2312,8 +2277,8 @@ bool-vector. IDX starts at 0. */) { register EMACS_INT idxval; - CHECK_NUMBER (idx); - idxval = XINT (idx); + CHECK_FIXNUM (idx); + idxval = XFIXNUM (idx); if (! RECORDP (array)) CHECK_ARRAY (array, Qarrayp); @@ -2349,7 +2314,7 @@ bool-vector. IDX starts at 0. */) if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); CHECK_CHARACTER (newelt); - c = XFASTINT (newelt); + c = XFIXNAT (newelt); if (STRING_MULTIBYTE (array)) { @@ -2403,39 +2368,113 @@ bool-vector. IDX starts at 0. */) return newelt; } +/* GMP tests for this value and aborts (!) if it is exceeded. + This is as of GMP 6.1.2 (2016); perhaps future versions will differ. */ +enum { GMP_NLIMBS_MAX = min (INT_MAX, ULONG_MAX / GMP_NUMB_BITS) }; + +/* An upper bound on limb counts, needed to prevent libgmp and/or + Emacs from aborting or otherwise misbehaving. This bound applies + to estimates of mpz_t sizes before the mpz_t objects are created, + as opposed to integer-width which operates on mpz_t values after + creation and before conversion to Lisp bignums. */ +enum + { + NLIMBS_LIMIT = min (min (/* libgmp needs to store limb counts. */ + GMP_NLIMBS_MAX, + + /* Size calculations need to work. */ + min (PTRDIFF_MAX, SIZE_MAX) / sizeof (mp_limb_t)), + + /* Emacs puts bit counts into fixnums. */ + MOST_POSITIVE_FIXNUM / GMP_NUMB_BITS) + }; + +/* Like mpz_size, but tell the compiler the result is a nonnegative int. */ + +static int +emacs_mpz_size (mpz_t const op) +{ + mp_size_t size = mpz_size (op); + eassume (0 <= size && size <= INT_MAX); + return size; +} + +/* Wrappers to work around GMP limitations. As of GMP 6.1.2 (2016), + the library code aborts when a number is too large. These wrappers + avoid the problem for functions that can return numbers much larger + than their arguments. For slowly-growing numbers, the integer + width checks in bignum.c should suffice. */ + +static void +emacs_mpz_mul (mpz_t rop, mpz_t const op1, mpz_t const op2) +{ + if (NLIMBS_LIMIT - emacs_mpz_size (op1) < emacs_mpz_size (op2)) + overflow_error (); + mpz_mul (rop, op1, op2); +} + +static void +emacs_mpz_mul_2exp (mpz_t rop, mpz_t const op1, EMACS_INT op2) +{ + /* Fudge factor derived from GMP 6.1.2, to avoid an abort in + mpz_mul_2exp (look for the '+ 1' in its source code). */ + enum { mul_2exp_extra_limbs = 1 }; + enum { lim = min (NLIMBS_LIMIT, GMP_NLIMBS_MAX - mul_2exp_extra_limbs) }; + + EMACS_INT op2limbs = op2 / GMP_NUMB_BITS; + if (lim - emacs_mpz_size (op1) < op2limbs) + overflow_error (); + mpz_mul_2exp (rop, op1, op2); +} + +static void +emacs_mpz_pow_ui (mpz_t rop, mpz_t const base, unsigned long exp) +{ + /* This fudge factor is derived from GMP 6.1.2, to avoid an abort in + mpz_n_pow_ui (look for the '5' in its source code). */ + enum { pow_ui_extra_limbs = 5 }; + enum { lim = min (NLIMBS_LIMIT, GMP_NLIMBS_MAX - pow_ui_extra_limbs) }; + + int nbase = emacs_mpz_size (base), n; + if (INT_MULTIPLY_WRAPV (nbase, exp, &n) || lim < n) + overflow_error (); + mpz_pow_ui (rop, base, exp); +} + + /* Arithmetic functions */ Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison) { - double f1, f2; - EMACS_INT i1, i2; - bool lt, eq, gt; + EMACS_INT i1 = 0, i2 = 0; + bool lt, eq = true, gt; bool test; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2); + CHECK_NUMBER_COERCE_MARKER (num1); + CHECK_NUMBER_COERCE_MARKER (num2); - /* If either arg is floating point, set F1 and F2 to the 'double' - approximations of the two arguments, and set LT, EQ, and GT to - the <, ==, > floating-point comparisons of F1 and F2 + /* If the comparison is mostly done by comparing two doubles, + set LT, EQ, and GT to the <, ==, > results of that comparison, respectively, taking care to avoid problems if either is a NaN, and trying to avoid problems on platforms where variables (in violation of the C standard) can contain excess precision. Regardless, set I1 and I2 to integers that break ties if the - floating-point comparison is either not done or reports + two-double comparison is either not done or reports equality. */ if (FLOATP (num1)) { - f1 = XFLOAT_DATA (num1); + double f1 = XFLOAT_DATA (num1); if (FLOATP (num2)) { - i1 = i2 = 0; - f2 = XFLOAT_DATA (num2); + double f2 = XFLOAT_DATA (num2); + lt = f1 < f2; + eq = f1 == f2; + gt = f1 > f2; } - else + else if (FIXNUMP (num2)) { /* Compare a float NUM1 to an integer NUM2 by converting the integer I2 (i.e., NUM2) to the double F2 (a conversion that @@ -2445,35 +2484,56 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, floating-point comparison reports a tie, NUM1 = F1 = F2 = I1 (exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1 to I2 will break the tie correctly. */ - i1 = f2 = i2 = XINT (num2); + double f2 = XFIXNUM (num2); + lt = f1 < f2; + eq = f1 == f2; + gt = f1 > f2; + i1 = f2; + i2 = XFIXNUM (num2); } - lt = f1 < f2; - eq = f1 == f2; - gt = f1 > f2; + else if (isnan (f1)) + lt = eq = gt = false; + else + i2 = mpz_cmp_d (XBIGNUM (num2)->value, f1); } - else + else if (FIXNUMP (num1)) { - i1 = XINT (num1); if (FLOATP (num2)) { /* Compare an integer NUM1 to a float NUM2. This is the converse of comparing float to integer (see above). */ - i2 = f1 = i1; - f2 = XFLOAT_DATA (num2); + double f1 = XFIXNUM (num1), f2 = XFLOAT_DATA (num2); lt = f1 < f2; eq = f1 == f2; gt = f1 > f2; + i1 = XFIXNUM (num1); + i2 = f1; } - else + else if (FIXNUMP (num2)) { - i2 = XINT (num2); - eq = true; + i1 = XFIXNUM (num1); + i2 = XFIXNUM (num2); } + else + i2 = mpz_sgn (XBIGNUM (num2)->value); + } + else if (FLOATP (num2)) + { + double f2 = XFLOAT_DATA (num2); + if (isnan (f2)) + lt = eq = gt = false; + else + i1 = mpz_cmp_d (XBIGNUM (num1)->value, f2); } + else if (FIXNUMP (num2)) + i1 = mpz_sgn (XBIGNUM (num1)->value); + else + i1 = mpz_cmp (XBIGNUM (num1)->value, XBIGNUM (num2)->value); if (eq) { - /* Break a floating-point tie by comparing the integers. */ + /* The two-double comparison either reported equality, or was not done. + Break the tie by comparing the integers. */ lt = i1 < i2; eq = i1 == i2; gt = i1 > i2; @@ -2569,48 +2629,21 @@ DEFUN ("/=", Fneq, Sneq, 2, 2, 0, return arithcompare (num1, num2, ARITH_NOTEQUAL); } -/* Convert the integer I to a cons-of-integers, where I is not in - fixnum range. */ - -#define INTBIG_TO_LISP(i, extremum) \ - (eassert (FIXNUM_OVERFLOW_P (i)), \ - (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \ - && FIXNUM_OVERFLOW_P ((i) >> 16)) \ - ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \ - : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \ - && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \ - ? Fcons (make_number ((i) >> 16 >> 24), \ - Fcons (make_number ((i) >> 16 & 0xffffff), \ - make_number ((i) & 0xffff))) \ - : make_float (i))) - -Lisp_Object -intbig_to_lisp (intmax_t i) -{ - return INTBIG_TO_LISP (i, INTMAX_MIN); -} - -Lisp_Object -uintbig_to_lisp (uintmax_t i) -{ - return INTBIG_TO_LISP (i, UINTMAX_MAX); -} - /* Convert the cons-of-integers, integer, or float value C to an unsigned value with maximum value MAX, where MAX is one less than a power of 2. Signal an error if C does not have a valid format or - is out of range. */ + is out of range. + + Although Emacs represents large integers with bignums instead of + cons-of-integers or floats, for now this function still accepts the + obsolete forms in case some old Lisp code still generates them. */ uintmax_t cons_to_unsigned (Lisp_Object c, uintmax_t max) { bool valid = false; uintmax_t val UNINIT; - if (INTEGERP (c)) - { - valid = XINT (c) >= 0; - val = XINT (c); - } - else if (FLOATP (c)) + + if (FLOATP (c)) { double d = XFLOAT_DATA (c); if (d >= 0 && d < 1.0 + max) @@ -2619,27 +2652,34 @@ cons_to_unsigned (Lisp_Object c, uintmax_t max) valid = val == d; } } - else if (CONSP (c) && NATNUMP (XCAR (c))) + else { - uintmax_t top = XFASTINT (XCAR (c)); - Lisp_Object rest = XCDR (c); - if (top <= UINTMAX_MAX >> 24 >> 16 - && CONSP (rest) - && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24 - && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16) - { - uintmax_t mid = XFASTINT (XCAR (rest)); - val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest)); - valid = true; - } - else if (top <= UINTMAX_MAX >> 16) + Lisp_Object hi = CONSP (c) ? XCAR (c) : c; + valid = INTEGERP (hi) && integer_to_uintmax (hi, &val); + + if (valid && CONSP (c)) { - if (CONSP (rest)) - rest = XCAR (rest); - if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16) + uintmax_t top = val; + Lisp_Object rest = XCDR (c); + if (top <= UINTMAX_MAX >> 24 >> 16 + && CONSP (rest) + && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24 + && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16) { - val = top << 16 | XFASTINT (rest); - valid = true; + uintmax_t mid = XFIXNAT (XCAR (rest)); + val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest)); + } + else + { + valid = top <= UINTMAX_MAX >> 16; + if (valid) + { + if (CONSP (rest)) + rest = XCAR (rest); + valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16; + if (valid) + val = top << 16 | XFIXNAT (rest); + } } } } @@ -2653,18 +2693,18 @@ cons_to_unsigned (Lisp_Object c, uintmax_t max) value with extrema MIN and MAX. MAX should be one less than a power of 2, and MIN should be zero or the negative of a power of 2. Signal an error if C does not have a valid format or is out of - range. */ + range. + + Although Emacs represents large integers with bignums instead of + cons-of-integers or floats, for now this function still accepts the + obsolete forms in case some old Lisp code still generates them. */ intmax_t cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max) { bool valid = false; intmax_t val UNINIT; - if (INTEGERP (c)) - { - val = XINT (c); - valid = true; - } - else if (FLOATP (c)) + + if (FLOATP (c)) { double d = XFLOAT_DATA (c); if (d >= min && d < 1.0 + max) @@ -2673,27 +2713,34 @@ cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max) valid = val == d; } } - else if (CONSP (c) && INTEGERP (XCAR (c))) + else { - intmax_t top = XINT (XCAR (c)); - Lisp_Object rest = XCDR (c); - if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16 - && CONSP (rest) - && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24 - && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16) - { - intmax_t mid = XFASTINT (XCAR (rest)); - val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest)); - valid = true; - } - else if (top >= INTMAX_MIN >> 16 && top <= INTMAX_MAX >> 16) + Lisp_Object hi = CONSP (c) ? XCAR (c) : c; + valid = INTEGERP (hi) && integer_to_intmax (hi, &val); + + if (valid && CONSP (c)) { - if (CONSP (rest)) - rest = XCAR (rest); - if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16) + intmax_t top = val; + Lisp_Object rest = XCDR (c); + if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16 + && CONSP (rest) + && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24 + && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16) { - val = top << 16 | XFASTINT (rest); - valid = true; + intmax_t mid = XFIXNAT (XCAR (rest)); + val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest)); + } + else + { + valid = INTMAX_MIN >> 16 <= top && top <= INTMAX_MAX >> 16; + if (valid) + { + if (CONSP (rest)) + rest = XCAR (rest); + valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16; + if (valid) + val = top << 16 | XFIXNAT (rest); + } } } } @@ -2712,12 +2759,15 @@ NUMBER may be an integer or a floating point number. */) char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))]; int len; - CHECK_NUMBER_OR_FLOAT (number); + CHECK_NUMBER (number); + + if (BIGNUMP (number)) + return bignum_to_string (number, 10); if (FLOATP (number)) len = float_to_string (buffer, XFLOAT_DATA (number)); else - len = sprintf (buffer, "%"pI"d", XINT (number)); + len = sprintf (buffer, "%"pI"d", XFIXNUM (number)); return make_unibyte_string (buffer, len); } @@ -2732,9 +2782,7 @@ present, base 10 is used. BASE must be between 2 and 16 (inclusive). If the base used is not 10, STRING is always parsed as an integer. */) (register Lisp_Object string, Lisp_Object base) { - register char *p; - register int b; - Lisp_Object val; + int b; CHECK_STRING (string); @@ -2742,18 +2790,18 @@ If the base used is not 10, STRING is always parsed as an integer. */) b = 10; else { - CHECK_NUMBER (base); - if (! (XINT (base) >= 2 && XINT (base) <= 16)) + CHECK_FIXNUM (base); + if (! (XFIXNUM (base) >= 2 && XFIXNUM (base) <= 16)) xsignal1 (Qargs_out_of_range, base); - b = XINT (base); + b = XFIXNUM (base); } - p = SSDATA (string); + char *p = SSDATA (string); while (*p == ' ' || *p == '\t') p++; - val = string_to_number (p, b, 1); - return NILP (val) ? make_number (0) : val; + Lisp_Object val = string_to_number (p, b, 0); + return NILP (val) ? make_fixnum (0) : val; } enum arithop @@ -2766,151 +2814,178 @@ enum arithop Alogior, Alogxor }; +static bool +floating_point_op (enum arithop code) +{ + return code <= Adiv; +} + +/* Return the result of applying the floating-point operation CODE to + the NARGS arguments starting at ARGS. If ARGNUM is positive, + ARGNUM of the arguments were already consumed, yielding ACCUM. + 0 <= ARGNUM < NARGS, 2 <= NARGS, and NEXT is the value of + ARGS[ARGSNUM], converted to double. */ -static Lisp_Object float_arith_driver (double, ptrdiff_t, enum arithop, - ptrdiff_t, Lisp_Object *); static Lisp_Object -arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) +floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, double accum, double next) { - Lisp_Object val; - ptrdiff_t argnum, ok_args; - EMACS_INT accum = 0; - EMACS_INT next, ok_accum; - bool overflow = 0; - - switch (code) - { - case Alogior: - case Alogxor: - case Aadd: - case Asub: - accum = 0; - break; - case Amult: - case Adiv: - accum = 1; - break; - case Alogand: - accum = -1; - break; - default: - break; + if (argnum == 0) + { + accum = next; + goto next_arg; } - for (argnum = 0; argnum < nargs; argnum++) + while (true) { - if (! overflow) - { - ok_args = argnum; - ok_accum = accum; - } - - /* Using args[argnum] as argument to CHECK_NUMBER_... */ - val = args[argnum]; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); - - if (FLOATP (val)) - return float_arith_driver (ok_accum, ok_args, code, - nargs, args); - args[argnum] = val; - next = XINT (args[argnum]); switch (code) { - case Aadd: - overflow |= INT_ADD_WRAPV (accum, next, &accum); - break; - case Asub: - if (! argnum) - accum = nargs == 1 ? - next : next; - else - overflow |= INT_SUBTRACT_WRAPV (accum, next, &accum); - break; - case Amult: - overflow |= INT_MULTIPLY_WRAPV (accum, next, &accum); - break; + case Aadd : accum += next; break; + case Asub : accum -= next; break; + case Amult: accum *= next; break; case Adiv: - if (! (argnum || nargs == 1)) - accum = next; - else - { - if (next == 0) - xsignal0 (Qarith_error); - if (INT_DIVIDE_OVERFLOW (accum, next)) - overflow = true; - else - accum /= next; - } - break; - case Alogand: - accum &= next; - break; - case Alogior: - accum |= next; - break; - case Alogxor: - accum ^= next; + if (! IEEE_FLOATING_POINT && next == 0) + xsignal0 (Qarith_error); + accum /= next; break; + default: eassume (false); } + + next_arg: + argnum++; + if (argnum == nargs) + return make_float (accum); + Lisp_Object val = args[argnum]; + CHECK_NUMBER_COERCE_MARKER (val); + next = XFLOATINT (val); } +} - XSETINT (val, accum); - return val; +/* Like floatop_arith_driver, except CODE might not be a floating-point + operation, and NEXT is a Lisp float rather than a C double. */ + +static Lisp_Object +float_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, double accum, Lisp_Object next) +{ + if (! floating_point_op (code)) + wrong_type_argument (Qinteger_or_marker_p, next); + return floatop_arith_driver (code, nargs, args, argnum, accum, + XFLOAT_DATA (next)); } -#ifndef isnan -# define isnan(x) ((x) != (x)) -#endif +/* Return the result of applying the arithmetic operation CODE to the + NARGS arguments starting at ARGS. If ARGNUM is positive, ARGNUM of + the arguments were already consumed, yielding IACCUM. 0 <= ARGNUM + < NARGS, 2 <= NARGS, and VAL is the value of ARGS[ARGSNUM], + converted to integer. */ static Lisp_Object -float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code, - ptrdiff_t nargs, Lisp_Object *args) +bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val) { - register Lisp_Object val; - double next; + mpz_t *accum; + if (argnum == 0) + { + accum = bignum_integer (&mpz[0], val); + goto next_arg; + } + mpz_set_intmax (mpz[0], iaccum); + accum = &mpz[0]; - for (; argnum < nargs; argnum++) + while (true) { - val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); + mpz_t *next = bignum_integer (&mpz[1], val); - if (FLOATP (val)) - { - next = XFLOAT_DATA (val); - } - else - { - args[argnum] = val; /* runs into a compiler bug. */ - next = XINT (args[argnum]); - } switch (code) { - case Aadd: - accum += next; - break; - case Asub: - accum = argnum ? accum - next : nargs == 1 ? - next : next; - break; - case Amult: - accum *= next; - break; + case Aadd : mpz_add (mpz[0], *accum, *next); break; + case Asub : mpz_sub (mpz[0], *accum, *next); break; + case Amult : emacs_mpz_mul (mpz[0], *accum, *next); break; + case Alogand: mpz_and (mpz[0], *accum, *next); break; + case Alogior: mpz_ior (mpz[0], *accum, *next); break; + case Alogxor: mpz_xor (mpz[0], *accum, *next); break; case Adiv: - if (! (argnum || nargs == 1)) - accum = next; - else - { - if (! IEEE_FLOATING_POINT && next == 0) - xsignal0 (Qarith_error); - accum /= next; - } + if (mpz_sgn (*next) == 0) + xsignal0 (Qarith_error); + mpz_tdiv_q (mpz[0], *accum, *next); break; - case Alogand: - case Alogior: - case Alogxor: - wrong_type_argument (Qinteger_or_marker_p, val); + default: + eassume (false); } + accum = &mpz[0]; + + next_arg: + argnum++; + if (argnum == nargs) + return make_integer_mpz (); + val = args[argnum]; + CHECK_NUMBER_COERCE_MARKER (val); + if (FLOATP (val)) + return float_arith_driver (code, nargs, args, argnum, + mpz_get_d_rounded (*accum), val); } +} - return make_float (accum); +/* Return the result of applying the arithmetic operation CODE to the + NARGS arguments starting at ARGS, with the first argument being the + number VAL. 2 <= NARGS. Check that the remaining arguments are + numbers or markers. */ + +static Lisp_Object +arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + Lisp_Object val) +{ + eassume (2 <= nargs); + + ptrdiff_t argnum = 0; + /* Set ACCUM to VAL's value if it is a fixnum, otherwise to some + ignored value to avoid using an uninitialized variable later. */ + intmax_t accum = XFIXNUM (val); + + if (FIXNUMP (val)) + while (true) + { + argnum++; + if (argnum == nargs) + return make_int (accum); + val = args[argnum]; + CHECK_NUMBER_COERCE_MARKER (val); + + /* Set NEXT to the next value if it fits, else exit the loop. */ + intmax_t next; + if (! (INTEGERP (val) && integer_to_intmax (val, &next))) + break; + + /* Set ACCUM to the next operation's result if it fits, + else exit the loop. */ + bool overflow = false; + intmax_t a; + switch (code) + { + case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break; + case Amult: overflow = INT_MULTIPLY_WRAPV (accum, next, &a); break; + case Asub : overflow = INT_SUBTRACT_WRAPV (accum, next, &a); break; + case Adiv: + if (next == 0) + xsignal0 (Qarith_error); + overflow = INT_DIVIDE_OVERFLOW (accum, next); + if (!overflow) + a = accum / next; + break; + case Alogand: accum &= next; continue; + case Alogior: accum |= next; continue; + case Alogxor: accum ^= next; continue; + default: eassume (false); + } + if (overflow) + break; + accum = a; + } + + return (FLOATP (val) + ? float_arith_driver (code, nargs, args, argnum, accum, val) + : bignum_arith_driver (code, nargs, args, argnum, accum, val)); } @@ -2919,7 +2994,11 @@ DEFUN ("+", Fplus, Splus, 0, MANY, 0, usage: (+ &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Aadd, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = args[0]; + CHECK_NUMBER_COERCE_MARKER (a); + return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a); } DEFUN ("-", Fminus, Sminus, 0, MANY, 0, @@ -2929,7 +3008,20 @@ subtracts all but the first from the first. usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Asub, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = args[0]; + CHECK_NUMBER_COERCE_MARKER (a); + if (nargs == 1) + { + if (FIXNUMP (a)) + return make_int (-XFIXNUM (a)); + if (FLOATP (a)) + return make_float (-XFLOAT_DATA (a)); + mpz_neg (mpz[0], XBIGNUM (a)->value); + return make_integer_mpz (); + } + return arith_driver (Asub, nargs, args, a); } DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, @@ -2937,7 +3029,11 @@ DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, usage: (* &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Amult, nargs, args); + if (nargs == 0) + return make_fixnum (1); + Lisp_Object a = args[0]; + CHECK_NUMBER_COERCE_MARKER (a); + return nargs == 1 ? a : arith_driver (Amult, nargs, args, a); } DEFUN ("/", Fquo, Squo, 1, MANY, 0, @@ -2948,11 +3044,31 @@ The arguments must be numbers or markers. usage: (/ NUMBER &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { - ptrdiff_t argnum; - for (argnum = 2; argnum < nargs; argnum++) + Lisp_Object a = args[0]; + CHECK_NUMBER_COERCE_MARKER (a); + if (nargs == 1) + { + if (FIXNUMP (a)) + { + if (XFIXNUM (a) == 0) + xsignal0 (Qarith_error); + return make_fixnum (1 / XFIXNUM (a)); + } + if (FLOATP (a)) + { + if (! IEEE_FLOATING_POINT && XFLOAT_DATA (a) == 0) + xsignal0 (Qarith_error); + return make_float (1 / XFLOAT_DATA (a)); + } + /* Dividing 1 by any bignum yields 0. */ + return make_fixnum (0); + } + + /* Do all computation in floating-point if any arg is a float. */ + for (ptrdiff_t argnum = 2; argnum < nargs; argnum++) if (FLOATP (args[argnum])) - return float_arith_driver (0, 0, Adiv, nargs, args); - return arith_driver (Adiv, nargs, args); + return floatop_arith_driver (Adiv, nargs, args, 0, 0, XFLOATINT (a)); + return arith_driver (Adiv, nargs, args, a); } DEFUN ("%", Frem, Srem, 2, 2, 0, @@ -2960,16 +3076,22 @@ DEFUN ("%", Frem, Srem, 2, 2, 0, Both must be integers or markers. */) (register Lisp_Object x, Lisp_Object y) { - Lisp_Object val; - - CHECK_NUMBER_COERCE_MARKER (x); - CHECK_NUMBER_COERCE_MARKER (y); + CHECK_INTEGER_COERCE_MARKER (x); + CHECK_INTEGER_COERCE_MARKER (y); - if (XINT (y) == 0) + /* A bignum can never be 0, so don't check that case. */ + if (FIXNUMP (y) && XFIXNUM (y) == 0) xsignal0 (Qarith_error); - XSETINT (val, XINT (x) % XINT (y)); - return val; + if (FIXNUMP (x) && FIXNUMP (y)) + return make_fixnum (XFIXNUM (x) % XFIXNUM (y)); + else + { + mpz_tdiv_r (mpz[0], + *bignum_integer (&mpz[0], x), + *bignum_integer (&mpz[1], y)); + return make_integer_mpz (); + } } DEFUN ("mod", Fmod, Smod, 2, 2, 0, @@ -2978,29 +3100,45 @@ The result falls between zero (inclusive) and Y (exclusive). Both X and Y must be numbers or markers. */) (register Lisp_Object x, Lisp_Object y) { - Lisp_Object val; - EMACS_INT i1, i2; + CHECK_NUMBER_COERCE_MARKER (x); + CHECK_NUMBER_COERCE_MARKER (y); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y); + /* Note that a bignum can never be 0, so we don't need to check that + case. */ + if (FIXNUMP (y) && XFIXNUM (y) == 0) + xsignal0 (Qarith_error); if (FLOATP (x) || FLOATP (y)) return fmod_float (x, y); - i1 = XINT (x); - i2 = XINT (y); + if (FIXNUMP (x) && FIXNUMP (y)) + { + EMACS_INT i1 = XFIXNUM (x), i2 = XFIXNUM (y); - if (i2 == 0) - xsignal0 (Qarith_error); + if (i2 == 0) + xsignal0 (Qarith_error); - i1 %= i2; + i1 %= i2; - /* If the "remainder" comes out with the wrong sign, fix it. */ - if (i2 < 0 ? i1 > 0 : i1 < 0) - i1 += i2; + /* If the "remainder" comes out with the wrong sign, fix it. */ + if (i2 < 0 ? i1 > 0 : i1 < 0) + i1 += i2; - XSETINT (val, i1); - return val; + return make_fixnum (i1); + } + else + { + mpz_t *ym = bignum_integer (&mpz[1], y); + bool neg_y = mpz_sgn (*ym) < 0; + mpz_mod (mpz[0], *bignum_integer (&mpz[0], x), *ym); + + /* Fix the sign if needed. */ + int sgn_r = mpz_sgn (mpz[0]); + if (neg_y ? sgn_r > 0 : sgn_r < 0) + mpz_add (mpz[0], mpz[0], *ym); + + return make_integer_mpz (); + } } static Lisp_Object @@ -3008,11 +3146,11 @@ minmax_driver (ptrdiff_t nargs, Lisp_Object *args, enum Arith_Comparison comparison) { Lisp_Object accum = args[0]; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (accum); + CHECK_NUMBER_COERCE_MARKER (accum); for (ptrdiff_t argnum = 1; argnum < nargs; argnum++) { Lisp_Object val = args[argnum]; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); + CHECK_NUMBER_COERCE_MARKER (val); if (!NILP (arithcompare (val, accum, comparison))) accum = val; else if (FLOATP (val) && isnan (XFLOAT_DATA (val))) @@ -3045,7 +3183,11 @@ Arguments may be integers, or markers converted to integers. usage: (logand &rest INTS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Alogand, nargs, args); + if (nargs == 0) + return make_fixnum (-1); + Lisp_Object a = args[0]; + CHECK_INTEGER_COERCE_MARKER (a); + return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a); } DEFUN ("logior", Flogior, Slogior, 0, MANY, 0, @@ -3054,7 +3196,11 @@ Arguments may be integers, or markers converted to integers. usage: (logior &rest INTS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Alogior, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = args[0]; + CHECK_INTEGER_COERCE_MARKER (a); + return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a); } DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0, @@ -3063,48 +3209,108 @@ Arguments may be integers, or markers converted to integers. usage: (logxor &rest INTS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Alogxor, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = args[0]; + CHECK_INTEGER_COERCE_MARKER (a); + return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a); } -static Lisp_Object -ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh) +DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0, + doc: /* Return population count of VALUE. +This is the number of one bits in the two's complement representation +of VALUE. If VALUE is negative, return the number of zero bits in the +representation. */) + (Lisp_Object value) { - /* This code assumes that signed right shifts are arithmetic. */ - verify ((EMACS_INT) -1 >> 1 == -1); - - Lisp_Object val; + CHECK_INTEGER (value); - CHECK_NUMBER (value); - CHECK_NUMBER (count); + if (BIGNUMP (value)) + { + mpz_t *nonneg = &XBIGNUM (value)->value; + if (mpz_sgn (*nonneg) < 0) + { + mpz_com (mpz[0], *nonneg); + nonneg = &mpz[0]; + } + return make_fixnum (mpz_popcount (*nonneg)); + } - if (XINT (count) >= EMACS_INT_WIDTH) - XSETINT (val, 0); - else if (XINT (count) > 0) - XSETINT (val, XUINT (value) << XINT (count)); - else if (XINT (count) <= -EMACS_INT_WIDTH) - XSETINT (val, lsh ? 0 : XINT (value) < 0 ? -1 : 0); - else - XSETINT (val, (lsh ? XUINT (value) >> -XINT (count) - : XINT (value) >> -XINT (count))); - return val; + eassume (FIXNUMP (value)); + EMACS_INT v = XFIXNUM (value) < 0 ? -1 - XFIXNUM (value) : XFIXNUM (value); + return make_fixnum (EMACS_UINT_WIDTH <= UINT_WIDTH + ? count_one_bits (v) + : EMACS_UINT_WIDTH <= ULONG_WIDTH + ? count_one_bits_l (v) + : count_one_bits_ll (v)); } 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) + (Lisp_Object value, Lisp_Object count) { - return ash_lsh_impl (value, count, false); + CHECK_INTEGER (value); + CHECK_INTEGER (count); + + if (! FIXNUMP (count)) + { + if (EQ (value, make_fixnum (0))) + return value; + if (mpz_sgn (XBIGNUM (count)->value) < 0) + { + EMACS_INT v = (FIXNUMP (value) ? XFIXNUM (value) + : mpz_sgn (XBIGNUM (value)->value)); + return make_fixnum (v < 0 ? -1 : 0); + } + overflow_error (); + } + + if (XFIXNUM (count) <= 0) + { + if (XFIXNUM (count) == 0) + return value; + + if ((EMACS_INT) -1 >> 1 == -1 && FIXNUMP (value)) + { + EMACS_INT shift = -XFIXNUM (count); + EMACS_INT result + = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift + : XFIXNUM (value) < 0 ? -1 : 0); + return make_fixnum (result); + } + } + + mpz_t *zval = bignum_integer (&mpz[0], value); + if (XFIXNUM (count) < 0) + { + if (TYPE_MAXIMUM (mp_bitcnt_t) < - XFIXNUM (count)) + return make_fixnum (mpz_sgn (*zval) < 0 ? -1 : 0); + mpz_fdiv_q_2exp (mpz[0], *zval, - XFIXNUM (count)); + } + else + emacs_mpz_mul_2exp (mpz[0], *zval, XFIXNUM (count)); + return make_integer_mpz (); } -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) -{ - return ash_lsh_impl (value, count, true); +/* Return X ** Y as an integer. X and Y must be integers, and Y must + be nonnegative. */ + +Lisp_Object +expt_integer (Lisp_Object x, Lisp_Object y) +{ + unsigned long exp; + if (TYPE_RANGED_FIXNUMP (unsigned long, y)) + exp = XFIXNUM (y); + else if (MOST_POSITIVE_FIXNUM < ULONG_MAX && BIGNUMP (y) + && mpz_fits_ulong_p (XBIGNUM (y)->value)) + exp = mpz_get_ui (XBIGNUM (y)->value); + else + overflow_error (); + + emacs_mpz_pow_ui (mpz[0], *bignum_integer (&mpz[0], x), exp); + return make_integer_mpz (); } DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, @@ -3112,13 +3318,14 @@ DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, Markers are converted to integers. */) (register Lisp_Object number) { - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); + CHECK_NUMBER_COERCE_MARKER (number); + if (FIXNUMP (number)) + return make_int (XFIXNUM (number) + 1); if (FLOATP (number)) return (make_float (1.0 + XFLOAT_DATA (number))); - - XSETINT (number, XINT (number) + 1); - return number; + mpz_add_ui (mpz[0], XBIGNUM (number)->value, 1); + return make_integer_mpz (); } DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, @@ -3126,22 +3333,25 @@ DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, Markers are converted to integers. */) (register Lisp_Object number) { - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); + CHECK_NUMBER_COERCE_MARKER (number); + if (FIXNUMP (number)) + return make_int (XFIXNUM (number) - 1); if (FLOATP (number)) return (make_float (-1.0 + XFLOAT_DATA (number))); - - XSETINT (number, XINT (number) - 1); - return number; + mpz_sub_ui (mpz[0], XBIGNUM (number)->value, 1); + return make_integer_mpz (); } DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */) (register Lisp_Object number) { - CHECK_NUMBER (number); - XSETINT (number, ~XINT (number)); - return number; + CHECK_INTEGER (number); + if (FIXNUMP (number)) + return make_fixnum (~XFIXNUM (number)); + mpz_com (mpz[0], XBIGNUM (number)->value); + return make_integer_mpz (); } DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0, @@ -3154,7 +3364,7 @@ lowercase l) for small endian machines. */ unsigned i = 0x04030201; int order = *(char *)&i == 1 ? 108 : 66; - return make_number (order); + return make_fixnum (order); } /* Because we round up the bool vector allocate size to word_size @@ -3507,7 +3717,7 @@ value from A's length. */) for (i = 0; i < nwords; i++) count += count_one_bits_word (adata[i]); - return make_number (count); + return make_fixnum (count); } DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive, @@ -3526,16 +3736,16 @@ A is a bool vector, B is t or nil, and I is an index into A. */) ptrdiff_t nr_words; CHECK_BOOL_VECTOR (a); - CHECK_NATNUM (i); + CHECK_FIXNAT (i); nr_bits = bool_vector_size (a); - if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */ + if (XFIXNAT (i) > nr_bits) /* Allow one past the end for convenience */ args_out_of_range (a, i); adata = bool_vector_data (a); nr_words = bool_vector_words (nr_bits); - pos = XFASTINT (i) / BITS_PER_BITS_WORD; - offset = XFASTINT (i) % BITS_PER_BITS_WORD; + pos = XFIXNAT (i) / BITS_PER_BITS_WORD; + offset = XFIXNAT (i) % BITS_PER_BITS_WORD; count = 0; /* By XORing with twiddle, we transform the problem of "count @@ -3556,7 +3766,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */) count = count_trailing_zero_bits (mword); pos++; if (count + offset < BITS_PER_BITS_WORD) - return make_number (count); + return make_fixnum (count); } /* Scan whole words until we either reach the end of the vector or @@ -3583,7 +3793,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */) count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD; } - return make_number (count); + return make_fixnum (count); } @@ -3626,6 +3836,7 @@ syms_of_data (void) DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); DEFSYM (Qsymbolp, "symbolp"); + DEFSYM (Qfixnump, "fixnump"); DEFSYM (Qintegerp, "integerp"); DEFSYM (Qnatnump, "natnump"); DEFSYM (Qwholenump, "wholenump"); @@ -3830,10 +4041,6 @@ syms_of_data (void) defsubr (&Slocal_variable_p); defsubr (&Slocal_variable_if_set_p); defsubr (&Svariable_binding_locus); -#if 0 /* XXX Remove this. --lorentey */ - defsubr (&Sterminal_local_value); - defsubr (&Sset_terminal_local_value); -#endif defsubr (&Saref); defsubr (&Saset); defsubr (&Snumber_to_string); @@ -3855,7 +4062,7 @@ syms_of_data (void) defsubr (&Slogand); defsubr (&Slogior); defsubr (&Slogxor); - defsubr (&Slsh); + defsubr (&Slogcount); defsubr (&Sash); defsubr (&Sadd1); defsubr (&Ssub1); @@ -3879,15 +4086,15 @@ syms_of_data (void) set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->u.s.function); DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum, - doc: /* The largest value that is representable in a Lisp integer. + doc: /* The greatest integer that is represented efficiently. This variable cannot be set; trying to do so will signal an error. */); - Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM); + Vmost_positive_fixnum = make_fixnum (MOST_POSITIVE_FIXNUM); 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. + doc: /* The least integer that is represented efficiently. This variable cannot be set; trying to do so will signal an error. */); - Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM); + Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM); make_symbol_constant (intern_c_string ("most-negative-fixnum")); DEFSYM (Qwatchers, "watchers"); diff --git a/src/dbusbind.c b/src/dbusbind.c index 6ae9bc7f538..e1c4eda76e9 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -200,17 +200,17 @@ xd_symbol_to_dbus_type (Lisp_Object object) `dbus-send-signal', into corresponding C values appended as arguments to a D-Bus message. */ #define XD_OBJECT_TO_DBUS_TYPE(object) \ - ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN \ - : (NATNUMP (object)) ? DBUS_TYPE_UINT32 \ - : (INTEGERP (object)) ? DBUS_TYPE_INT32 \ + ((EQ (object, Qt) || NILP (object)) ? DBUS_TYPE_BOOLEAN \ + : (FIXNATP (object)) ? DBUS_TYPE_UINT32 \ + : (FIXNUMP (object)) ? DBUS_TYPE_INT32 \ : (FLOATP (object)) ? DBUS_TYPE_DOUBLE \ : (STRINGP (object)) ? DBUS_TYPE_STRING \ : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object) \ : (CONSP (object)) \ - ? ((XD_DBUS_TYPE_P (CAR_SAFE (object))) \ - ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \ + ? ((XD_DBUS_TYPE_P (XCAR (object))) \ + ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (XCAR (object)))) \ ? DBUS_TYPE_ARRAY \ - : xd_symbol_to_dbus_type (CAR_SAFE (object))) \ + : xd_symbol_to_dbus_type (XCAR (object))) \ : DBUS_TYPE_ARRAY) \ : DBUS_TYPE_INVALID) @@ -355,18 +355,18 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) { case DBUS_TYPE_BYTE: case DBUS_TYPE_UINT16: - CHECK_NATNUM (object); + CHECK_FIXNAT (object); sprintf (signature, "%c", dtype); break; case DBUS_TYPE_BOOLEAN: - if (!EQ (object, Qt) && !EQ (object, Qnil)) + if (!EQ (object, Qt) && !NILP (object)) wrong_type_argument (intern ("booleanp"), object); sprintf (signature, "%c", dtype); break; case DBUS_TYPE_INT16: - CHECK_NUMBER (object); + CHECK_FIXNUM (object); sprintf (signature, "%c", dtype); break; @@ -378,7 +378,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) case DBUS_TYPE_INT32: case DBUS_TYPE_INT64: case DBUS_TYPE_DOUBLE: - CHECK_NUMBER_OR_FLOAT (object); + CHECK_NUMBER (object); sprintf (signature, "%c", dtype); break; @@ -396,7 +396,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) CHECK_CONS (object); /* Type symbol is optional. */ - if (EQ (QCarray, CAR_SAFE (elt))) + if (EQ (QCarray, XCAR (elt))) elt = XD_NEXT_VALUE (elt); /* If the array is empty, DBUS_TYPE_STRING is the default @@ -416,10 +416,12 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) /* If the element type is DBUS_TYPE_SIGNATURE, and this is the only element, the value of this element is used as the array's element signature. */ - if ((subtype == DBUS_TYPE_SIGNATURE) - && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt))) - && NILP (CDR_SAFE (XD_NEXT_VALUE (elt)))) - subsig = SSDATA (CAR_SAFE (XD_NEXT_VALUE (elt))); + if (subtype == DBUS_TYPE_SIGNATURE) + { + Lisp_Object elt1 = XD_NEXT_VALUE (elt); + if (CONSP (elt1) && STRINGP (XCAR (elt1)) && NILP (XCDR (elt1))) + subsig = SSDATA (XCAR (elt1)); + } while (!NILP (elt)) { @@ -517,11 +519,12 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) static intmax_t xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi) { - CHECK_NUMBER_OR_FLOAT (x); + CHECK_NUMBER (x); if (INTEGERP (x)) { - if (lo <= XINT (x) && XINT (x) <= hi) - return XINT (x); + intmax_t i; + if (integer_to_intmax (x, &i) && lo <= i && i <= hi) + return i; } else { @@ -533,23 +536,23 @@ xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi) return n; } } + if (xd_in_read_queued_messages) Fthrow (Qdbus_error, Qnil); else - args_out_of_range_3 (x, - make_fixnum_or_float (lo), - make_fixnum_or_float (hi)); + args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (hi)); } /* Convert X to an unsigned integer with bounds 0 and HI. */ static uintmax_t xd_extract_unsigned (Lisp_Object x, uintmax_t hi) { - CHECK_NUMBER_OR_FLOAT (x); + CHECK_NUMBER (x); if (INTEGERP (x)) { - if (0 <= XINT (x) && XINT (x) <= hi) - return XINT (x); + uintmax_t i; + if (integer_to_uintmax (x, &i) && i <= hi) + return i; } else { @@ -561,10 +564,11 @@ xd_extract_unsigned (Lisp_Object x, uintmax_t hi) return n; } } + if (xd_in_read_queued_messages) Fthrow (Qdbus_error, Qnil); else - args_out_of_range_3 (x, make_number (0), make_fixnum_or_float (hi)); + args_out_of_range_3 (x, make_fixnum (0), INT_TO_INTEGER (hi)); } /* Append C value, extracted from Lisp OBJECT, to iteration ITER. @@ -582,9 +586,9 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter) switch (dtype) { case DBUS_TYPE_BYTE: - CHECK_NATNUM (object); + CHECK_FIXNAT (object); { - unsigned char val = XFASTINT (object) & 0xFF; + unsigned char val = XFIXNAT (object) & 0xFF; XD_DEBUG_MESSAGE ("%c %u", dtype, val); if (!dbus_message_iter_append_basic (iter, dtype, &val)) XD_SIGNAL2 (build_string ("Unable to append argument"), object); @@ -748,7 +752,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter) if (!dbus_message_iter_open_container (iter, dtype, signature, &subiter)) XD_SIGNAL3 (build_string ("Cannot open container"), - make_number (dtype), build_string (signature)); + make_fixnum (dtype), build_string (signature)); break; case DBUS_TYPE_VARIANT: @@ -761,7 +765,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter) if (!dbus_message_iter_open_container (iter, dtype, signature, &subiter)) XD_SIGNAL3 (build_string ("Cannot open container"), - make_number (dtype), build_string (signature)); + make_fixnum (dtype), build_string (signature)); break; case DBUS_TYPE_STRUCT: @@ -770,7 +774,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter) XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (object)); if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter)) XD_SIGNAL2 (build_string ("Cannot open container"), - make_number (dtype)); + make_fixnum (dtype)); break; } @@ -788,7 +792,7 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter) /* Close the subiteration. */ if (!dbus_message_iter_close_container (iter, &subiter)) XD_SIGNAL2 (build_string ("Cannot close container"), - make_number (dtype)); + make_fixnum (dtype)); } } @@ -808,7 +812,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); val = val & 0xFF; XD_DEBUG_MESSAGE ("%c %u", dtype, val); - return make_number (val); + return make_fixnum (val); } case DBUS_TYPE_BOOLEAN: @@ -826,7 +830,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return make_number (val); + return make_fixnum (val); } case DBUS_TYPE_UINT16: @@ -836,7 +840,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return make_number (val); + return make_fixnum (val); } case DBUS_TYPE_INT32: @@ -846,7 +850,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return make_fixnum_or_float (val); + return INT_TO_INTEGER (val); } case DBUS_TYPE_UINT32: @@ -859,7 +863,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %u", dtype, pval); - return make_fixnum_or_float (val); + return INT_TO_INTEGER (val); } case DBUS_TYPE_INT64: @@ -869,7 +873,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval); - return make_fixnum_or_float (val); + return INT_TO_INTEGER (val); } case DBUS_TYPE_UINT64: @@ -879,7 +883,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval); - return make_fixnum_or_float (val); + return INT_TO_INTEGER (val); } case DBUS_TYPE_DOUBLE: @@ -944,7 +948,7 @@ xd_get_connection_references (DBusConnection *connection) static DBusConnection * xd_lisp_dbus_to_dbus (Lisp_Object bus) { - return (DBusConnection *) XSAVE_POINTER (bus, 0); + return xmint_pointer (bus); } /* Return D-Bus connection address. BUS is either a Lisp symbol, @@ -1187,7 +1191,7 @@ this connection to those buses. */) XD_SIGNAL1 (build_string ("Cannot add watch functions")); /* Add bus to list of registered buses. */ - val = make_save_ptr (connection); + val = make_mint_ptr (connection); xd_registered_buses = Fcons (Fcons (bus, val), xd_registered_buses); /* Cleanup. */ @@ -1198,7 +1202,7 @@ this connection to those buses. */) refcount = xd_get_connection_references (connection); XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d", XD_OBJECT_TO_STRING (bus), refcount); - return make_number (refcount); + return make_fixnum (refcount); } DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name, @@ -1273,11 +1277,11 @@ usage: (dbus-message-internal &rest REST) */) service = args[2]; handler = Qnil; - CHECK_NATNUM (message_type); - if (! (DBUS_MESSAGE_TYPE_INVALID < XFASTINT (message_type) - && XFASTINT (message_type) < DBUS_NUM_MESSAGE_TYPES)) + CHECK_FIXNAT (message_type); + if (! (DBUS_MESSAGE_TYPE_INVALID < XFIXNAT (message_type) + && XFIXNAT (message_type) < DBUS_NUM_MESSAGE_TYPES)) XD_SIGNAL2 (build_string ("Invalid message type"), message_type); - mtype = XFASTINT (message_type); + mtype = XFIXNAT (message_type); if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) || (mtype == DBUS_MESSAGE_TYPE_SIGNAL)) @@ -1301,7 +1305,7 @@ usage: (dbus-message-internal &rest REST) */) if (nargs < count) xsignal2 (Qwrong_number_of_arguments, Qdbus_message_internal, - make_number (nargs)); + make_fixnum (nargs)); if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) || (mtype == DBUS_MESSAGE_TYPE_SIGNAL)) @@ -1407,8 +1411,8 @@ usage: (dbus-message-internal &rest REST) */) /* Check for timeout parameter. */ if ((count + 2 <= nargs) && EQ (args[count], QCtimeout)) { - CHECK_NATNUM (args[count+1]); - timeout = min (XFASTINT (args[count+1]), INT_MAX); + CHECK_FIXNAT (args[count+1]); + timeout = min (XFIXNAT (args[count+1]), INT_MAX); count = count+2; } @@ -1452,7 +1456,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 (QCserial, bus, make_fixnum_or_float (serial)); + result = list3 (QCserial, bus, INT_TO_INTEGER (serial)); /* Create a hash table entry. */ Fputhash (result, handler, Vdbus_registered_objects_table); @@ -1539,7 +1543,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 (QCserial, bus, make_fixnum_or_float (serial)); + key = list3 (QCserial, bus, INT_TO_INTEGER (serial)); value = Fgethash (key, Vdbus_registered_objects_table, Qnil); /* There shall be exactly one entry. Construct an event. */ @@ -1606,8 +1610,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) event.arg); event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)), event.arg); - event.arg = Fcons (make_fixnum_or_float (serial), event.arg); - event.arg = Fcons (make_number (mtype), event.arg); + event.arg = Fcons (INT_TO_INTEGER (serial), event.arg); + event.arg = Fcons (make_fixnum (mtype), event.arg); /* Add the bus symbol to the event. */ event.arg = Fcons (bus, event.arg); @@ -1752,28 +1756,28 @@ syms_of_dbusbind (void) DEFVAR_LISP ("dbus-message-type-invalid", Vdbus_message_type_invalid, doc: /* This value is never a valid message type. */); - Vdbus_message_type_invalid = make_number (DBUS_MESSAGE_TYPE_INVALID); + Vdbus_message_type_invalid = make_fixnum (DBUS_MESSAGE_TYPE_INVALID); DEFVAR_LISP ("dbus-message-type-method-call", Vdbus_message_type_method_call, doc: /* Message type of a method call message. */); - Vdbus_message_type_method_call = make_number (DBUS_MESSAGE_TYPE_METHOD_CALL); + Vdbus_message_type_method_call = make_fixnum (DBUS_MESSAGE_TYPE_METHOD_CALL); DEFVAR_LISP ("dbus-message-type-method-return", Vdbus_message_type_method_return, doc: /* Message type of a method return message. */); Vdbus_message_type_method_return - = make_number (DBUS_MESSAGE_TYPE_METHOD_RETURN); + = make_fixnum (DBUS_MESSAGE_TYPE_METHOD_RETURN); DEFVAR_LISP ("dbus-message-type-error", Vdbus_message_type_error, doc: /* Message type of an error reply message. */); - Vdbus_message_type_error = make_number (DBUS_MESSAGE_TYPE_ERROR); + Vdbus_message_type_error = make_fixnum (DBUS_MESSAGE_TYPE_ERROR); DEFVAR_LISP ("dbus-message-type-signal", Vdbus_message_type_signal, doc: /* Message type of a signal message. */); - Vdbus_message_type_signal = make_number (DBUS_MESSAGE_TYPE_SIGNAL); + Vdbus_message_type_signal = make_fixnum (DBUS_MESSAGE_TYPE_SIGNAL); DEFVAR_LISP ("dbus-registered-objects-table", Vdbus_registered_objects_table, diff --git a/src/decompress.c b/src/decompress.c index a24b9f0678e..e66e4798b18 100644 --- a/src/decompress.c +++ b/src/decompress.c @@ -24,11 +24,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "buffer.h" +#include "composite.h" #include <verify.h> #ifdef WINDOWSNT # include <windows.h> +# include "w32common.h" # include "w32.h" DEF_DLL_FN (int, inflateInit2_, @@ -66,7 +68,7 @@ init_zlib_functions (void) struct decompress_unwind_data { - ptrdiff_t old_point, start, nbytes; + ptrdiff_t old_point, orig, start, nbytes; z_stream *stream; }; @@ -76,10 +78,19 @@ unwind_decompress (void *ddata) struct decompress_unwind_data *data = ddata; inflateEnd (data->stream); - /* Delete any uncompressed data already inserted on error. */ + /* Delete any uncompressed data already inserted on error, but + without calling the change hooks. */ if (data->start) - del_range (data->start, data->start + data->nbytes); - + { + del_range_2 (data->start, data->start, /* byte, char offsets the same */ + data->start + data->nbytes, data->start + data->nbytes, + 0); + update_compositions (data->start, data->start, CHECK_HEAD); + /* "Balance" the before-change-functions call, which would + otherwise be left "hanging". */ + signal_after_change (data->orig, data->start - data->orig, + data->start - data->orig); + } /* Put point where it was, or if the buffer has shrunk because the compressed data is bigger than the uncompressed, at point-max. */ @@ -139,8 +150,12 @@ This function can be called only in unibyte buffers. */) /* This is a unibyte buffer, so character positions and bytes are the same. */ - istart = XINT (start); - iend = XINT (end); + istart = XFIXNUM (start); + iend = XFIXNUM (end); + + /* Do the following before manipulating the gap. */ + modify_text (istart, iend); + move_gap_both (iend, iend); stream.zalloc = Z_NULL; @@ -154,6 +169,7 @@ This function can be called only in unibyte buffers. */) if (inflateInit2 (&stream, MAX_WBITS + 32) != Z_OK) return Qnil; + unwind_data.orig = istart; unwind_data.start = iend; unwind_data.stream = &stream; unwind_data.old_point = PT; @@ -196,7 +212,11 @@ This function can be called only in unibyte buffers. */) unwind_data.start = 0; /* Delete the compressed data. */ - del_range (istart, iend); + del_range_2 (istart, istart, /* byte and char offsets are the same. */ + iend, iend, 0); + + signal_after_change (istart, iend - istart, unwind_data.nbytes); + update_compositions (istart, istart, CHECK_HEAD); return unbind_to (count, Qt); } diff --git a/src/deps.mk b/src/deps.mk index 4db66e79da6..2cdeba8d4ae 100644 --- a/src/deps.mk +++ b/src/deps.mk @@ -71,7 +71,7 @@ cmds.o: cmds.c syntax.h buffer.h character.h commands.h window.h lisp.h \ pre-crt0.o: pre-crt0.c dbusbind.o: dbusbind.c termhooks.h frame.h keyboard.h lisp.h $(config_h) dired.o: dired.c commands.h buffer.h lisp.h $(config_h) character.h charset.h \ - coding.h regex.h systime.h blockinput.h atimer.h composite.h \ + coding.h regex-emacs.h systime.h blockinput.h atimer.h composite.h \ ../lib/filemode.h ../lib/unistd.h globals.h dispnew.o: dispnew.c systime.h commands.h process.h frame.h coding.h \ window.h buffer.h termchar.h termopts.h termhooks.h cm.h \ @@ -169,20 +169,21 @@ process.o: process.c process.h buffer.h window.h termhooks.h termopts.h \ blockinput.h atimer.h coding.h msdos.h nsterm.h composite.h \ keyboard.h lisp.h globals.h $(config_h) character.h xgselect.h sysselect.h \ ../lib/unistd.h gnutls.h -regex.o: regex.c syntax.h buffer.h lisp.h globals.h $(config_h) regex.h \ +regex-emacs.o: regex-emacs.c syntax.h buffer.h lisp.h globals.h \ + $(config_h) regex-emacs.h \ category.h character.h region-cache.o: region-cache.c buffer.h region-cache.h \ lisp.h globals.h $(config_h) scroll.o: scroll.c termchar.h dispextern.h frame.h msdos.h keyboard.h \ termhooks.h lisp.h globals.h $(config_h) systime.h coding.h composite.h \ window.h -search.o: search.c regex.h commands.h buffer.h region-cache.h syntax.h \ +search.o: search.c regex-emacs.h commands.h buffer.h region-cache.h syntax.h \ blockinput.h atimer.h systime.h category.h character.h charset.h \ $(INTERVALS_H) lisp.h globals.h $(config_h) sound.o: sound.c dispextern.h syssignal.h lisp.h globals.h $(config_h) \ atimer.h systime.h ../lib/unistd.h msdos.h syntax.o: syntax.c syntax.h buffer.h commands.h category.h character.h \ - keymap.h regex.h $(INTERVALS_H) lisp.h globals.h $(config_h) + keymap.h regex-emacs.h $(INTERVALS_H) lisp.h globals.h $(config_h) sysdep.o: sysdep.c syssignal.h systty.h systime.h syswait.h blockinput.h \ process.h dispextern.h termhooks.h termchar.h termopts.h coding.h \ frame.h atimer.h window.h msdos.h dosfns.h keyboard.h cm.h lisp.h \ diff --git a/src/dired.c b/src/dired.c index aa5b06a8ef6..17a21b07e3e 100644 --- a/src/dired.c +++ b/src/dired.c @@ -40,7 +40,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "systime.h" #include "buffer.h" #include "coding.h" -#include "regex.h" #ifdef MSDOS #include "msdos.h" /* for fstatat */ @@ -171,7 +170,6 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, { ptrdiff_t directory_nbytes; Lisp_Object list, dirfilename, encoded_directory; - struct re_pattern_buffer *bufp = NULL; bool needsep = 0; ptrdiff_t count = SPECPDL_INDEX (); #ifdef WINDOWSNT @@ -187,33 +185,12 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, list = encoded_directory = dirfilename = Qnil; dirfilename = Fdirectory_file_name (directory); - if (!NILP (match)) - { - CHECK_STRING (match); - - /* MATCH might be a flawed regular expression. Rather than - catching and signaling our own errors, we just call - compile_pattern to do the work for us. */ - /* Pass 1 for the MULTIBYTE arg - because we do make multibyte strings if the contents warrant. */ -# ifdef WINDOWSNT - /* Windows users want case-insensitive wildcards. */ - bufp = compile_pattern (match, 0, - BVAR (&buffer_defaults, case_canon_table), 0, 1); -# else /* !WINDOWSNT */ - bufp = compile_pattern (match, 0, Qnil, 0, 1); -# endif /* !WINDOWSNT */ - } - /* Note: ENCODE_FILE and DECODE_FILE can GC because they can run run_pre_post_conversion_on_str which calls Lisp directly and indirectly. */ dirfilename = ENCODE_FILE (dirfilename); encoded_directory = ENCODE_FILE (directory); - /* Now *bufp is the compiled form of MATCH; don't call anything - which might compile a new regexp until we're done with the loop! */ - int fd; DIR *d = open_directory (dirfilename, &fd); @@ -250,6 +227,18 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, || !IS_ANY_SEP (SREF (directory, directory_nbytes - 1))) needsep = 1; + /* Windows users want case-insensitive wildcards. */ + Lisp_Object case_table = +#ifdef WINDOWSNT + BVAR (&buffer_defaults, case_canon_table) +#else + Qnil +#endif + ; + + if (!NILP (match)) + CHECK_STRING (match); + /* Loop reading directory entries. */ for (struct dirent *dp; (dp = read_dirent (d, directory)); ) { @@ -266,8 +255,9 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, allow matching to be interrupted. */ maybe_quit (); - bool wanted = (NILP (match) - || re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0); + bool wanted = (NILP (match) || + fast_string_match_internal ( + match, name, case_table) >= 0); if (wanted) { @@ -346,7 +336,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. directory = Fexpand_file_name (directory, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (directory, Qdirectory_files); if (!NILP (handler)) return call5 (handler, Qdirectory_files, directory, @@ -360,7 +350,7 @@ DEFUN ("directory-files-and-attributes", Fdirectory_files_and_attributes, doc: /* Return a list of names of files and their attributes in DIRECTORY. Value is a list of the form: - ((FILE1 FILE1-ATTRS) (FILE2 FILE2-ATTRS) ...) + ((FILE1 . FILE1-ATTRS) (FILE2 . FILE2-ATTRS) ...) where each FILEn-ATTRS is the attributes of FILEn as returned by `file-attributes'. @@ -381,7 +371,7 @@ which see. */) directory = Fexpand_file_name (directory, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (directory, Qdirectory_files_and_attributes); if (!NILP (handler)) return call6 (handler, Qdirectory_files_and_attributes, @@ -416,13 +406,13 @@ is matched against file and directory names relative to DIRECTORY. */) directory = Fexpand_file_name (directory, Qnil); /* If the directory name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (directory, Qfile_name_completion); if (!NILP (handler)) return call4 (handler, Qfile_name_completion, file, directory, predicate); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (file, Qfile_name_completion); if (!NILP (handler)) return call4 (handler, Qfile_name_completion, file, directory, predicate); @@ -444,13 +434,13 @@ is matched against file and directory names relative to DIRECTORY. */) directory = Fexpand_file_name (directory, Qnil); /* If the directory name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (directory, Qfile_name_all_completions); if (!NILP (handler)) return call3 (handler, Qfile_name_all_completions, file, directory); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (file, Qfile_name_all_completions); if (!NILP (handler)) return call3 (handler, Qfile_name_all_completions, file, directory); @@ -684,15 +674,15 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, /* Reject entries where the encoded strings match, but the decoded don't. For example, "a" should not match "a-ring" on file systems that store decomposed characters. */ - Lisp_Object zero = make_number (0); + Lisp_Object zero = make_fixnum (0); if (check_decoded && SCHARS (file) <= SCHARS (name)) { /* FIXME: This is a copy of the code below. */ ptrdiff_t compare = SCHARS (file); Lisp_Object cmp - = Fcompare_strings (name, zero, make_number (compare), - file, zero, make_number (compare), + = Fcompare_strings (name, zero, make_fixnum (compare), + file, zero, make_fixnum (compare), completion_ignore_case ? Qt : Qnil); if (!EQ (cmp, Qt)) continue; @@ -714,10 +704,10 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, /* FIXME: This is a copy of the code in Ftry_completion. */ ptrdiff_t compare = min (bestmatchsize, SCHARS (name)); Lisp_Object cmp - = Fcompare_strings (bestmatch, zero, make_number (compare), - name, zero, make_number (compare), + = Fcompare_strings (bestmatch, zero, make_fixnum (compare), + name, zero, make_fixnum (compare), completion_ignore_case ? Qt : Qnil); - ptrdiff_t matchsize = EQ (cmp, Qt) ? compare : eabs (XINT (cmp)) - 1; + ptrdiff_t matchsize = EQ (cmp, Qt) ? compare : eabs (XFIXNUM (cmp)) - 1; if (completion_ignore_case) { @@ -742,13 +732,13 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, == (matchsize + directoryp == SCHARS (bestmatch))) && (cmp = Fcompare_strings (name, zero, - make_number (SCHARS (file)), + make_fixnum (SCHARS (file)), file, zero, Qnil, Qnil), EQ (Qt, cmp)) && (cmp = Fcompare_strings (bestmatch, zero, - make_number (SCHARS (file)), + make_fixnum (SCHARS (file)), file, zero, Qnil, Qnil), @@ -782,8 +772,8 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, it does not require any change to be made. */ if (matchcount == 1 && !NILP (Fequal (bestmatch, file))) return Qt; - bestmatch = Fsubstring (bestmatch, make_number (0), - make_number (bestmatchsize)); + bestmatch = Fsubstring (bestmatch, make_fixnum (0), + make_fixnum (bestmatchsize)); return bestmatch; } @@ -879,28 +869,22 @@ provided: `file-attribute-type', `file-attribute-link-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. - 2. File uid as a string or a number. If a string value cannot be - looked up, a numeric value, either an integer or a float, is returned. + 2. File uid as a string or (if ID-FORMAT is `integer' or a string value + cannot be looked up) as an integer. 3. File gid, likewise. - 4. Last access time, as a list of integers (HIGH LOW USEC PSEC) in the - same style as (current-time). + 4. Last access time, in the style of `current-time'. (See a note below about access time on FAT-based filesystems.) 5. Last modification time, likewise. This is the time of the last change to the file's contents. 6. Last status change time, likewise. This is the time of last change to the file's attributes: owner and group, access mode bits, etc. - 7. Size in bytes. - This is a floating point number if the size is too large for an integer. + 7. Size in bytes, as an integer. 8. File modes, as a string of ten letters or dashes as in ls -l. 9. An unspecified value, present only for backward compatibility. -10. inode number. If it is larger than what an Emacs integer can hold, - this is of the form (HIGH . LOW): first the high bits, then the low 16 bits. - If even HIGH is too large for an Emacs integer, this is instead of the form - (HIGH MIDDLE . LOW): first the high bits, then the middle 24 bits, - and finally the low 16 bits. -11. Filesystem device number. If it is larger than what the Emacs - integer can hold, this is a cons cell, similar to the inode number. +10. inode number, as a nonnegative integer. +11. Filesystem device number, as an integer. +Large integers are bignums, so `eq' might not work on them. On most filesystems, the combination of the inode and the device number uniquely identifies the file. @@ -920,11 +904,12 @@ so last access time will always be midnight of that day. */) return Qnil; /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qfile_attributes); if (!NILP (handler)) - { /* Only pass the extra arg if it is used to help backward compatibility - with old file handlers which do not implement the new arg. --Stef */ + { /* Only pass the extra arg if it is used to help backward + compatibility with old file name handlers which do not + implement the new arg. --Stef */ if (NILP (id_format)) return call2 (handler, Qfile_attributes, filename); else @@ -1022,13 +1007,13 @@ file_attributes (int fd, char const *name, return CALLN (Flist, file_type, - make_number (s.st_nlink), + make_fixnum (s.st_nlink), (uname ? DECODE_SYSTEM (build_unibyte_string (uname)) - : make_fixnum_or_float (s.st_uid)), + : INT_TO_INTEGER (s.st_uid)), (gname ? DECODE_SYSTEM (build_unibyte_string (gname)) - : make_fixnum_or_float (s.st_gid)), + : INT_TO_INTEGER (s.st_gid)), make_lisp_time (get_stat_atime (&s)), make_lisp_time (get_stat_mtime (&s)), make_lisp_time (get_stat_ctime (&s)), @@ -1037,14 +1022,14 @@ file_attributes (int fd, char const *name, files of sizes in the 2-4 GiB range wrap around to negative values, as this is a common bug on older 32-bit platforms. */ - make_fixnum_or_float (sizeof (s.st_size) == 4 - ? s.st_size & 0xffffffffu - : s.st_size), + INT_TO_INTEGER (sizeof (s.st_size) == 4 + ? s.st_size & 0xffffffffu + : s.st_size), make_string (modes, 10), Qt, - INTEGER_TO_CONS (s.st_ino), - INTEGER_TO_CONS (s.st_dev)); + INT_TO_INTEGER (s.st_ino), + INT_TO_INTEGER (s.st_dev)); } DEFUN ("file-attributes-lessp", Ffile_attributes_lessp, Sfile_attributes_lessp, 2, 2, 0, @@ -1071,7 +1056,7 @@ return a list with one element, taken from `user-real-login-name'. */) endpwent (); #endif - if (EQ (users, Qnil)) + if (NILP (users)) /* At least current user is always known. */ users = list1 (Vuser_real_login_name); return users; diff --git a/src/dispextern.h b/src/dispextern.h index 673e1c2fab6..5774e3e9514 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -74,10 +74,13 @@ typedef HDC XImagePtr_or_DC; #ifdef HAVE_NS #include "nsgui.h" +#define FACE_COLOR_TO_PIXEL(face_color, frame) ns_color_index_to_rgba(face_color, frame) /* Following typedef needed to accommodate the MSDOS port, believe it or not. */ typedef struct ns_display_info Display_Info; typedef Pixmap XImagePtr; typedef XImagePtr XImagePtr_or_DC; +#else +#define FACE_COLOR_TO_PIXEL(face_color, frame) face_color #endif #ifdef HAVE_WINDOW_SYSTEM @@ -306,24 +309,24 @@ INLINE int GLYPH_CODE_CHAR (Lisp_Object gc) { return (CONSP (gc) - ? XINT (XCAR (gc)) - : XINT (gc) & MAX_CHAR); + ? XFIXNUM (XCAR (gc)) + : XFIXNUM (gc) & MAX_CHAR); } INLINE int GLYPH_CODE_FACE (Lisp_Object gc) { - return CONSP (gc) ? XINT (XCDR (gc)) : XINT (gc) >> CHARACTERBITS; + return CONSP (gc) ? XFIXNUM (XCDR (gc)) : XFIXNUM (gc) >> CHARACTERBITS; } #define SET_GLYPH_FROM_GLYPH_CODE(glyph, gc) \ do \ { \ if (CONSP (gc)) \ - SET_GLYPH (glyph, XINT (XCAR (gc)), XINT (XCDR (gc))); \ + SET_GLYPH (glyph, XFIXNUM (XCAR (gc)), XFIXNUM (XCDR (gc))); \ else \ - SET_GLYPH (glyph, (XINT (gc) & ((1 << CHARACTERBITS)-1)), \ - (XINT (gc) >> CHARACTERBITS)); \ + SET_GLYPH (glyph, (XFIXNUM (gc) & ((1 << CHARACTERBITS)-1)), \ + (XFIXNUM (gc) >> CHARACTERBITS)); \ } \ while (false) @@ -1837,8 +1840,8 @@ GLYPH_CODE_P (Lisp_Object gc) { return (CONSP (gc) ? (CHARACTERP (XCAR (gc)) - && RANGED_INTEGERP (0, XCDR (gc), MAX_FACE_ID)) - : (RANGED_INTEGERP + && RANGED_FIXNUMP (0, XCDR (gc), MAX_FACE_ID)) + : (RANGED_FIXNUMP (0, gc, (MAX_FACE_ID < TYPE_MAXIMUM (EMACS_INT) >> CHARACTERBITS ? ((EMACS_INT) MAX_FACE_ID << CHARACTERBITS) | MAX_CHAR @@ -2482,7 +2485,7 @@ struct it If `what' is anything else, these two are undefined (will probably hold values for the last IT_CHARACTER or IT_COMPOSITION - traversed by the iterator. + traversed by the iterator). The values are updated by get_next_display_element, so they are out of sync with the value returned by IT_CHARPOS between the @@ -2932,34 +2935,6 @@ struct redisplay_interface #ifdef HAVE_WINDOW_SYSTEM -/* Each image format (JPEG, TIFF, ...) supported is described by - a structure of the type below. */ - -struct image_type -{ - /* Index of a symbol uniquely identifying the image type, e.g., 'jpeg'. */ - int type; - - /* Check that SPEC is a valid image specification for the given - image type. Value is true if SPEC is valid. */ - bool (* valid_p) (Lisp_Object spec); - - /* Load IMG which is used on frame F from information contained in - IMG->spec. Value is true if successful. */ - bool (* load) (struct frame *f, struct image *img); - - /* Free resources of image IMG which is used on frame F. */ - void (* free) (struct frame *f, struct image *img); - - /* Initialization function (used for dynamic loading of image - libraries on Windows), or NULL if none. */ - bool (* init) (void); - - /* Next in list of all supported image types. */ - struct image_type *next; -}; - - /* Structure describing an image. Specific image formats like XBM are converted into this form, so that display only has to deal with this type of image. */ @@ -3429,11 +3404,12 @@ char *choose_face_font (struct frame *, Lisp_Object *, Lisp_Object, #ifdef HAVE_WINDOW_SYSTEM void prepare_face_for_display (struct frame *, struct face *); #endif -int lookup_named_face (struct frame *, Lisp_Object, bool); -int lookup_basic_face (struct frame *, int); +int lookup_named_face (struct window *, struct frame *, Lisp_Object, bool); +int lookup_basic_face (struct window *, struct frame *, int); int smaller_face (struct frame *, int, int); int face_with_height (struct frame *, int, int); -int lookup_derived_face (struct frame *, Lisp_Object, int, bool); +int lookup_derived_face (struct window *, struct frame *, + Lisp_Object, int, bool); void init_frame_faces (struct frame *); void free_frame_faces (struct frame *); void recompute_basic_faces (struct frame *); @@ -3443,7 +3419,7 @@ int face_for_overlay_string (struct window *, ptrdiff_t, ptrdiff_t *, ptrdiff_t, bool, Lisp_Object); int face_at_string_position (struct window *, Lisp_Object, ptrdiff_t, ptrdiff_t, ptrdiff_t *, enum face_id, bool); -int merge_faces (struct frame *, Lisp_Object, int, int); +int merge_faces (struct window *, Lisp_Object, int, int); int compute_char_face (struct frame *, int, Lisp_Object); void free_all_realized_faces (Lisp_Object); extern char unspecified_fg[], unspecified_bg[]; @@ -3462,15 +3438,6 @@ void gamma_correct (struct frame *, COLORREF *); void x_implicitly_set_name (struct frame *, Lisp_Object, Lisp_Object); void x_change_tool_bar_height (struct frame *f, int); -/* The frame used to display a tooltip. - - Note: In a GTK build with non-zero x_gtk_use_system_tooltips, this - variable holds the frame that shows the tooltip, not the frame of - the tooltip itself, so checking whether a frame is a tooltip frame - cannot just compare the frame to what this variable holds. */ -extern Lisp_Object tip_frame; - -extern Window tip_window; extern frame_parm_handler x_frame_parm_handlers[]; extern void start_hourglass (void); @@ -3577,6 +3544,10 @@ extern void create_tty_output (struct frame *); extern struct terminal *init_tty (const char *, const char *, bool); extern void tty_append_glyph (struct it *); +/* All scrolling costs measured in characters. + So no cost can exceed the area of a frame, measured in characters. + Let's hope this is never more than 1000000 characters. */ +enum { SCROLL_INFINITY = 1000000 }; /* Defined in scroll.c */ diff --git a/src/dispnew.c b/src/dispnew.c index 03fac54e05b..55cdaf5de8a 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <unistd.h> #include "lisp.h" +#include "ptr-bounds.h" #include "termchar.h" /* cm.h must come after dispextern.h on Windows. */ #include "dispextern.h" @@ -233,9 +234,7 @@ DEFUN ("dump-redisplay-history", Fdump_redisplay_history, #endif /* GLYPH_DEBUG */ -#if (defined PROFILING \ - && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__) \ - && !HAVE___EXECUTABLE_START) +#if defined PROFILING && !HAVE___EXECUTABLE_START /* This function comes first in the Emacs executable and is used only to estimate the text start for profiling. */ void @@ -1281,7 +1280,7 @@ row_equal_p (struct glyph_row *a, struct glyph_row *b, bool mouse_face_p) with zeros. If GLYPH_DEBUG and ENABLE_CHECKING are in effect, the global variable glyph_pool_count is incremented for each pool allocated. */ -static struct glyph_pool * +static struct glyph_pool * ATTRIBUTE_MALLOC new_glyph_pool (void) { struct glyph_pool *result = xzalloc (sizeof *result); @@ -2509,8 +2508,7 @@ spec_glyph_lookup_face (struct window *w, GLYPH *glyph) /* Convert the glyph's specified face to a realized (cache) face. */ if (lface_id > 0) { - int face_id = merge_faces (XFRAME (w->frame), - Qt, lface_id, DEFAULT_FACE_ID); + int face_id = merge_faces (w, Qt, lface_id, DEFAULT_FACE_ID); SET_GLYPH_FACE (*glyph, face_id); } } @@ -4657,6 +4655,11 @@ scrolling (struct frame *frame) unsigned *new_hash = old_hash + height; int *draw_cost = (int *) (new_hash + height); int *old_draw_cost = draw_cost + height; + old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash); + new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash); + draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost); + old_draw_cost = ptr_bounds_clip (old_draw_cost, + height * sizeof *old_draw_cost); eassert (current_matrix); @@ -4679,8 +4682,7 @@ scrolling (struct frame *frame) { /* This line cannot be redrawn, so don't let scrolling mess it. */ new_hash[i] = old_hash[i]; -#define INFINITY 1000000 /* Taken from scroll.c */ - draw_cost[i] = INFINITY; + draw_cost[i] = SCROLL_INFINITY; } else { @@ -5721,8 +5723,8 @@ additional wait period, in milliseconds; this is for backwards compatibility. if (!NILP (milliseconds)) { - CHECK_NUMBER (milliseconds); - duration += XINT (milliseconds) / 1000.0; + CHECK_FIXNUM (milliseconds); + duration += XFIXNUM (milliseconds) / 1000.0; } if (duration > 0) @@ -5772,9 +5774,18 @@ sit_for (Lisp_Object timeout, bool reading, int display_option) if (INTEGERP (timeout)) { - sec = XINT (timeout); - if (sec <= 0) - return Qt; + if (integer_to_intmax (timeout, &sec)) + { + if (sec <= 0) + return Qt; + sec = min (sec, WAIT_READING_MAX); + } + else + { + if (NILP (Fnatnump (timeout))) + return Qt; + sec = WAIT_READING_MAX; + } nsec = 0; } else if (FLOATP (timeout)) @@ -5832,8 +5843,7 @@ immediately by pending input. */) if (!NILP (force) && !redisplay_dont_pause) specbind (Qredisplay_dont_pause, Qt); redisplay_preserve_echo_area (2); - unbind_to (count, Qnil); - return Qt; + return unbind_to (count, Qt); } @@ -5930,7 +5940,7 @@ pass nil for VARIABLE. */) || n + 20 < ASIZE (state) / 2) /* Add 20 extra so we grow it less often. */ { - state = Fmake_vector (make_number (n + 20), Qlambda); + state = make_vector (n + 20, Qlambda); if (! NILP (variable)) Fset (variable, state); else @@ -6046,7 +6056,7 @@ init_display (void) { Vinitial_window_system = Qx; #ifdef HAVE_X11 - Vwindow_system_version = make_number (11); + Vwindow_system_version = make_fixnum (11); #endif #ifdef USE_NCURSES /* In some versions of ncurses, @@ -6062,7 +6072,7 @@ init_display (void) if (!inhibit_window_system) { Vinitial_window_system = Qw32; - Vwindow_system_version = make_number (1); + Vwindow_system_version = make_fixnum (1); return; } #endif /* HAVE_NTGUI */ @@ -6075,7 +6085,7 @@ init_display (void) ) { Vinitial_window_system = Qns; - Vwindow_system_version = make_number (10); + Vwindow_system_version = make_fixnum (10); return; } #endif @@ -6228,7 +6238,7 @@ syms_of_display (void) defsubr (&Sdump_redisplay_history); #endif - frame_and_buffer_state = Fmake_vector (make_number (20), Qlambda); + frame_and_buffer_state = make_vector (20, Qlambda); staticpro (&frame_and_buffer_state); /* This is the "purpose" slot of a display table. */ diff --git a/src/disptab.h b/src/disptab.h index a8f75f9b084..f7a162898b5 100644 --- a/src/disptab.h +++ b/src/disptab.h @@ -72,14 +72,14 @@ extern struct Lisp_Char_Table *buffer_display_table (void); /* Given BASE and LEN returned by the two previous macros, return nonzero if GLYPH code G is aliased to a different code. */ #define GLYPH_ALIAS_P(base,len,g) \ - (GLYPH_FACE (g) == DEFAULT_FACE_ID && GLYPH_CHAR (g) < (len) && INTEGERP (base[GLYPH_CHAR (g)])) + (GLYPH_FACE (g) == DEFAULT_FACE_ID && GLYPH_CHAR (g) < (len) && FIXNUMP (base[GLYPH_CHAR (g)])) /* Follow all aliases for G in the glyph table given by (BASE, LENGTH), and set G to the final glyph. */ #define GLYPH_FOLLOW_ALIASES(base, length, g) \ do { \ while (GLYPH_ALIAS_P ((base), (length), (g))) \ - SET_GLYPH_CHAR ((g), XINT ((base)[GLYPH_CHAR (g)])); \ + SET_GLYPH_CHAR ((g), XFIXNUM ((base)[GLYPH_CHAR (g)])); \ if (!GLYPH_CHAR_VALID_P (g)) \ SET_GLYPH_CHAR (g, ' '); \ } while (false) diff --git a/src/doc.c b/src/doc.c index 7633b8552bc..04370f7cc62 100644 --- a/src/doc.c +++ b/src/doc.c @@ -86,10 +86,10 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) int offset; EMACS_INT position; Lisp_Object file, tem, pos; - ptrdiff_t count; + ptrdiff_t count = SPECPDL_INDEX (); USE_SAFE_ALLOCA; - if (INTEGERP (filepos)) + if (FIXNUMP (filepos)) { file = Vdoc_file_name; pos = filepos; @@ -102,7 +102,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) else return Qnil; - position = eabs (XINT (pos)); + position = eabs (XFIXNUM (pos)); if (!STRINGP (Vdoc_directory)) return Qnil; @@ -148,7 +148,6 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) return concat3 (cannot_open, file, quote_nl); } } - count = SPECPDL_INDEX (); record_unwind_protect_int (close_file_unwind, fd); /* Seek only to beginning of disk block. */ @@ -204,8 +203,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) } p += nread; } - unbind_to (count, Qnil); - SAFE_FREE (); + SAFE_FREE_UNBIND_TO (count, Qnil); /* Sanity checking. */ if (CONSP (filepos)) @@ -341,7 +339,7 @@ string is passed through `substitute-command-keys'. */) if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) fun = XCDR (fun); if (SUBRP (fun)) - doc = make_number (XSUBR (fun)->doc); + doc = make_fixnum (XSUBR (fun)->doc); else if (MODULE_FUNCTIONP (fun)) doc = XMODULE_FUNCTION (fun)->documentation; else if (COMPILEDP (fun)) @@ -353,7 +351,7 @@ string is passed through `substitute-command-keys'. */) Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING); if (STRINGP (tem)) doc = tem; - else if (NATNUMP (tem) || CONSP (tem)) + else if (FIXNATP (tem) || CONSP (tem)) doc = tem; else return Qnil; @@ -380,7 +378,7 @@ string is passed through `substitute-command-keys'. */) doc = tem; /* Handle a doc reference--but these never come last in the function body, so reject them if they are last. */ - else if ((NATNUMP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem)))) + else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem)))) && !NILP (XCDR (tem1))) doc = tem; else @@ -397,9 +395,9 @@ string is passed through `substitute-command-keys'. */) /* If DOC is 0, it's typically because of a dumped file missing from the DOC file (bug in src/Makefile.in). */ - if (EQ (doc, make_number (0))) + if (EQ (doc, make_fixnum (0))) doc = Qnil; - if (INTEGERP (doc) || CONSP (doc)) + if (FIXNUMP (doc) || CONSP (doc)) { Lisp_Object tem; tem = get_doc_string (doc, 0, 0); @@ -439,9 +437,9 @@ aren't strings. */) documentation_property: tem = Fget (symbol, prop); - if (EQ (tem, make_number (0))) + if (EQ (tem, make_fixnum (0))) tem = Qnil; - if (INTEGERP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem)))) + if (FIXNUMP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem)))) { Lisp_Object doc = tem; tem = get_doc_string (tem, 0, 0); @@ -488,10 +486,10 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1))) { tem = Fcdr (Fcdr (fun)); - if (CONSP (tem) && INTEGERP (XCAR (tem))) + if (CONSP (tem) && FIXNUMP (XCAR (tem))) /* FIXME: This modifies typically pure hash-cons'd data, so its correctness is quite delicate. */ - XSETCAR (tem, make_number (offset)); + XSETCAR (tem, make_fixnum (offset)); } } @@ -505,7 +503,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) /* This bytecode object must have a slot for the docstring, since we've found a docstring for it. */ if (PVSIZE (fun) > COMPILED_DOC_STRING) - ASET (fun, COMPILED_DOC_STRING, make_number (offset)); + ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); else { AUTO_STRING (format, "No docstring slot for %s"); @@ -535,7 +533,6 @@ the same file name is found in the `doc-directory'. */) EMACS_INT pos; Lisp_Object sym; char *p, *name; - bool skip_file = 0; ptrdiff_t count; char const *dirname; ptrdiff_t dirlen; @@ -609,34 +606,24 @@ the same file name is found in the `doc-directory'. */) { end = strchr (p, '\n'); - /* See if this is a file name, and if it is a file in build-files. */ - if (p[1] == 'S') - { - skip_file = 0; - if (end - p > 4 && end[-2] == '.' - && (end[-1] == 'o' || end[-1] == 'c')) - { - ptrdiff_t len = end - p - 2; - char *fromfile = SAFE_ALLOCA (len + 1); - memcpy (fromfile, &p[2], len); - fromfile[len] = 0; - if (fromfile[len-1] == 'c') - fromfile[len-1] = 'o'; - - skip_file = NILP (Fmember (build_string (fromfile), - Vbuild_files)); - } - } + /* We used to skip files not in build_files, so that when a + function was defined several times in different files + (typically, once in xterm, once in w32term, ...), we only + paid attention to the relevant one. + + But this meant the doc had to be kept and updated in + multiple files. Nowadays we keep the doc only in eg xterm. + The (f)boundp checks below ensure we don't report + docs for eg w32-specific items on X. + */ sym = oblookup (Vobarray, p + 2, multibyte_chars_in_text ((unsigned char *) p + 2, end - p - 2), end - p - 2); - /* Check skip_file so that when a function is defined several - times in different files (typically, once in xterm, once in - w32term, ...), we only pay attention to the one that - matters. */ - if (! skip_file && SYMBOLP (sym)) + /* Ignore docs that start with SKIP. These mark + placeholders where the real doc is elsewhere. */ + if (SYMBOLP (sym)) { /* Attach a docstring to a variable? */ if (p[1] == 'V') @@ -644,17 +631,18 @@ the same file name is found in the `doc-directory'. */) /* Install file-position as variable-documentation property and make it negative for a user-variable (doc starts with a `*'). */ - if (!NILP (Fboundp (sym)) + if ((!NILP (Fboundp (sym)) || !NILP (Fmemq (sym, delayed_init))) + && strncmp (end, "\nSKIP", 5)) Fput (sym, Qvariable_documentation, - make_number ((pos + end + 1 - buf) + make_fixnum ((pos + end + 1 - buf) * (end[1] == '*' ? -1 : 1))); } /* Attach a docstring to a function? */ else if (p[1] == 'F') { - if (!NILP (Ffboundp (sym))) + if (!NILP (Ffboundp (sym)) && strncmp (end, "\nSKIP", 5)) store_function_docstring (sym, pos + end + 1 - buf); } else if (p[1] == 'S') @@ -669,8 +657,7 @@ the same file name is found in the `doc-directory'. */) memmove (buf, end, filled); } - SAFE_FREE (); - return unbind_to (count, Qnil); + return SAFE_FREE_UNBIND_TO (count, Qnil); } /* Return true if text quoting style should default to quote `like this'. */ @@ -684,7 +671,7 @@ default_to_grave_quoting_style (void) Lisp_Object dv = DISP_CHAR_VECTOR (XCHAR_TABLE (Vstandard_display_table), LEFT_SINGLE_QUOTATION_MARK); return (VECTORP (dv) && ASIZE (dv) == 1 - && EQ (AREF (dv, 0), make_number ('`'))); + && EQ (AREF (dv, 0), make_fixnum ('`'))); } /* Return the current effective text quoting style. */ diff --git a/src/doprnt.c b/src/doprnt.c index 363eece5c27..d0c703398fa 100644 --- a/src/doprnt.c +++ b/src/doprnt.c @@ -503,7 +503,7 @@ esprintf (char *buf, char const *format, ...) return nbytes; } -#if HAVE_MODULES || (defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT) +#if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT /* Format to buffer *BUF of positive size *BUFSIZE, reallocating *BUF and updating *BUFSIZE if the buffer is too small, and otherwise diff --git a/src/dosfns.c b/src/dosfns.c index cc371ce22c1..47c545007ad 100644 --- a/src/dosfns.c +++ b/src/dosfns.c @@ -66,33 +66,33 @@ REGISTERS should be a vector produced by `make-register' and int no; union REGS inregs, outregs; - CHECK_NUMBER (interrupt); - no = (unsigned long) XINT (interrupt); + CHECK_FIXNUM (interrupt); + no = (unsigned long) XFIXNUM (interrupt); CHECK_VECTOR (registers); if (no < 0 || no > 0xff || ASIZE (registers) != 8) return Qnil; for (i = 0; i < 8; i++) - CHECK_NUMBER (AREF (registers, i)); + CHECK_FIXNUM (AREF (registers, i)); - inregs.x.ax = (unsigned long) XFASTINT (AREF (registers, 0)); - inregs.x.bx = (unsigned long) XFASTINT (AREF (registers, 1)); - inregs.x.cx = (unsigned long) XFASTINT (AREF (registers, 2)); - inregs.x.dx = (unsigned long) XFASTINT (AREF (registers, 3)); - inregs.x.si = (unsigned long) XFASTINT (AREF (registers, 4)); - inregs.x.di = (unsigned long) XFASTINT (AREF (registers, 5)); - inregs.x.cflag = (unsigned long) XFASTINT (AREF (registers, 6)); - inregs.x.flags = (unsigned long) XFASTINT (AREF (registers, 7)); + inregs.x.ax = (unsigned long) XFIXNAT (AREF (registers, 0)); + inregs.x.bx = (unsigned long) XFIXNAT (AREF (registers, 1)); + inregs.x.cx = (unsigned long) XFIXNAT (AREF (registers, 2)); + inregs.x.dx = (unsigned long) XFIXNAT (AREF (registers, 3)); + inregs.x.si = (unsigned long) XFIXNAT (AREF (registers, 4)); + inregs.x.di = (unsigned long) XFIXNAT (AREF (registers, 5)); + inregs.x.cflag = (unsigned long) XFIXNAT (AREF (registers, 6)); + inregs.x.flags = (unsigned long) XFIXNAT (AREF (registers, 7)); int86 (no, &inregs, &outregs); - ASET (registers, 0, make_number (outregs.x.ax)); - ASET (registers, 1, make_number (outregs.x.bx)); - ASET (registers, 2, make_number (outregs.x.cx)); - ASET (registers, 3, make_number (outregs.x.dx)); - ASET (registers, 4, make_number (outregs.x.si)); - ASET (registers, 5, make_number (outregs.x.di)); - ASET (registers, 6, make_number (outregs.x.cflag)); - ASET (registers, 7, make_number (outregs.x.flags)); + ASET (registers, 0, make_fixnum (outregs.x.ax)); + ASET (registers, 1, make_fixnum (outregs.x.bx)); + ASET (registers, 2, make_fixnum (outregs.x.cx)); + ASET (registers, 3, make_fixnum (outregs.x.dx)); + ASET (registers, 4, make_fixnum (outregs.x.si)); + ASET (registers, 5, make_fixnum (outregs.x.di)); + ASET (registers, 6, make_fixnum (outregs.x.cflag)); + ASET (registers, 7, make_fixnum (outregs.x.flags)); return registers; } @@ -106,8 +106,8 @@ Return the updated VECTOR. */) int offs, len; char *buf; - CHECK_NUMBER (address); - offs = (unsigned long) XINT (address); + CHECK_FIXNUM (address); + offs = (unsigned long) XFIXNUM (address); CHECK_VECTOR (vector); len = ASIZE (vector); if (len < 1 || len > 2048 || offs < 0 || offs > 0xfffff - len) @@ -116,7 +116,7 @@ Return the updated VECTOR. */) dosmemget (offs, len, buf); for (i = 0; i < len; i++) - ASET (vector, i, make_number (buf[i])); + ASET (vector, i, make_fixnum (buf[i])); return vector; } @@ -129,8 +129,8 @@ DEFUN ("msdos-memput", Fdos_memput, Sdos_memput, 2, 2, 0, int offs, len; char *buf; - CHECK_NUMBER (address); - offs = (unsigned long) XINT (address); + CHECK_FIXNUM (address); + offs = (unsigned long) XFIXNUM (address); CHECK_VECTOR (vector); len = ASIZE (vector); if (len < 1 || len > 2048 || offs < 0 || offs > 0xfffff - len) @@ -139,8 +139,8 @@ DEFUN ("msdos-memput", Fdos_memput, Sdos_memput, 2, 2, 0, for (i = 0; i < len; i++) { - CHECK_NUMBER (AREF (vector, i)); - buf[i] = (unsigned char) XFASTINT (AREF (vector, i)) & 0xFF; + CHECK_FIXNUM (AREF (vector, i)); + buf[i] = (unsigned char) XFIXNAT (AREF (vector, i)) & 0xFF; } dosmemput (buf, len, offs); @@ -154,8 +154,8 @@ all keys; otherwise it is only used when the ALT key is pressed. The current keyboard layout is available in dos-keyboard-code. */) (Lisp_Object country_code, Lisp_Object allkeys) { - CHECK_NUMBER (country_code); - if (!dos_set_keyboard (XINT (country_code), !NILP (allkeys))) + CHECK_FIXNUM (country_code); + if (!dos_set_keyboard (XFIXNUM (country_code), !NILP (allkeys))) return Qnil; return Qt; } @@ -280,7 +280,7 @@ init_dosfns (void) regs.x.ax = 0x3000; intdos (®s, ®s); - Vdos_version = Fcons (make_number (regs.h.al), make_number (regs.h.ah)); + Vdos_version = Fcons (make_fixnum (regs.h.al), make_fixnum (regs.h.ah)); /* Obtain the country code via DPMI, use DJGPP transfer buffer. */ dpmiregs.x.ax = 0x3800; @@ -341,7 +341,7 @@ init_dosfns (void) { dos_windows_version = dpmiregs.x.ax; Vdos_windows_version = - Fcons (make_number (dpmiregs.h.al), make_number (dpmiregs.h.ah)); + Fcons (make_fixnum (dpmiregs.h.al), make_fixnum (dpmiregs.h.ah)); /* Save the current title of this virtual machine, so we can restore it before exiting. Otherwise, Windows 95 will continue to use @@ -480,11 +480,7 @@ x_set_title (struct frame *f, Lisp_Object name) #endif /* !HAVE_X_WINDOWS */ DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0, - doc: /* Return storage information about the file system FILENAME is on. -Value is a list of floats (TOTAL FREE AVAIL), where TOTAL is the total -storage of the file system, FREE is the free storage, and AVAIL is the -storage available to a non-superuser. All 3 numbers are in bytes. -If the underlying system call fails, value is nil. */) + doc: /* SKIP: real doc in fileio.c. */) (Lisp_Object filename) { struct statfs stfs; @@ -513,7 +509,7 @@ list_system_processes (void) { Lisp_Object proclist = Qnil; - proclist = Fcons (make_fixnum_or_float (getpid ()), proclist); + proclist = Fcons (INT_TO_INTEGER (getpid ()), proclist); return proclist; } @@ -524,8 +520,8 @@ system_process_attributes (Lisp_Object pid) int proc_id; Lisp_Object attrs = Qnil; - CHECK_NUMBER_OR_FLOAT (pid); - proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XINT (pid); + CHECK_NUMBER (pid); + proc_id = XFLOATINT (pid); if (proc_id == getpid ()) { @@ -543,12 +539,12 @@ system_process_attributes (Lisp_Object pid) #endif uid = getuid (); - attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs); + attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs); usr = getlogin (); if (usr) attrs = Fcons (Fcons (Quser, build_string (usr)), attrs); gid = getgid (); - attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs); + attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs); gr = getgrgid (gid); if (gr) attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs); @@ -559,18 +555,18 @@ system_process_attributes (Lisp_Object pid) Vlocale_coding_system, 0); attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs); /* Pretend we have 0 as PPID. */ - attrs = Fcons (Fcons (Qppid, make_number (0)), attrs); + attrs = Fcons (Fcons (Qppid, make_fixnum (0)), attrs); attrs = Fcons (Fcons (Qpgrp, pid), attrs); attrs = Fcons (Fcons (Qttname, build_string ("/dev/tty")), attrs); /* We are never idle! */ tem = Fget_internal_run_time (); attrs = Fcons (Fcons (Qtime, tem), attrs); - attrs = Fcons (Fcons (Qthcount, make_number (1)), attrs); + attrs = Fcons (Fcons (Qthcount, make_fixnum (1)), attrs); attrs = Fcons (Fcons (Qstart, Fsymbol_value (intern ("before-init-time"))), attrs); attrs = Fcons (Fcons (Qvsize, - make_fixnum_or_float ((unsigned long)sbrk (0)/1024)), + INT_TO_INTEGER ((unsigned long) sbrk (0) / 1024)), attrs); attrs = Fcons (Fcons (Qetime, tem), attrs); #ifndef SYSTEM_MALLOC diff --git a/src/dynlib.c b/src/dynlib.c index 45b85353325..878044558a6 100644 --- a/src/dynlib.c +++ b/src/dynlib.c @@ -156,9 +156,8 @@ dynlib_addr (void *addr, const char **fname, const char **symname) address we pass to it is not an address of a string, but an address of a function. So we don't care about the Unicode version. */ - s_pfn_Get_Module_HandleExA = - (GetModuleHandleExA_Proc) GetProcAddress (hm_kernel32, - "GetModuleHandleExA"); + s_pfn_Get_Module_HandleExA = (GetModuleHandleExA_Proc) + get_proc_addr (hm_kernel32, "GetModuleHandleExA"); } if (s_pfn_Get_Module_HandleExA) { diff --git a/src/editfns.c b/src/editfns.c index f5edbb71d2e..028fec8d092 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -35,57 +35,26 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" -/* systime.h includes <sys/time.h> which, on some systems, is required - for <sys/resource.h>; thus systime.h must be included before - <sys/resource.h> */ -#include "systime.h" - -#if defined HAVE_SYS_RESOURCE_H -#include <sys/resource.h> -#endif - -#include <errno.h> #include <float.h> #include <limits.h> +#include <math.h> #include <c-ctype.h> #include <intprops.h> #include <stdlib.h> -#include <strftime.h> #include <verify.h> #include "composite.h" #include "intervals.h" +#include "ptr-bounds.h" #include "character.h" #include "buffer.h" -#include "coding.h" #include "window.h" #include "blockinput.h" -#define TM_YEAR_BASE 1900 - -#ifdef WINDOWSNT -extern Lisp_Object w32_get_internal_run_time (void); -#endif - -static struct lisp_time lisp_time_struct (Lisp_Object, int *); -static Lisp_Object format_time_string (char const *, ptrdiff_t, struct timespec, - Lisp_Object, struct tm *); -static long int tm_gmtoff (struct tm *); -static int tm_diff (struct tm *, struct tm *); static void update_buffer_properties (ptrdiff_t, ptrdiff_t); static Lisp_Object styled_format (ptrdiff_t, Lisp_Object *, bool); -#ifndef HAVE_TM_GMTOFF -# define HAVE_TM_GMTOFF false -#endif - -enum { tzeqlen = sizeof "TZ=" - 1 }; - -/* Time zones equivalent to current local time and to UTC, respectively. */ -static timezone_t local_tz; -static timezone_t const utc_tz = 0; - /* 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; @@ -97,141 +66,9 @@ init_and_cache_system_name (void) cached_system_name = Vsystem_name; } -static struct tm * -emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm) -{ - tm = localtime_rz (tz, t, tm); - if (!tm && errno == ENOMEM) - memory_full (SIZE_MAX); - return tm; -} - -static time_t -emacs_mktime_z (timezone_t tz, struct tm *tm) -{ - errno = 0; - time_t t = mktime_z (tz, tm); - if (t == (time_t) -1 && errno == ENOMEM) - memory_full (SIZE_MAX); - return t; -} - -/* Allocate a timezone, signaling on failure. */ -static timezone_t -xtzalloc (char const *name) -{ - timezone_t tz = tzalloc (name); - if (!tz) - memory_full (SIZE_MAX); - return tz; -} - -/* Free a timezone, except do not free the time zone for local time. - Freeing utc_tz is also a no-op. */ -static void -xtzfree (timezone_t tz) -{ - if (tz != local_tz) - tzfree (tz); -} - -/* Convert the Lisp time zone rule ZONE to a timezone_t object. - The returned value either is 0, or is LOCAL_TZ, or is newly allocated. - If SETTZ, set Emacs local time to the time zone rule; otherwise, - the caller should eventually pass the returned value to xtzfree. */ -static timezone_t -tzlookup (Lisp_Object zone, bool settz) -{ - 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; - - if (NILP (zone)) - return local_tz; - else if (EQ (zone, Qt)) - { - zone_string = "UTC0"; - new_tz = utc_tz; - } - else - { - bool plain_integer = INTEGERP (zone); - - if (EQ (zone, Qwall)) - zone_string = 0; - else if (STRINGP (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 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, - XINT (zone) < 0 ? -numzone : 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"), - zone); - new_tz = xtzalloc (zone_string); - } - - if (settz) - { - block_input (); - emacs_setenv_TZ (zone_string); - tzset (); - timezone_t old_tz = local_tz; - local_tz = new_tz; - tzfree (old_tz); - unblock_input (); - } - - return new_tz; -} - void -init_editfns (bool dumping) +init_editfns (void) { -#if !defined CANNOT_DUMP - /* 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 */ @@ -240,37 +77,6 @@ init_editfns (bool dumping) /* Set up system_name even when dumping. */ init_and_cache_system_name (); -#ifndef CANNOT_DUMP - /* When just dumping out, set the time zone to a known unlikely value - and skip the rest of this function. */ - if (dumping) - { - xputenv (dump_tz_string); - tzset (); - return; - } -#endif - - char *tz = getenv ("TZ"); - -#if !defined CANNOT_DUMP - /* If the execution TZ happens to be the same as the dump TZ, - change it to some other value and then change it back, - to force the underlying implementation to reload the TZ info. - This is needed on implementations that load TZ info from files, - since the TZ file contents may differ between dump and execution. */ - if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0) - { - ++*tz; - tzset (); - --*tz; - } -#endif - - /* Set the time zone rule now, so that the call to putenv is done - before multiple threads are active. */ - tzlookup (tz ? build_string (tz) : Qwall, true); - pw = getpwuid (getuid ()); #ifdef MSDOS /* We let the real user name default to "root" because that's quite @@ -305,7 +111,7 @@ init_editfns (bool dumping) else { uid_t euid = geteuid (); - tem = make_fixnum_or_float (euid); + tem = INT_TO_INTEGER (euid); } Vuser_full_name = Fuser_full_name (tem); @@ -335,7 +141,7 @@ usage: (char-to-string CHAR) */) unsigned char str[MAX_MULTIBYTE_LENGTH]; CHECK_CHARACTER (character); - c = XFASTINT (character); + c = XFIXNAT (character); len = CHAR_STRING (c, str); return make_string_from_bytes ((char *) str, 1, len); @@ -346,10 +152,10 @@ DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0, (Lisp_Object byte) { unsigned char b; - CHECK_NUMBER (byte); - if (XINT (byte) < 0 || XINT (byte) > 255) + CHECK_FIXNUM (byte); + if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255) error ("Invalid byte"); - b = XINT (byte); + b = XFIXNUM (byte); return make_string_from_bytes ((char *) &b, 1, 1); } @@ -397,8 +203,8 @@ The return value is POSITION. */) { if (MARKERP (position)) set_point_from_marker (position); - else if (INTEGERP (position)) - SET_PT (clip_to_bounds (BEGV, XINT (position), ZV)); + else if (FIXNUMP (position)) + SET_PT (clip_to_bounds (BEGV, XFIXNUM (position), ZV)); else wrong_type_argument (Qinteger_or_marker_p, position); return position; @@ -424,9 +230,9 @@ region_limit (bool beginningp) error ("The mark is not set now, so there is no region"); /* Clip to the current narrowing (bug#11770). */ - return make_number ((PT < XFASTINT (m)) == beginningp + return make_fixnum ((PT < XFIXNAT (m)) == beginningp ? PT - : clip_to_bounds (BEGV, XFASTINT (m), ZV)); + : clip_to_bounds (BEGV, XFIXNAT (m), ZV)); } DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0, @@ -460,21 +266,18 @@ If you set the marker not to point anywhere, the buffer will have no mark. */) static ptrdiff_t overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len) { - Lisp_Object overlay, start, end; - struct Lisp_Overlay *tail; - ptrdiff_t startpos, endpos; ptrdiff_t idx = 0; - for (tail = current_buffer->overlays_before; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { - XSETMISC (overlay, tail); - - end = OVERLAY_END (overlay); - endpos = OVERLAY_POSITION (end); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object end = OVERLAY_END (overlay); + ptrdiff_t endpos = OVERLAY_POSITION (end); if (endpos < pos) break; - start = OVERLAY_START (overlay); - startpos = OVERLAY_POSITION (start); + Lisp_Object start = OVERLAY_START (overlay); + ptrdiff_t startpos = OVERLAY_POSITION (start); if (startpos <= pos) { if (idx < len) @@ -484,16 +287,16 @@ overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len) } } - for (tail = current_buffer->overlays_after; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { - XSETMISC (overlay, tail); - - start = OVERLAY_START (overlay); - startpos = OVERLAY_POSITION (start); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object start = OVERLAY_START (overlay); + ptrdiff_t startpos = OVERLAY_POSITION (start); if (pos < startpos) break; - end = OVERLAY_END (overlay); - endpos = OVERLAY_POSITION (end); + Lisp_Object end = OVERLAY_END (overlay); + ptrdiff_t endpos = OVERLAY_POSITION (end); if (pos <= endpos) { if (idx < len) @@ -515,7 +318,7 @@ i.e. the property that a char would inherit if it were inserted at POSITION. */) (Lisp_Object position, register Lisp_Object prop, Lisp_Object object) { - CHECK_NUMBER_COERCE_MARKER (position); + CHECK_FIXNUM_COERCE_MARKER (position); if (NILP (object)) XSETBUFFER (object, current_buffer); @@ -529,7 +332,7 @@ at POSITION. */) return Fget_text_property (position, prop, object); else { - EMACS_INT posn = XINT (position); + EMACS_INT posn = XFIXNUM (position); ptrdiff_t noverlays; Lisp_Object *overlay_vec, tem; struct buffer *obuf = current_buffer; @@ -582,8 +385,8 @@ at POSITION. */) if (stickiness > 0) return Fget_text_property (position, prop, object); else if (stickiness < 0 - && XINT (position) > BUF_BEGV (XBUFFER (object))) - return Fget_text_property (make_number (XINT (position) - 1), + && XFIXNUM (position) > BUF_BEGV (XBUFFER (object))) + return Fget_text_property (make_fixnum (XFIXNUM (position) - 1), prop, object); else return Qnil; @@ -626,13 +429,13 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, if (NILP (pos)) XSETFASTINT (pos, PT); else - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); after_field = get_char_property_and_overlay (pos, Qfield, Qnil, NULL); before_field - = (XFASTINT (pos) > BEGV - ? get_char_property_and_overlay (make_number (XINT (pos) - 1), + = (XFIXNAT (pos) > BEGV + ? get_char_property_and_overlay (make_fixnum (XFIXNUM (pos) - 1), Qfield, Qnil, NULL) /* Using nil here would be a more obvious choice, but it would fail when the buffer starts with a non-sticky field. */ @@ -686,7 +489,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, if (at_field_start) /* POS is at the edge of a field, and we should consider it as the beginning of the following field. */ - *beg = XFASTINT (pos); + *beg = XFIXNAT (pos); else /* Find the previous field boundary. */ { @@ -698,7 +501,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, p = Fprevious_single_char_property_change (p, Qfield, Qnil, beg_limit); - *beg = NILP (p) ? BEGV : XFASTINT (p); + *beg = NILP (p) ? BEGV : XFIXNAT (p); } } @@ -707,7 +510,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, if (at_field_end) /* POS is at the edge of a field, and we should consider it as the end of the previous field. */ - *end = XFASTINT (pos); + *end = XFIXNAT (pos); else /* Find the next field boundary. */ { @@ -718,7 +521,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, pos = Fnext_single_char_property_change (pos, Qfield, Qnil, end_limit); - *end = NILP (pos) ? ZV : XFASTINT (pos); + *end = NILP (pos) ? ZV : XFIXNAT (pos); } } } @@ -771,7 +574,7 @@ is before LIMIT, then LIMIT will be returned instead. */) { ptrdiff_t beg; find_field (pos, escape_from_edge, limit, &beg, Qnil, 0); - return make_number (beg); + return make_fixnum (beg); } DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0, @@ -786,7 +589,7 @@ is after LIMIT, then LIMIT will be returned instead. */) { ptrdiff_t end; find_field (pos, escape_from_edge, Qnil, 0, limit, &end); - return make_number (end); + return make_fixnum (end); } DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0, @@ -832,13 +635,13 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) XSETFASTINT (new_pos, PT); } - CHECK_NUMBER_COERCE_MARKER (new_pos); - CHECK_NUMBER_COERCE_MARKER (old_pos); + CHECK_FIXNUM_COERCE_MARKER (new_pos); + CHECK_FIXNUM_COERCE_MARKER (old_pos); - fwd = (XINT (new_pos) > XINT (old_pos)); + fwd = (XFIXNUM (new_pos) > XFIXNUM (old_pos)); - prev_old = make_number (XINT (old_pos) - 1); - prev_new = make_number (XINT (new_pos) - 1); + prev_old = make_fixnum (XFIXNUM (old_pos) - 1); + prev_new = make_fixnum (XFIXNUM (new_pos) - 1); if (NILP (Vinhibit_field_text_motion) && !EQ (new_pos, old_pos) @@ -848,16 +651,16 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) previous positions; we could use `Fget_pos_property' instead, but in itself that would fail inside non-sticky fields (like comint prompts). */ - || (XFASTINT (new_pos) > BEGV + || (XFIXNAT (new_pos) > BEGV && !NILP (Fget_char_property (prev_new, Qfield, Qnil))) - || (XFASTINT (old_pos) > BEGV + || (XFIXNAT (old_pos) > BEGV && !NILP (Fget_char_property (prev_old, Qfield, Qnil)))) && (NILP (inhibit_capture_property) /* Field boundaries are again a problem; but now we must decide the case exactly, so we need to call `get_pos_property' as well. */ || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil)) - && (XFASTINT (old_pos) <= BEGV + && (XFIXNAT (old_pos) <= BEGV || NILP (Fget_char_property (old_pos, inhibit_capture_property, Qnil)) || NILP (Fget_char_property @@ -877,7 +680,7 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) other side of NEW_POS, which would mean that NEW_POS is already acceptable, and it's not necessary to constrain it to FIELD_BOUND. */ - ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd) + ((XFIXNAT (field_bound) < XFIXNAT (new_pos)) ? fwd : !fwd) /* NEW_POS should be constrained, but only if either ONLY_IN_LINE is nil (in which case any constraint is OK), or NEW_POS and FIELD_BOUND are on the same line (in which @@ -886,16 +689,16 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) /* This is the ONLY_IN_LINE case, check that NEW_POS and FIELD_BOUND are on the same line by seeing whether there's an intervening newline or not. */ - || (find_newline (XFASTINT (new_pos), -1, - XFASTINT (field_bound), -1, + || (find_newline (XFIXNAT (new_pos), -1, + XFIXNAT (field_bound), -1, fwd ? -1 : 1, &shortage, NULL, 1), shortage != 0))) /* Constrain NEW_POS to FIELD_BOUND. */ new_pos = field_bound; - if (orig_point && XFASTINT (new_pos) != orig_point) + if (orig_point && XFIXNAT (new_pos) != orig_point) /* The NEW_POS argument was originally nil, so automatically set PT. */ - SET_PT (XFASTINT (new_pos)); + SET_PT (XFIXNAT (new_pos)); } return new_pos; @@ -926,13 +729,13 @@ This function does not move point. */) if (NILP (n)) XSETFASTINT (n, 1); else - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - scan_newline_from_point (XINT (n) - 1, &charpos, &bytepos); + scan_newline_from_point (XFIXNUM (n) - 1, &charpos, &bytepos); /* Return END constrained to the current input field. */ - return Fconstrain_to_field (make_number (charpos), make_number (PT), - XINT (n) != 1 ? Qt : Qnil, + return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT), + XFIXNUM (n) != 1 ? Qt : Qnil, Qt, Qnil); } @@ -961,69 +764,57 @@ This function does not move point. */) if (NILP (n)) XSETFASTINT (n, 1); else - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX); + clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XFIXNUM (n), PTRDIFF_MAX); end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0), NULL); /* Return END_POS constrained to the current input field. */ - return Fconstrain_to_field (make_number (end_pos), make_number (orig), + return Fconstrain_to_field (make_fixnum (end_pos), make_fixnum (orig), Qnil, Qt, Qnil); } -/* Save current buffer state for `save-excursion' special form. - We (ab)use Lisp_Misc_Save_Value to allow explicit free and so - offload some work from GC. */ +/* Save current buffer state for save-excursion special form. */ -Lisp_Object -save_excursion_save (void) +void +save_excursion_save (union specbinding *pdl) { - return make_save_obj_obj_obj_obj - (Fpoint_marker (), - Qnil, - /* Selected window if current buffer is shown in it, nil otherwise. */ - (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ()) - ? selected_window : Qnil), - Qnil); + eassert (pdl->unwind_excursion.kind == SPECPDL_UNWIND_EXCURSION); + pdl->unwind_excursion.marker = Fpoint_marker (); + /* Selected window if current buffer is shown in it, nil otherwise. */ + pdl->unwind_excursion.window + = (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ()) + ? selected_window : Qnil); } /* Restore saved buffer before leaving `save-excursion' special form. */ void -save_excursion_restore (Lisp_Object info) +save_excursion_restore (Lisp_Object marker, Lisp_Object window) { - Lisp_Object tem, tem1; - - tem = Fmarker_buffer (XSAVE_OBJECT (info, 0)); + Lisp_Object buffer = Fmarker_buffer (marker); /* If we're unwinding to top level, saved buffer may be deleted. This - means that all of its markers are unchained and so tem is nil. */ - if (NILP (tem)) - goto out; + means that all of its markers are unchained and so BUFFER is nil. */ + if (NILP (buffer)) + return; - Fset_buffer (tem); + Fset_buffer (buffer); /* Point marker. */ - tem = XSAVE_OBJECT (info, 0); - Fgoto_char (tem); - unchain_marker (XMARKER (tem)); + Fgoto_char (marker); + unchain_marker (XMARKER (marker)); /* If buffer was visible in a window, and a different window was selected, and the old selected window is still showing this buffer, restore point in that window. */ - tem = XSAVE_OBJECT (info, 2); - if (WINDOWP (tem) - && !EQ (tem, selected_window) - && (tem1 = XWINDOW (tem)->contents, - (/* Window is live... */ - BUFFERP (tem1) - /* ...and it shows the current buffer. */ - && XBUFFER (tem1) == current_buffer))) - Fset_window_point (tem, make_number (PT)); - - out: - - free_misc (info); + if (WINDOWP (window) && !EQ (window, selected_window)) + { + /* Set window point if WINDOW is live and shows the current buffer. */ + Lisp_Object contents = XWINDOW (window)->contents; + if (BUFFERP (contents) && XBUFFER (contents) == current_buffer) + Fset_window_point (window, make_fixnum (PT)); + } } DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0, @@ -1045,7 +836,7 @@ usage: (save-excursion &rest BODY) */) register Lisp_Object val; ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); val = Fprogn (args); return unbind_to (count, val); @@ -1076,11 +867,11 @@ in some other BUFFER, use (Lisp_Object buffer) { if (NILP (buffer)) - return make_number (Z - BEG); + return make_fixnum (Z - BEG); else { CHECK_BUFFER (buffer); - return make_number (BUF_Z (XBUFFER (buffer)) + return make_fixnum (BUF_Z (XBUFFER (buffer)) - BUF_BEG (XBUFFER (buffer))); } } @@ -1148,10 +939,10 @@ DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0, If POSITION is out of range, the value is nil. */) (Lisp_Object position) { - CHECK_NUMBER_COERCE_MARKER (position); - if (XINT (position) < BEG || XINT (position) > Z) + CHECK_FIXNUM_COERCE_MARKER (position); + if (XFIXNUM (position) < BEG || XFIXNUM (position) > Z) return Qnil; - return make_number (CHAR_TO_BYTE (XINT (position))); + return make_fixnum (CHAR_TO_BYTE (XFIXNUM (position))); } DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0, @@ -1161,8 +952,8 @@ If BYTEPOS is out of range, the value is nil. */) { ptrdiff_t pos_byte; - CHECK_NUMBER (bytepos); - pos_byte = XINT (bytepos); + CHECK_FIXNUM (bytepos); + pos_byte = XFIXNUM (bytepos); if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE) return Qnil; if (Z != Z_BYTE) @@ -1172,7 +963,7 @@ If BYTEPOS is out of range, the value is nil. */) character. */ while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte))) pos_byte--; - return make_number (BYTE_TO_CHAR (pos_byte)); + return make_fixnum (BYTE_TO_CHAR (pos_byte)); } DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0, @@ -1257,10 +1048,10 @@ If POS is out of range, the value is nil. */) if (NILP (pos)) { pos_byte = PT_BYTE; - XSETFASTINT (pos, PT); + if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE) + return Qnil; } - - if (MARKERP (pos)) + else if (MARKERP (pos)) { pos_byte = marker_byte_position (pos); if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE) @@ -1268,14 +1059,14 @@ If POS is out of range, the value is nil. */) } else { - CHECK_NUMBER_COERCE_MARKER (pos); - if (XINT (pos) < BEGV || XINT (pos) >= ZV) + CHECK_FIXNUM_COERCE_MARKER (pos); + if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) >= ZV) return Qnil; - pos_byte = CHAR_TO_BYTE (XINT (pos)); + pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); } - return make_number (FETCH_CHAR (pos_byte)); + return make_fixnum (FETCH_CHAR (pos_byte)); } DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0, @@ -1302,12 +1093,12 @@ If POS is out of range, the value is nil. */) } else { - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); - if (XINT (pos) <= BEGV || XINT (pos) > ZV) + if (XFIXNUM (pos) <= BEGV || XFIXNUM (pos) > ZV) return Qnil; - pos_byte = CHAR_TO_BYTE (XINT (pos)); + pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); } if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) @@ -1329,7 +1120,7 @@ This is based on the effective uid, not the real uid. Also, if the environment variables LOGNAME or USER are set, that determines the value of this function. -If optional argument UID is an integer or a float, return the login name +If optional argument UID is an integer, return the login name of the user with that uid, or nil if there is no such user. */) (Lisp_Object uid) { @@ -1340,7 +1131,7 @@ of the user with that uid, or nil if there is no such user. */) (That can happen if Emacs is dumpable but you decide to run `temacs -l loadup' and not dump. */ if (NILP (Vuser_login_name)) - init_editfns (false); + init_editfns (); if (NILP (uid)) return Vuser_login_name; @@ -1363,44 +1154,62 @@ This ignores the environment variables LOGNAME and USER, so it differs from (That can happen if Emacs is dumpable but you decide to run `temacs -l loadup' and not dump. */ if (NILP (Vuser_login_name)) - init_editfns (false); + init_editfns (); return Vuser_real_login_name; } DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0, doc: /* Return the effective uid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { uid_t euid = geteuid (); - return make_fixnum_or_float (euid); + return INT_TO_INTEGER (euid); } DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0, doc: /* Return the real uid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { uid_t uid = getuid (); - return make_fixnum_or_float (uid); + return INT_TO_INTEGER (uid); +} + +DEFUN ("group-name", Fgroup_name, Sgroup_name, 1, 1, 0, + doc: /* Return the name of the group whose numeric group ID is GID. +The argument GID should be an integer or a float. +Return nil if a group with such GID does not exists or is not known. */) + (Lisp_Object gid) +{ + struct group *gr; + gid_t id; + + if (!NUMBERP (gid) && !CONSP (gid)) + error ("Invalid GID specification"); + CONS_TO_INTEGER (gid, gid_t, id); + block_input (); + gr = getgrgid (id); + unblock_input (); + return gr ? build_string (gr->gr_name) : Qnil; } DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0, doc: /* Return the effective gid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { gid_t egid = getegid (); - return make_fixnum_or_float (egid); + return INT_TO_INTEGER (egid); } DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0, doc: /* Return the real gid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { gid_t gid = getgid (); - return make_fixnum_or_float (gid); + return INT_TO_INTEGER (gid); } DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0, @@ -1408,7 +1217,7 @@ DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0, If the full name corresponding to Emacs's userid is not known, return "unknown". -If optional argument UID is an integer or float, return the full name +If optional argument UID is an integer, return the full name of the user with that uid, or nil if there is no such user. If UID is a string, return the full name of the user with that login name, or nil if there is no such user. */) @@ -1451,7 +1260,7 @@ name, or nil if there is no such user. */) /* Substitute the login name for the &, upcasing the first character. */ if (q) { - Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid)); + Lisp_Object login = Fuser_login_name (make_fixnum (pw->pw_uid)); USE_SAFE_ALLOCA; char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1); memcpy (r, p, q - p); @@ -1476,1028 +1285,14 @@ DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0, } DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0, - doc: /* Return the process ID of Emacs, as a number. */) + doc: /* Return the process ID of Emacs, as a number. +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { pid_t pid = getpid (); - return make_fixnum_or_float (pid); -} - - - -#ifndef TIME_T_MIN -# define TIME_T_MIN TYPE_MINIMUM (time_t) -#endif -#ifndef TIME_T_MAX -# define TIME_T_MAX TYPE_MAXIMUM (time_t) -#endif - -/* Report that a time value is out of range for Emacs. */ -void -time_overflow (void) -{ - error ("Specified time is not representable"); -} - -static _Noreturn void -invalid_time (void) -{ - error ("Invalid time specification"); -} - -/* Check a return value compatible with that of decode_time_components. */ -static void -check_time_validity (int validity) -{ - if (validity <= 0) - { - if (validity < 0) - time_overflow (); - else - invalid_time (); - } -} - -/* Return the upper part of the time T (everything but the bottom 16 bits). */ -static EMACS_INT -hi_time (time_t t) -{ - time_t hi = t >> LO_TIME_BITS; - if (FIXNUM_OVERFLOW_P (hi)) - time_overflow (); - return hi; -} - -/* Return the bottom bits of the time T. */ -static int -lo_time (time_t t) -{ - return t & ((1 << LO_TIME_BITS) - 1); -} - -DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0, - doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00. -The time is returned as a list of integers (HIGH LOW USEC PSEC). -HIGH has the most significant bits of the seconds, while LOW has the -least significant 16 bits. USEC and PSEC are the microsecond and -picosecond counts. */) - (void) -{ - return make_lisp_time (current_timespec ()); -} - -static struct lisp_time -time_add (struct lisp_time ta, struct lisp_time tb) -{ - EMACS_INT hi = ta.hi + tb.hi; - int lo = ta.lo + tb.lo; - int us = ta.us + tb.us; - int ps = ta.ps + tb.ps; - us += (1000000 <= ps); - ps -= (1000000 <= ps) * 1000000; - lo += (1000000 <= us); - us -= (1000000 <= us) * 1000000; - hi += (1 << LO_TIME_BITS <= lo); - lo -= (1 << LO_TIME_BITS <= lo) << LO_TIME_BITS; - return (struct lisp_time) { hi, lo, us, ps }; -} - -static struct lisp_time -time_subtract (struct lisp_time ta, struct lisp_time tb) -{ - EMACS_INT hi = ta.hi - tb.hi; - int lo = ta.lo - tb.lo; - int us = ta.us - tb.us; - int ps = ta.ps - tb.ps; - us -= (ps < 0); - ps += (ps < 0) * 1000000; - lo -= (us < 0); - us += (us < 0) * 1000000; - hi -= (lo < 0); - lo += (lo < 0) << LO_TIME_BITS; - return (struct lisp_time) { hi, lo, us, ps }; -} - -static Lisp_Object -time_arith (Lisp_Object a, Lisp_Object b, - struct lisp_time (*op) (struct lisp_time, struct lisp_time)) -{ - int alen, blen; - 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 (FIXNUM_OVERFLOW_P (t.hi)) - time_overflow (); - Lisp_Object val = Qnil; - - switch (max (alen, blen)) - { - default: - val = Fcons (make_number (t.ps), val); - FALLTHROUGH; - case 3: - val = Fcons (make_number (t.us), val); - FALLTHROUGH; - case 2: - val = Fcons (make_number (t.lo), val); - val = Fcons (make_number (t.hi), val); - break; - } - - return val; + return INT_TO_INTEGER (pid); } -DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0, - doc: /* Return the sum of two time values A and B, as a time value. -A nil value for either argument stands for the current time. -See `current-time-string' for the various forms of a time value. */) - (Lisp_Object a, Lisp_Object b) -{ - return time_arith (a, b, time_add); -} - -DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0, - doc: /* Return the difference between two time values A and B, as a time value. -Use `float-time' to convert the difference into elapsed seconds. -A nil value for either argument stands for the current time. -See `current-time-string' for the various forms of a time value. */) - (Lisp_Object a, Lisp_Object b) -{ - return time_arith (a, b, time_subtract); -} - -DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0, - doc: /* Return non-nil if time value T1 is earlier than time value T2. -A nil value for either argument stands for the current time. -See `current-time-string' for the various forms of a time value. */) - (Lisp_Object t1, Lisp_Object t2) -{ - int t1len, t2len; - struct lisp_time a = lisp_time_struct (t1, &t1len); - struct lisp_time b = lisp_time_struct (t2, &t2len); - return ((a.hi != b.hi ? a.hi < b.hi - : a.lo != b.lo ? a.lo < b.lo - : a.us != b.us ? a.us < b.us - : a.ps < b.ps) - ? Qt : Qnil); -} - - -DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time, - 0, 0, 0, - doc: /* Return the current run time used by Emacs. -The time is returned as a list (HIGH LOW USEC PSEC), using the same -style as (current-time). - -On systems that can't determine the run time, `get-internal-run-time' -does the same thing as `current-time'. */) - (void) -{ -#ifdef HAVE_GETRUSAGE - struct rusage usage; - time_t secs; - int usecs; - - if (getrusage (RUSAGE_SELF, &usage) < 0) - /* This shouldn't happen. What action is appropriate? */ - xsignal0 (Qerror); - - /* Sum up user time and system time. */ - secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec; - usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec; - if (usecs >= 1000000) - { - usecs -= 1000000; - secs++; - } - return make_lisp_time (make_timespec (secs, usecs * 1000)); -#else /* ! HAVE_GETRUSAGE */ -#ifdef WINDOWSNT - return w32_get_internal_run_time (); -#else /* ! WINDOWSNT */ - return Fcurrent_time (); -#endif /* WINDOWSNT */ -#endif /* HAVE_GETRUSAGE */ -} - - -/* Make a Lisp list that represents the Emacs time T. T may be an - invalid time, with a slightly negative tv_nsec value such as - UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a - correspondingly negative picosecond count. */ -Lisp_Object -make_lisp_time (struct timespec t) -{ - time_t s = t.tv_sec; - int ns = t.tv_nsec; - return list4i (hi_time (s), lo_time (s), ns / 1000, ns % 1000 * 1000); -} - -/* Decode a Lisp list SPECIFIED_TIME that represents a time. - Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values. - Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME - if successful, 0 if unsuccessful. */ -static int -disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh, - Lisp_Object *plow, Lisp_Object *pusec, - Lisp_Object *ppsec) -{ - Lisp_Object high = make_number (0); - Lisp_Object low = specified_time; - Lisp_Object usec = make_number (0); - Lisp_Object psec = make_number (0); - int len = 4; - - if (CONSP (specified_time)) - { - high = XCAR (specified_time); - low = XCDR (specified_time); - if (CONSP (low)) - { - Lisp_Object low_tail = XCDR (low); - low = XCAR (low); - if (CONSP (low_tail)) - { - usec = XCAR (low_tail); - low_tail = XCDR (low_tail); - if (CONSP (low_tail)) - psec = XCAR (low_tail); - else - len = 3; - } - else if (!NILP (low_tail)) - { - usec = low_tail; - len = 3; - } - else - len = 2; - } - else - len = 2; - - /* When combining components, require LOW to be an integer, - as otherwise it would be a pain to add up times. */ - if (! INTEGERP (low)) - return 0; - } - else if (INTEGERP (specified_time)) - len = 2; - - *phigh = high; - *plow = low; - *pusec = usec; - *ppsec = psec; - return len; -} - -/* Convert T into an Emacs time *RESULT, truncating toward minus infinity. - Return true if T is in range, false otherwise. */ -static bool -decode_float_time (double t, struct lisp_time *result) -{ - double lo_multiplier = 1 << LO_TIME_BITS; - double emacs_time_min = MOST_NEGATIVE_FIXNUM * lo_multiplier; - if (! (emacs_time_min <= t && t < -emacs_time_min)) - return false; - - double small_t = t / lo_multiplier; - EMACS_INT hi = small_t; - double t_sans_hi = t - hi * lo_multiplier; - int lo = t_sans_hi; - long double fracps = (t_sans_hi - lo) * 1e12L; -#ifdef INT_FAST64_MAX - int_fast64_t ifracps = fracps; - int us = ifracps / 1000000; - int ps = ifracps % 1000000; -#else - int us = fracps / 1e6L; - int ps = fracps - us * 1e6L; -#endif - us -= (ps < 0); - ps += (ps < 0) * 1000000; - lo -= (us < 0); - us += (us < 0) * 1000000; - hi -= (lo < 0); - lo += (lo < 0) << LO_TIME_BITS; - result->hi = hi; - result->lo = lo; - result->us = us; - result->ps = ps; - return true; -} - -/* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp - list, generate the corresponding time value. - If LOW is floating point, the other components should be zero. - - If RESULT is not null, store into *RESULT the converted time. - If *DRESULT is not null, store into *DRESULT the number of - seconds since the start of the POSIX Epoch. - - Return 1 if successful, 0 if the components are of the - wrong type, and -1 if the time is out of range. */ -int -decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec, - Lisp_Object psec, - struct lisp_time *result, double *dresult) -{ - EMACS_INT hi, lo, us, ps; - if (! (INTEGERP (high) - && INTEGERP (usec) && INTEGERP (psec))) - return 0; - if (! INTEGERP (low)) - { - if (FLOATP (low)) - { - double t = XFLOAT_DATA (low); - if (result && ! decode_float_time (t, result)) - return -1; - if (dresult) - *dresult = t; - return 1; - } - else if (NILP (low)) - { - struct timespec now = current_timespec (); - if (result) - { - result->hi = hi_time (now.tv_sec); - result->lo = lo_time (now.tv_sec); - result->us = now.tv_nsec / 1000; - result->ps = now.tv_nsec % 1000 * 1000; - } - if (dresult) - *dresult = now.tv_sec + now.tv_nsec / 1e9; - return 1; - } - else - return 0; - } - - hi = XINT (high); - lo = XINT (low); - us = XINT (usec); - ps = XINT (psec); - - /* Normalize out-of-range lower-order components by carrying - each overflow into the next higher-order component. */ - us += ps / 1000000 - (ps % 1000000 < 0); - lo += us / 1000000 - (us % 1000000 < 0); - hi += lo >> LO_TIME_BITS; - ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0); - us = us % 1000000 + 1000000 * (us % 1000000 < 0); - lo &= (1 << LO_TIME_BITS) - 1; - - if (result) - { - if (FIXNUM_OVERFLOW_P (hi)) - return -1; - result->hi = hi; - result->lo = lo; - result->us = us; - result->ps = ps; - } - - if (dresult) - { - double dhi = hi; - *dresult = (us * 1e6 + ps) / 1e12 + lo + dhi * (1 << LO_TIME_BITS); - } - - return 1; -} - -struct timespec -lisp_to_timespec (struct lisp_time t) -{ - if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> LO_TIME_BITS <= t.hi : 0 <= t.hi) - && t.hi <= TIME_T_MAX >> LO_TIME_BITS)) - return invalid_timespec (); - time_t s = (t.hi << LO_TIME_BITS) + t.lo; - int ns = t.us * 1000 + t.ps / 1000; - return make_timespec (s, ns); -} - -/* Decode a Lisp list SPECIFIED_TIME that represents a time. - Store its effective length into *PLEN. - If SPECIFIED_TIME is nil, use the current time. - Signal an error if SPECIFIED_TIME does not represent a time. */ -static struct lisp_time -lisp_time_struct (Lisp_Object specified_time, int *plen) -{ - Lisp_Object high, low, usec, psec; - struct lisp_time t; - int len = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec); - if (!len) - invalid_time (); - int val = decode_time_components (high, low, usec, psec, &t, 0); - check_time_validity (val); - *plen = len; - return t; -} - -/* Like lisp_time_struct, except return a struct timespec. - Discard any low-order digits. */ -struct timespec -lisp_time_argument (Lisp_Object specified_time) -{ - int len; - struct lisp_time lt = lisp_time_struct (specified_time, &len); - struct timespec t = lisp_to_timespec (lt); - if (! timespec_valid_p (t)) - time_overflow (); - return t; -} - -/* Like lisp_time_argument, except decode only the seconds part, - and do not check the subseconds part. */ -static time_t -lisp_seconds_argument (Lisp_Object specified_time) -{ - Lisp_Object high, low, usec, psec; - struct lisp_time t; - - int val = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec); - if (val != 0) - { - val = decode_time_components (high, low, make_number (0), - make_number (0), &t, 0); - if (0 < val - && ! ((TYPE_SIGNED (time_t) - ? TIME_T_MIN >> LO_TIME_BITS <= t.hi - : 0 <= t.hi) - && t.hi <= TIME_T_MAX >> LO_TIME_BITS)) - val = -1; - } - check_time_validity (val); - return (t.hi << LO_TIME_BITS) + t.lo; -} - -DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0, - doc: /* Return the current time, as a float number of seconds since the epoch. -If SPECIFIED-TIME is given, it is the time to convert to float -instead of the current time. The argument should have the form -\(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus, -you can use times from `current-time' and from `file-attributes'. -SPECIFIED-TIME can also have the form (HIGH . LOW), but this is -considered obsolete. - -WARNING: Since the result is floating point, it may not be exact. -If precise time stamps are required, use either `current-time', -or (if you need time as a string) `format-time-string'. */) - (Lisp_Object specified_time) -{ - double t; - Lisp_Object high, low, usec, psec; - if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec) - && decode_time_components (high, low, usec, psec, 0, &t))) - invalid_time (); - return make_float (t); -} - -/* Write information into buffer S of size MAXSIZE, according to the - FORMAT of length FORMAT_LEN, using time information taken from *TP. - Use the time zone specified by TZ. - Use NS as the number of nanoseconds in the %N directive. - Return the number of bytes written, not including the terminating - '\0'. If S is NULL, nothing will be written anywhere; so to - determine how many bytes would be written, use NULL for S and - ((size_t) -1) for MAXSIZE. - - This function behaves like nstrftime, except it allows null - bytes in FORMAT and it does not support nanoseconds. */ -static size_t -emacs_nmemftime (char *s, size_t maxsize, const char *format, - size_t format_len, const struct tm *tp, timezone_t tz, int ns) -{ - size_t total = 0; - - /* Loop through all the null-terminated strings in the format - argument. Normally there's just one null-terminated string, but - there can be arbitrarily many, concatenated together, if the - format contains '\0' bytes. nstrftime stops at the first - '\0' byte so we must invoke it separately for each such string. */ - for (;;) - { - size_t len; - size_t result; - - if (s) - s[0] = '\1'; - - result = nstrftime (s, maxsize, format, tp, tz, ns); - - if (s) - { - if (result == 0 && s[0] != '\0') - return 0; - s += result + 1; - } - - maxsize -= result + 1; - total += result; - len = strlen (format); - if (len == format_len) - return total; - total++; - format += len + 1; - format_len -= len + 1; - } -} - -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. 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: - -%Y is the year, %y within the century, %C the century. -%G is the year corresponding to the ISO week, %g within the century. -%m is the numeric month. -%b and %h are the locale's abbreviated month name, %B the full name. - (%h is not supported on MS-Windows.) -%d is the day of the month, zero-padded, %e is blank-padded. -%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6. -%a is the locale's abbreviated name of the day of week, %A the full name. -%U is the week number starting on Sunday, %W starting on Monday, - %V according to ISO 8601. -%j is the day of the year. - -%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 (00-59). -%S is the second (00-59; 00-60 on platforms with leap seconds) -%s is the number of seconds since 1970-01-01 00:00:00 +0000. -%N is the nanosecond, %6N the microsecond, %3N the millisecond, etc. -%Z is the time zone abbreviation, %z is the numeric form. - -%c is the locale's date and time format. -%x is the locale's "preferred" date format. -%D is like "%m/%d/%y". -%F is the ISO 8601 date format (like "%Y-%m-%d"). - -%R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p". -%X is the locale's "preferred" time format. - -Finally, %n is a newline, %t is a tab, %% is a literal %, and -unrecognized %-sequences stand for themselves. - -Certain flags and modifiers are available with some format controls. -The flags are `_', `-', `^' and `#'. For certain characters X, -%_X is like %X, but padded with blanks; %-X is like %X, -but without padding. %^X is like %X, but with all textual -characters up-cased; %#X is like %X, but with letter-case of -all textual characters reversed. -%NX (where N stands for an integer) is like %X, -but takes up at least N (a number) positions. -The modifiers are `E' and `O'. For certain characters X, -%EX is a locale's alternative version of %X; -%OX is like %X, but uses the locale's number symbols. - -For example, to produce full ISO 8601 format, use "%FT%T%z". - -usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */) - (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone) -{ - struct timespec t = lisp_time_argument (timeval); - struct tm tm; - - CHECK_STRING (format_string); - format_string = code_convert_string_norecord (format_string, - Vlocale_coding_system, 1); - return format_time_string (SSDATA (format_string), SBYTES (format_string), - t, zone, &tm); -} - -static Lisp_Object -format_time_string (char const *format, ptrdiff_t formatlen, - struct timespec t, Lisp_Object zone, struct tm *tmp) -{ - char buffer[4000]; - char *buf = buffer; - ptrdiff_t size = sizeof buffer; - size_t len; - int ns = t.tv_nsec; - USE_SAFE_ALLOCA; - - timezone_t tz = tzlookup (zone, false); - /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is - a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz - expects a pointer to time_t value. */ - time_t tsec = t.tv_sec; - tmp = emacs_localtime_rz (tz, &tsec, tmp); - if (! tmp) - { - xtzfree (tz); - time_overflow (); - } - synchronize_system_time_locale (); - - while (true) - { - buf[0] = '\1'; - len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns); - if ((0 < len && len < size) || (len == 0 && buf[0] == '\0')) - break; - - /* Buffer was too small, so make it bigger and try again. */ - len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns); - if (STRING_BYTES_BOUND <= len) - { - xtzfree (tz); - string_overflow (); - } - size = len + 1; - buf = SAFE_ALLOCA (size); - } - - xtzfree (tz); - AUTO_STRING_WITH_LEN (bufstring, buf, len); - Lisp_Object result = code_convert_string_norecord (bufstring, - Vlocale_coding_system, 0); - SAFE_FREE (); - 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 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. - -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 (the UTC offset in seconds) 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 -support. MINUTE is an integer between 0 and 59. HOUR is an integer -between 0 and 23. DAY is an integer between 1 and 31. MONTH is an -integer between 1 and 12. YEAR is an integer indicating the -four-digit year. DOW is the day of week, an integer between 0 and 6, -where 0 is Sunday. DST is t if daylight saving time is in effect, -otherwise nil. UTCOFF is an integer indicating the UTC offset in -seconds, i.e., the number of seconds east of Greenwich. (Note that -Common Lisp has different meanings for DOW and UTCOFF.) - -usage: (decode-time &optional TIME ZONE) */) - (Lisp_Object specified_time, Lisp_Object zone) -{ - time_t time_spec = lisp_seconds_argument (specified_time); - struct tm local_tm, gmt_tm; - timezone_t tz = tzlookup (zone, false); - struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm); - xtzfree (tz); - - if (! (tm - && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year - && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)) - time_overflow (); - - /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */ - EMACS_INT tm_year_base = TM_YEAR_BASE; - - return CALLN (Flist, - make_number (local_tm.tm_sec), - make_number (local_tm.tm_min), - make_number (local_tm.tm_hour), - make_number (local_tm.tm_mday), - make_number (local_tm.tm_mon + 1), - make_number (local_tm.tm_year + tm_year_base), - make_number (local_tm.tm_wday), - local_tm.tm_isdst ? Qt : Qnil, - (HAVE_TM_GMTOFF - ? make_number (tm_gmtoff (&local_tm)) - : gmtime_r (&time_spec, &gmt_tm) - ? make_number (tm_diff (&local_tm, &gmt_tm)) - : Qnil)); -} - -/* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that - the result is representable as an int. */ -static int -check_tm_member (Lisp_Object obj, int offset) -{ - CHECK_NUMBER (obj); - EMACS_INT n = XINT (obj); - int result; - if (INT_SUBTRACT_WRAPV (n, offset, &result)) - time_overflow (); - 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 -`current-time-zone') or an integer (as from `decode-time') applied -without consideration for daylight saving time. - -You can pass more than 7 arguments; then the first six arguments -are used as SECOND through YEAR, and the *last* argument is used as ZONE. -The intervening arguments are ignored. -This feature lets (apply \\='encode-time (decode-time ...)) work. - -Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed; -for example, a DAY of 0 means the day preceding the given month. -Year numbers less than 100 are treated just like other year numbers. -If you want them to stand for years in this century, you must do that yourself. - -Years before 1970 are not guaranteed to work. On some systems, -year values as low as 1901 do work. - -usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - time_t value; - struct tm tm; - Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil); - - tm.tm_sec = check_tm_member (args[0], 0); - tm.tm_min = check_tm_member (args[1], 0); - tm.tm_hour = check_tm_member (args[2], 0); - tm.tm_mday = check_tm_member (args[3], 0); - tm.tm_mon = check_tm_member (args[4], 1); - tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE); - tm.tm_isdst = -1; - - timezone_t tz = tzlookup (zone, false); - value = emacs_mktime_z (tz, &tm); - xtzfree (tz); - - if (value == (time_t) -1) - time_overflow (); - - return list2i (hi_time (value), lo_time (value)); -} - -DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, - 0, 2, 0, - doc: /* Return the current local time, as a human-readable string. -Programs can use this function to decode a time, -since the number of columns in each field is fixed -if the year is in the range 1000-9999. -The format is `Sun Sep 16 01:03:52 1973'. -However, see also the functions `decode-time' and `format-time-string' -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. 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. */) - (Lisp_Object specified_time, Lisp_Object zone) -{ - time_t value = lisp_seconds_argument (specified_time); - timezone_t tz = tzlookup (zone, false); - - /* Convert to a string in ctime format, except without the trailing - newline, and without the 4-digit year limit. Don't use asctime - or ctime, as they might dump core if the year is outside the - range -999 .. 9999. */ - struct tm tm; - struct tm *tmp = emacs_localtime_rz (tz, &value, &tm); - xtzfree (tz); - if (! tmp) - time_overflow (); - - static char const wday_name[][4] = - { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" }; - static char const mon_name[][4] = - { "Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }; - printmax_t year_base = TM_YEAR_BASE; - char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1]; - int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd, - wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday, - tm.tm_hour, tm.tm_min, tm.tm_sec, - tm.tm_year + year_base); - - return make_unibyte_string (buf, len); -} - -/* Yield A - B, measured in seconds. - This function is copied from the GNU C Library. */ -static int -tm_diff (struct tm *a, struct tm *b) -{ - /* Compute intervening leap days correctly even if year is negative. - Take care to avoid int overflow in leap day calculations, - but it's OK to assume that A and B are close to each other. */ - int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3); - int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3); - int a100 = a4 / 25 - (a4 % 25 < 0); - int b100 = b4 / 25 - (b4 % 25 < 0); - int a400 = a100 >> 2; - int b400 = b100 >> 2; - int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400); - int years = a->tm_year - b->tm_year; - int days = (365 * years + intervening_leap_days - + (a->tm_yday - b->tm_yday)); - return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour)) - + (a->tm_min - b->tm_min)) - + (a->tm_sec - b->tm_sec)); -} - -/* Yield A's UTC offset, or an unspecified value if unknown. */ -static long int -tm_gmtoff (struct tm *a) -{ -#if HAVE_TM_GMTOFF - return a->tm_gmtoff; -#else - return 0; -#endif -} - -DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0, - doc: /* Return the offset and name for the local time zone. -This returns a list of the form (OFFSET NAME). -OFFSET is an integer number of seconds ahead of UTC (east of Greenwich). - A negative value means west of Greenwich. -NAME is a string giving the name of the time zone. -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. 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 -the data it can't find. */) - (Lisp_Object specified_time, Lisp_Object zone) -{ - struct timespec value; - struct tm local_tm, gmt_tm; - Lisp_Object zone_offset, zone_name; - - zone_offset = Qnil; - value = make_timespec (lisp_seconds_argument (specified_time), 0); - zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value, - zone, &local_tm); - - /* gmtime_r expects a pointer to time_t, but tv_sec of struct - timespec on some systems (MinGW) is a 64-bit field. */ - time_t tsec = value.tv_sec; - if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm)) - { - long int offset = (HAVE_TM_GMTOFF - ? tm_gmtoff (&local_tm) - : tm_diff (&local_tm, &gmt_tm)); - zone_offset = make_number (offset); - if (SCHARS (zone_name) == 0) - { - /* 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_prec, min, sec_prec, sec); - } - } - - return list2 (zone_offset, zone_name); -} - -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 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 -of `decode-time', `encode-time', or `format-time-string', pass the -function a ZONE argument. To change local time consistently -throughout Emacs, call (setenv "TZ" TZ): this changes both the -environment of the Emacs process and the variable -`process-environment', whereas `set-time-zone-rule' affects only the -former. */) - (Lisp_Object tz) -{ - tzlookup (NILP (tz) ? Qwall : tz, true); - return Qnil; -} - -/* A buffer holding a string of the form "TZ=value", intended - to be part of the environment. If TZ is supposed to be unset, - the buffer string is "tZ=". */ - static char *tzvalbuf; - -/* Get the local time zone rule. */ -char * -emacs_getenv_TZ (void) -{ - return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0; -} - -/* Set the local time zone rule to TZSTRING, which can be null to - denote wall clock time. Do not record the setting in LOCAL_TZ. - - This function is not thread-safe, in theory because putenv is not, - but mostly because of the static storage it updates. Other threads - that invoke localtime etc. may be adversely affected while this - function is executing. */ - -int -emacs_setenv_TZ (const char *tzstring) -{ - static ptrdiff_t tzvalbufsize; - ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0; - char *tzval = tzvalbuf; - bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen; - - if (new_tzvalbuf) - { - /* Do not attempt to free the old tzvalbuf, since another thread - may be using it. In practice, the first allocation is large - enough and memory does not leak. */ - tzval = xpalloc (NULL, &tzvalbufsize, - tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1); - tzvalbuf = tzval; - tzval[1] = 'Z'; - tzval[2] = '='; - } - - if (tzstring) - { - /* Modify TZVAL in place. Although this is dicey in a - multithreaded environment, we know of no portable alternative. - Calling putenv or setenv could crash some other thread. */ - tzval[0] = 'T'; - strcpy (tzval + tzeqlen, tzstring); - } - else - { - /* Turn 'TZ=whatever' into an empty environment variable 'tZ='. - Although this is also dicey, calling unsetenv here can crash Emacs. - See Bug#8705. */ - tzval[0] = 't'; - tzval[tzeqlen] = 0; - } - - -#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 - if (need_putenv) - xputenv (tzval); - - return 0; -} /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a @@ -2520,7 +1315,7 @@ general_insert_function (void (*insert_func) val = args[argnum]; if (CHARACTERP (val)) { - int c = XFASTINT (val); + int c = XFIXNAT (val); unsigned char str[MAX_MULTIBYTE_LENGTH]; int len; @@ -2676,18 +1471,19 @@ called interactively, INHERIT is t. */) CHECK_CHARACTER (character); if (NILP (count)) XSETFASTINT (count, 1); - CHECK_NUMBER (count); - c = XFASTINT (character); + else + CHECK_FIXNUM (count); + c = XFIXNAT (character); if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) len = CHAR_STRING (c, str); else str[0] = c, len = 1; - if (XINT (count) <= 0) + if (XFIXNUM (count) <= 0) return Qnil; - if (BUF_BYTES_MAX / len < XINT (count)) + if (BUF_BYTES_MAX / len < XFIXNUM (count)) buffer_overflow (); - n = XINT (count) * len; + n = XFIXNUM (count) * len; stringlen = min (n, sizeof string - sizeof string % len); for (i = 0; i < stringlen; i++) string[i] = str[i % len]; @@ -2720,12 +1516,12 @@ The optional third arg INHERIT, if non-nil, says to inherit text properties from adjoining text, if those properties are sticky. */) (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit) { - CHECK_NUMBER (byte); - if (XINT (byte) < 0 || XINT (byte) > 255) - args_out_of_range_3 (byte, make_number (0), make_number (255)); - if (XINT (byte) >= 128 + CHECK_FIXNUM (byte); + if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255) + args_out_of_range_3 (byte, make_fixnum (0), make_fixnum (255)); + if (XFIXNUM (byte) >= 128 && ! NILP (BVAR (current_buffer, enable_multibyte_characters))) - XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte))); + XSETFASTINT (byte, BYTE8_TO_CHAR (XFIXNUM (byte))); return Finsert_char (byte, count, inherit); } @@ -2808,10 +1604,10 @@ make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte, { update_buffer_properties (start, end); - tem = Fnext_property_change (make_number (start), Qnil, make_number (end)); - tem1 = Ftext_properties_at (make_number (start), Qnil); + tem = Fnext_property_change (make_fixnum (start), Qnil, make_fixnum (end)); + tem1 = Ftext_properties_at (make_fixnum (start), Qnil); - if (XINT (tem) != end || !NILP (tem1)) + if (XFIXNUM (tem) != end || !NILP (tem1)) copy_intervals_to_string (result, current_buffer, start, end - start); } @@ -2834,7 +1630,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end) if (!NILP (Vbuffer_access_fontified_property)) { Lisp_Object tem - = Ftext_property_any (make_number (start), make_number (end), + = Ftext_property_any (make_fixnum (start), make_fixnum (end), Vbuffer_access_fontified_property, Qnil, Qnil); if (NILP (tem)) @@ -2842,7 +1638,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end) } CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions, - make_number (start), make_number (end)); + make_fixnum (start), make_fixnum (end)); } } @@ -2860,8 +1656,8 @@ use `buffer-substring-no-properties' instead. */) register ptrdiff_t b, e; validate_region (&start, &end); - b = XINT (start); - e = XINT (end); + b = XFIXNUM (start); + e = XFIXNUM (end); return make_buffer_string (b, e, 1); } @@ -2876,8 +1672,8 @@ they can be in either order. */) register ptrdiff_t b, e; validate_region (&start, &end); - b = XINT (start); - e = XINT (end); + b = XFIXNUM (start); + e = XFIXNUM (end); return make_buffer_string (b, e, 0); } @@ -2922,15 +1718,15 @@ using `string-make-multibyte' or `string-make-unibyte', which see. */) b = BUF_BEGV (bp); else { - CHECK_NUMBER_COERCE_MARKER (start); - b = XINT (start); + CHECK_FIXNUM_COERCE_MARKER (start); + b = XFIXNUM (start); } if (NILP (end)) e = BUF_ZV (bp); else { - CHECK_NUMBER_COERCE_MARKER (end); - e = XINT (end); + CHECK_FIXNUM_COERCE_MARKER (end); + e = XFIXNUM (end); } if (b > e) @@ -2990,15 +1786,15 @@ determines whether case is significant or ignored. */) begp1 = BUF_BEGV (bp1); else { - CHECK_NUMBER_COERCE_MARKER (start1); - begp1 = XINT (start1); + CHECK_FIXNUM_COERCE_MARKER (start1); + begp1 = XFIXNUM (start1); } if (NILP (end1)) endp1 = BUF_ZV (bp1); else { - CHECK_NUMBER_COERCE_MARKER (end1); - endp1 = XINT (end1); + CHECK_FIXNUM_COERCE_MARKER (end1); + endp1 = XFIXNUM (end1); } if (begp1 > endp1) @@ -3028,15 +1824,15 @@ determines whether case is significant or ignored. */) begp2 = BUF_BEGV (bp2); else { - CHECK_NUMBER_COERCE_MARKER (start2); - begp2 = XINT (start2); + CHECK_FIXNUM_COERCE_MARKER (start2); + begp2 = XFIXNUM (start2); } if (NILP (end2)) endp2 = BUF_ZV (bp2); else { - CHECK_NUMBER_COERCE_MARKER (end2); - endp2 = XINT (end2); + CHECK_FIXNUM_COERCE_MARKER (end2); + endp2 = XFIXNUM (end2); } if (begp2 > endp2) @@ -3091,7 +1887,7 @@ determines whether case is significant or ignored. */) } if (c1 != c2) - return make_number (c1 < c2 ? -1 - chars : chars + 1); + return make_fixnum (c1 < c2 ? -1 - chars : chars + 1); chars++; rarely_quit (chars); @@ -3100,12 +1896,12 @@ determines whether case is significant or ignored. */) /* The strings match as far as they go. If one is shorter, that one is less. */ if (chars < endp1 - begp1) - return make_number (chars + 1); + return make_fixnum (chars + 1); else if (chars < endp2 - begp2) - return make_number (- chars - 1); + return make_fixnum (- chars - 1); /* Same length too => they are equal. */ - return make_number (0); + return make_fixnum (0); } @@ -3195,6 +1991,8 @@ differences between the two buffers. */) return Qnil; } + ptrdiff_t count = SPECPDL_INDEX (); + /* FIXME: It is not documented how to initialize the contents of the context structure. This code cargo-cults from the existing caller in src/analyze.c of GNU Diffutils, which appears to @@ -3235,8 +2033,7 @@ differences between the two buffers. */) Fundo_boundary (); bool modification_hooks_inhibited = false; - ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); /* We are going to make a lot of small modifications, and having the modification hooks called for each of them will slow us down. @@ -3285,15 +2082,14 @@ differences between the two buffers. */) if (beg_b < end_b) { SET_PT (beg_a); - Finsert_buffer_substring (source, make_natnum (beg_b), - make_natnum (end_b)); + Finsert_buffer_substring (source, make_fixed_natnum (beg_b), + make_fixed_natnum (end_b)); } } --i; --j; } - unbind_to (count, Qnil); - SAFE_FREE (); + SAFE_FREE_UNBIND_TO (count, Qnil); rbc_quitcounter = 0; if (modification_hooks_inhibited) @@ -3414,8 +2210,8 @@ Both characters must have the same length of multi-byte form. */) validate_region (&start, &end); CHECK_CHARACTER (fromchar); CHECK_CHARACTER (tochar); - fromc = XFASTINT (fromchar); - toc = XFASTINT (tochar); + fromc = XFIXNAT (fromchar); + toc = XFIXNAT (tochar); if (multibyte_p) { @@ -3441,9 +2237,9 @@ Both characters must have the same length of multi-byte form. */) tostr[0] = toc; } - pos = XINT (start); + pos = XFIXNUM (start); pos_byte = CHAR_TO_BYTE (pos); - stop = CHAR_TO_BYTE (XINT (end)); + stop = CHAR_TO_BYTE (XFIXNUM (end)); end_byte = stop; /* If we don't want undo, turn off putting stuff on the list. @@ -3491,7 +2287,7 @@ Both characters must have the same length of multi-byte form. */) else if (!changed) { changed = -1; - modify_text (pos, XINT (end)); + modify_text (pos, XFIXNUM (end)); if (! NILP (noundo)) { @@ -3558,8 +2354,7 @@ Both characters must have the same length of multi-byte form. */) update_compositions (changed, last_changed, CHECK_ALL); } - unbind_to (count, Qnil); - return Qnil; + return unbind_to (count, Qnil); } @@ -3615,7 +2410,7 @@ check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end, buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1); pos_byte += len1; } - if (XINT (AREF (elt, i)) != buf[i]) + if (XFIXNUM (AREF (elt, i)) != buf[i]) break; } if (i == len) @@ -3667,9 +2462,9 @@ It returns the number of characters changed. */) tt = SDATA (table); } - pos = XINT (start); + pos = XFIXNUM (start); pos_byte = CHAR_TO_BYTE (pos); - end_pos = XINT (end); + end_pos = XFIXNUM (end); modify_text (pos, end_pos); cnt = 0; @@ -3718,7 +2513,7 @@ It returns the number of characters changed. */) val = CHAR_TABLE_REF (table, oc); if (CHARACTERP (val)) { - nc = XFASTINT (val); + nc = XFIXNAT (val); str_len = CHAR_STRING (nc, buf); str = buf; } @@ -3779,7 +2574,7 @@ It returns the number of characters changed. */) } else { - string = Fmake_string (make_number (1), val); + string = Fmake_string (make_fixnum (1), val, Qnil); } replace_range (pos, pos + len, string, 1, 0, 1, 0); pos_byte += SBYTES (string); @@ -3793,7 +2588,7 @@ It returns the number of characters changed. */) pos++; } - return make_number (cnt); + return make_fixnum (cnt); } DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r", @@ -3803,7 +2598,7 @@ This command deletes buffer text without modifying the kill ring. */) (Lisp_Object start, Lisp_Object end) { validate_region (&start, &end); - del_range (XINT (start), XINT (end)); + del_range (XFIXNUM (start), XFIXNUM (end)); return Qnil; } @@ -3813,9 +2608,9 @@ DEFUN ("delete-and-extract-region", Fdelete_and_extract_region, (Lisp_Object start, Lisp_Object end) { validate_region (&start, &end); - if (XINT (start) == XINT (end)) + if (XFIXNUM (start) == XFIXNUM (end)) return empty_unibyte_string; - return del_range_1 (XINT (start), XINT (end), 1, 1); + return del_range_1 (XFIXNUM (start), XFIXNUM (end), 1, 1); } DEFUN ("widen", Fwiden, Swiden, 0, 0, "", @@ -3844,27 +2639,27 @@ When calling from a program, pass two arguments; positions (integers or markers) bounding the text that should remain visible. */) (register Lisp_Object start, Lisp_Object end) { - CHECK_NUMBER_COERCE_MARKER (start); - CHECK_NUMBER_COERCE_MARKER (end); + CHECK_FIXNUM_COERCE_MARKER (start); + CHECK_FIXNUM_COERCE_MARKER (end); - if (XINT (start) > XINT (end)) + if (XFIXNUM (start) > XFIXNUM (end)) { Lisp_Object tem; tem = start; start = end; end = tem; } - if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z)) + if (!(BEG <= XFIXNUM (start) && XFIXNUM (start) <= XFIXNUM (end) && XFIXNUM (end) <= Z)) args_out_of_range (start, end); - if (BEGV != XFASTINT (start) || ZV != XFASTINT (end)) + if (BEGV != XFIXNAT (start) || ZV != XFIXNAT (end)) current_buffer->clip_changed = 1; - SET_BUF_BEGV (current_buffer, XFASTINT (start)); - SET_BUF_ZV (current_buffer, XFASTINT (end)); - if (PT < XFASTINT (start)) - SET_PT (XFASTINT (start)); - if (PT > XFASTINT (end)) - SET_PT (XFASTINT (end)); + SET_BUF_BEGV (current_buffer, XFIXNAT (start)); + SET_BUF_ZV (current_buffer, XFIXNAT (end)); + if (PT < XFIXNAT (start)) + SET_PT (XFIXNAT (start)); + if (PT > XFIXNAT (end)) + SET_PT (XFIXNAT (end)); /* Changing the buffer bounds invalidates any recorded current column. */ invalidate_current_column (); return Qnil; @@ -4110,8 +2905,8 @@ usage: (propertize STRING &rest PROPERTIES) */) for (i = 1; i < nargs; i += 2) properties = Fcons (args[i], Fcons (args[i + 1], properties)); - Fadd_text_properties (make_number (0), - make_number (SCHARS (string)), + Fadd_text_properties (make_fixnum (0), + make_fixnum (SCHARS (string)), properties, string); return string; } @@ -4171,14 +2966,14 @@ Nth argument is substituted instead of the next one. A format can contain either numbered or unnumbered %-sequences but not both, except that %% can be mixed with numbered %-sequences. -The + flag character inserts a + before any positive number, while a -space inserts a space before any positive number; these flags only -affect %d, %e, %f, and %g sequences, and the + flag takes precedence. +The + flag character inserts a + before any nonnegative number, while a +space inserts a space before any nonnegative number; these flags +affect only numeric %-sequences, and the + flag takes precedence. The - and 0 flags affect the width specifier, as described below. The # flag means to use an alternate display form for %o, %x, %X, %e, %f, and %g sequences: for %o, it ensures that the result begins with -\"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\"; +\"0\"; for %x and %X, it prefixes nonzero results with \"0x\" or \"0X\"; for %e and %f, it causes a decimal point to be included even if the precision is zero; for %g, it causes a decimal point to be included even if the precision is zero, and also forces trailing @@ -4228,8 +3023,26 @@ usage: (format-message STRING &rest OBJECTS) */) static Lisp_Object styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) { + enum + { + /* Maximum precision for a %f conversion such that the trailing + output digit might be nonzero. Any precision larger than this + will not yield useful information. */ + USEFUL_PRECISION_MAX = ((1 - LDBL_MIN_EXP) + * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1 + : FLT_RADIX == 16 ? 4 + : -1)), + + /* Maximum number of bytes (including terminating null) generated + by any format, if precision is no more than USEFUL_PRECISION_MAX. + On all practical hosts, %Lf is the worst case. */ + SPRINTF_BUFSIZE = (sizeof "-." + (LDBL_MAX_10_EXP + 1) + + USEFUL_PRECISION_MAX) + }; + verify (USEFUL_PRECISION_MAX > 0); + ptrdiff_t n; /* The number of the next arg to substitute. */ - char initial_buffer[4000]; + char initial_buffer[1000 + SPRINTF_BUFSIZE]; char *buf = initial_buffer; ptrdiff_t bufsize = sizeof initial_buffer; ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1; @@ -4273,9 +3086,9 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; /* Allocate the info and discarded tables. */ - ptrdiff_t alloca_size; - if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &alloca_size) - || INT_ADD_WRAPV (formatlen, alloca_size, &alloca_size) + ptrdiff_t info_size, alloca_size; + if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size) + || INT_ADD_WRAPV (formatlen, info_size, &alloca_size) || SIZE_MAX < alloca_size) memory_full (SIZE_MAX); info = SAFE_ALLOCA (alloca_size); @@ -4283,6 +3096,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) string was not copied into the output. It is 2 if byte I was not the first byte of its character. */ char *discarded = (char *) &info[nspec_bound]; + info = ptr_bounds_clip (info, info_size); + discarded = ptr_bounds_clip (discarded, formatlen); memset (discarded, 0, formatlen); /* Try to determine whether the result should be multibyte. @@ -4332,8 +3147,14 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) char const *convsrc = format; unsigned char format_char = *format++; - /* Bytes needed to represent the output of this conversion. */ + /* Number of bytes to be preallocated for the next directive's + output. At the end of each iteration this is at least + CONVBYTES_ROOM, and is greater if the current directive + output was so large that it will be retried after buffer + reallocation. */ ptrdiff_t convbytes = 1; + enum { CONVBYTES_ROOM = SPRINTF_BUFSIZE - 1 }; + eassert (p <= buf + bufsize - SPRINTF_BUFSIZE); if (format_char == '%') { @@ -4453,7 +3274,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } else if (conversion == 'c') { - if (INTEGERP (arg) && ! ASCII_CHAR_P (XINT (arg))) + if (FIXNUMP (arg) && ! ASCII_CHAR_P (XFIXNUM (arg))) { if (!multibyte) { @@ -4569,7 +3390,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) spec->intervals = arg_intervals = true; new_result = true; - continue; + convbytes = CONVBYTES_ROOM; } } else if (! (conversion == 'c' || conversion == 'd' @@ -4578,43 +3399,13 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) || conversion == 'X')) error ("Invalid format operation %%%c", STRING_CHAR ((unsigned char *) format - 1)); - else if (! (INTEGERP (arg) || (FLOATP (arg) && conversion != 'c'))) + else if (! (FIXNUMP (arg) || ((BIGNUMP (arg) || FLOATP (arg)) + && conversion != 'c'))) error ("Format specifier doesn't match argument type"); else { - enum - { - /* Lower bound on the number of bits per - base-FLT_RADIX digit. */ - DIG_BITS_LBOUND = FLT_RADIX < 16 ? 1 : 4, - - /* 1 if integers should be formatted as long doubles, - because they may be so large that there is a rounding - error when converting them to double, and long doubles - are wider than doubles. */ - INT_AS_LDBL = (DIG_BITS_LBOUND * DBL_MANT_DIG < FIXNUM_BITS - 1 - && DBL_MANT_DIG < LDBL_MANT_DIG), - - /* Maximum precision for a %f conversion such that the - trailing output digit might be nonzero. Any precision - larger than this will not yield useful information. */ - USEFUL_PRECISION_MAX = - ((1 - LDBL_MIN_EXP) - * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1 - : FLT_RADIX == 16 ? 4 - : -1)), - - /* Maximum number of bytes generated by any format, if - precision is no more than USEFUL_PRECISION_MAX. - On all practical hosts, %f is the worst case. */ - SPRINTF_BUFSIZE = - sizeof "-." + (LDBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX, - - /* Length of pM (that is, of pMd without the - trailing "d"). */ - pMlen = sizeof pMd - 2 - }; - verify (USEFUL_PRECISION_MAX > 0); + /* Length of pM (that is, of pMd without the trailing "d"). */ + enum { pMlen = sizeof pMd - 2 }; /* Avoid undefined behavior in underlying sprintf. */ if (conversion == 'd' || conversion == 'i') @@ -4625,219 +3416,308 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) with "L" possibly inserted for floating-point formats, and with pM inserted for integer formats. At most two flags F can be specified at once. */ - char convspec[sizeof "%FF.*d" + max (INT_AS_LDBL, pMlen)]; - { - char *f = convspec; - *f++ = '%'; - /* MINUS_FLAG and ZERO_FLAG are dealt with later. */ - *f = '+'; f += plus_flag; - *f = ' '; f += space_flag; - *f = '#'; f += sharp_flag; - *f++ = '.'; - *f++ = '*'; - if (float_conversion) - { - if (INT_AS_LDBL) - { - *f = 'L'; - f += INTEGERP (arg); - } - } - else if (conversion != 'c') - { - memcpy (f, pMd, pMlen); - f += pMlen; - zero_flag &= ! precision_given; - } - *f++ = conversion; - *f = '\0'; - } + char convspec[sizeof "%FF.*d" + max (sizeof "L" - 1, pMlen)]; + char *f = convspec; + *f++ = '%'; + /* MINUS_FLAG and ZERO_FLAG are dealt with later. */ + *f = '+'; f += plus_flag; + *f = ' '; f += space_flag; + *f = '#'; f += sharp_flag; + *f++ = '.'; + *f++ = '*'; + if (! (float_conversion || conversion == 'c')) + { + memcpy (f, pMd, pMlen); + f += pMlen; + zero_flag &= ! precision_given; + } + *f++ = conversion; + *f = '\0'; int prec = -1; if (precision_given) prec = min (precision, USEFUL_PRECISION_MAX); - /* Use sprintf to format this number into sprintf_buf. Omit + /* Characters to be inserted after spaces and before + leading zeros. This can occur with bignums, since + bignum_to_string does only leading '-'. */ + char prefix[sizeof "-0x" - 1]; + int prefixlen = 0; + + /* Use sprintf or bignum_to_string to format this number. Omit padding and excess precision, though, because sprintf limits - output length to INT_MAX. + output length to INT_MAX and bignum_to_string doesn't + do padding or precision. - There are four types of conversion: double, unsigned + Use five sprintf conversions: double, long double, unsigned char (passed as int), wide signed int, and wide unsigned int. Treat them separately because the sprintf ABI is sensitive to which type is passed. Be careful about integer overflow, NaNs, infinities, and conversions; for example, the min and max macros are not suitable here. */ - char sprintf_buf[SPRINTF_BUFSIZE]; ptrdiff_t sprintf_bytes; if (float_conversion) { - if (INT_AS_LDBL && INTEGERP (arg)) + /* Format as a long double if the arg is an integer + that would lose less information than when formatting + it as a double. Otherwise, format as a double; + this is likely to be faster and better-tested. */ + + bool format_as_long_double = false; + double darg; + long double ldarg; + + if (FLOATP (arg)) + darg = XFLOAT_DATA (arg); + else { - /* Although long double may have a rounding error if - DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1, - it is more accurate than plain 'double'. */ - long double x = XINT (arg); - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); + bool format_bignum_as_double = false; + if (LDBL_MANT_DIG <= DBL_MANT_DIG) + { + if (FIXNUMP (arg)) + darg = XFIXNUM (arg); + else + format_bignum_as_double = true; + } + else + { + if (INTEGERP (arg)) + { + intmax_t iarg; + uintmax_t uarg; + if (integer_to_intmax (arg, &iarg)) + ldarg = iarg; + else if (integer_to_uintmax (arg, &uarg)) + ldarg = uarg; + else + format_bignum_as_double = true; + } + if (!format_bignum_as_double) + { + darg = ldarg; + format_as_long_double = darg != ldarg; + } + } + if (format_bignum_as_double) + darg = bignum_to_double (arg); + } + + if (format_as_long_double) + { + f[-1] = 'L'; + *f++ = conversion; + *f = '\0'; + sprintf_bytes = sprintf (p, convspec, prec, ldarg); } else - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, - XFLOATINT (arg)); + sprintf_bytes = sprintf (p, convspec, prec, darg); } else if (conversion == 'c') { /* Don't use sprintf here, as it might mishandle prec. */ - sprintf_buf[0] = XINT (arg); + p[0] = XFIXNUM (arg); + p[1] = '\0'; sprintf_bytes = prec != 0; } + else if (BIGNUMP (arg)) + { + int base = ((conversion == 'd' || conversion == 'i') ? 10 + : conversion == 'o' ? 8 : 16); + sprintf_bytes = bignum_bufsize (arg, base); + if (sprintf_bytes <= buf + bufsize - p) + { + int signedbase = conversion == 'X' ? -base : base; + sprintf_bytes = bignum_to_c_string (p, sprintf_bytes, + arg, signedbase); + bool negative = p[0] == '-'; + prec = min (precision, sprintf_bytes - prefixlen); + prefix[prefixlen] = plus_flag ? '+' : ' '; + prefixlen += (plus_flag | space_flag) & !negative; + prefix[prefixlen] = '0'; + prefix[prefixlen + 1] = conversion; + prefixlen += sharp_flag && base == 16 ? 2 : 0; + } + } else if (conversion == 'd' || conversion == 'i') { - /* For float, maybe we should use "%1.0f" - instead so it also works for values outside - the integer range. */ - printmax_t x; - if (INTEGERP (arg)) - x = XINT (arg); + if (FIXNUMP (arg)) + { + printmax_t x = XFIXNUM (arg); + sprintf_bytes = sprintf (p, convspec, prec, x); + } else { - double d = XFLOAT_DATA (arg); - if (d < 0) - { - x = TYPE_MINIMUM (printmax_t); - if (x < d) - x = d; - } - else - { - x = TYPE_MAXIMUM (printmax_t); - if (d < x) - x = d; - } + strcpy (f - pMlen - 1, "f"); + double x = XFLOAT_DATA (arg); + + /* Truncate and then convert -0 to 0, to be more + consistent with %x etc.; see Bug#31938. */ + x = trunc (x); + x = x ? x : 0; + + sprintf_bytes = sprintf (p, convspec, 0, x); + bool signedp = ! c_isdigit (p[0]); + prec = min (precision, sprintf_bytes - signedp); } - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); } else { - /* Don't sign-extend for octal or hex printing. */ uprintmax_t x; - if (INTEGERP (arg)) - x = XUINT (arg); - else + bool negative; + if (FIXNUMP (arg)) { - double d = XFLOAT_DATA (arg); - if (d < 0) - x = 0; + if (binary_as_unsigned) + { + x = XUFIXNUM (arg); + negative = false; + } else { - x = TYPE_MAXIMUM (uprintmax_t); - if (d < x) - x = d; + EMACS_INT i = XFIXNUM (arg); + negative = i < 0; + x = negative ? -i : i; } } - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); + else + { + double d = XFLOAT_DATA (arg); + double uprintmax = TYPE_MAXIMUM (uprintmax_t); + if (! (0 <= d && d < uprintmax + 1)) + xsignal1 (Qoverflow_error, arg); + x = d; + negative = false; + } + p[0] = negative ? '-' : plus_flag ? '+' : ' '; + bool signedp = negative | plus_flag | space_flag; + sprintf_bytes = sprintf (p + signedp, convspec, prec, x); + sprintf_bytes += signedp; } /* Now the length of the formatted item is known, except it omits padding and excess precision. Deal with excess precision - first. This happens only when the format specifies - ridiculously large precision. */ + first. This happens when the format specifies ridiculously + large precision, or when %d or %i formats a float that would + ordinarily need fewer digits than a specified precision, + or when a bignum is formatted using an integer format + with enough precision. */ ptrdiff_t excess_precision = precision_given ? precision - prec : 0; - ptrdiff_t leading_zeros = 0, trailing_zeros = 0; - if (excess_precision) + ptrdiff_t trailing_zeros = 0; + if (excess_precision != 0 && float_conversion) { - if (float_conversion) - { - if ((conversion == 'g' && ! sharp_flag) - || ! ('0' <= sprintf_buf[sprintf_bytes - 1] - && sprintf_buf[sprintf_bytes - 1] <= '9')) - excess_precision = 0; - else - { - if (conversion == 'g') - { - char *dot = strchr (sprintf_buf, '.'); - if (!dot) - excess_precision = 0; - } - } - trailing_zeros = excess_precision; - } - else - leading_zeros = excess_precision; + if (! c_isdigit (p[sprintf_bytes - 1]) + || (conversion == 'g' + && ! (sharp_flag && strchr (p, '.')))) + excess_precision = 0; + trailing_zeros = excess_precision; } + ptrdiff_t leading_zeros = excess_precision - trailing_zeros; /* Compute the total bytes needed for this item, including excess precision and padding. */ ptrdiff_t numwidth; - if (INT_ADD_WRAPV (sprintf_bytes, excess_precision, &numwidth)) + if (INT_ADD_WRAPV (prefixlen + sprintf_bytes, excess_precision, + &numwidth)) numwidth = PTRDIFF_MAX; ptrdiff_t padding = numwidth < field_width ? field_width - numwidth : 0; - if (max_bufsize - sprintf_bytes <= excess_precision + if (max_bufsize - (prefixlen + sprintf_bytes) <= excess_precision || max_bufsize - padding <= numwidth) string_overflow (); convbytes = numwidth + padding; if (convbytes <= buf + bufsize - p) { - /* Copy the formatted item from sprintf_buf into buf, - inserting padding and excess-precision zeros. */ - - char *src = sprintf_buf; - char src0 = src[0]; - int exponent_bytes = 0; - bool signedp = src0 == '-' || src0 == '+' || src0 == ' '; - unsigned char after_sign = src[signedp]; - if (zero_flag && 0 <= char_hexdigit (after_sign)) + bool signedp = p[0] == '-' || p[0] == '+' || p[0] == ' '; + int beglen = (signedp + + ((p[signedp] == '0' + && (p[signedp + 1] == 'x' + || p[signedp + 1] == 'X')) + ? 2 : 0)); + eassert (prefixlen == 0 || beglen == 0 + || (beglen == 1 && p[0] == '-' + && ! (prefix[0] == '-' || prefix[0] == '+' + || prefix[0] == ' '))); + if (zero_flag && 0 <= char_hexdigit (p[beglen])) { leading_zeros += padding; padding = 0; } + if (leading_zeros == 0 && sharp_flag && conversion == 'o' + && p[beglen] != '0') + { + leading_zeros++; + padding -= padding != 0; + } - if (excess_precision + int endlen = 0; + if (trailing_zeros && (conversion == 'e' || conversion == 'g')) { - char *e = strchr (src, 'e'); + char *e = strchr (p, 'e'); if (e) - exponent_bytes = src + sprintf_bytes - e; + endlen = p + sprintf_bytes - e; } - spec->start = nchars; - if (! minus_flag) - { - memset (p, ' ', padding); - p += padding; - nchars += padding; - } + ptrdiff_t midlen = sprintf_bytes - beglen - endlen; + ptrdiff_t leading_padding = minus_flag ? 0 : padding; + ptrdiff_t trailing_padding = padding - leading_padding; - *p = src0; - src += signedp; - p += signedp; - memset (p, '0', leading_zeros); - p += leading_zeros; - int significand_bytes - = sprintf_bytes - signedp - exponent_bytes; - memcpy (p, src, significand_bytes); - p += significand_bytes; - src += significand_bytes; - memset (p, '0', trailing_zeros); - p += trailing_zeros; - memcpy (p, src, exponent_bytes); - p += exponent_bytes; - - nchars += leading_zeros + sprintf_bytes + trailing_zeros; + /* Insert padding and excess-precision zeros. The output + contains the following components, in left-to-right order: - if (minus_flag) + LEADING_PADDING spaces. + BEGLEN bytes taken from the start of sprintf output. + PREFIXLEN bytes taken from the start of the prefix array. + LEADING_ZEROS zeros. + MIDLEN bytes taken from the middle of sprintf output. + TRAILING_ZEROS zeros. + ENDLEN bytes taken from the end of sprintf output. + TRAILING_PADDING spaces. + + The sprintf output is taken from the buffer starting at + P and continuing for SPRINTF_BYTES bytes. */ + + ptrdiff_t incr + = (padding + leading_zeros + prefixlen + + sprintf_bytes + trailing_zeros); + + /* Optimize for the typical case with padding or zeros. */ + if (incr != sprintf_bytes) { - memset (p, ' ', padding); - p += padding; - nchars += padding; + /* Move data to make room to insert spaces and '0's. + As this may entail overlapping moves, process + the output right-to-left and use memmove. + With any luck this code is rarely executed. */ + char *src = p + sprintf_bytes; + char *dst = p + incr; + dst -= trailing_padding; + memset (dst, ' ', trailing_padding); + src -= endlen; + dst -= endlen; + memmove (dst, src, endlen); + dst -= trailing_zeros; + memset (dst, '0', trailing_zeros); + src -= midlen; + dst -= midlen; + memmove (dst, src, midlen); + dst -= leading_zeros; + memset (dst, '0', leading_zeros); + dst -= prefixlen; + memcpy (dst, prefix, prefixlen); + src -= beglen; + dst -= beglen; + memmove (dst, src, beglen); + dst -= leading_padding; + memset (dst, ' ', leading_padding); } - spec->end = nchars; + p += incr; + spec->start = nchars; + spec->end = nchars += incr; new_result = true; - continue; + convbytes = CONVBYTES_ROOM; } } } @@ -4890,43 +3770,51 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } copy_char: - if (convbytes <= buf + bufsize - p) - { - memcpy (p, convsrc, convbytes); - p += convbytes; - nchars++; - continue; - } + memcpy (p, convsrc, convbytes); + p += convbytes; + nchars++; + convbytes = CONVBYTES_ROOM; } - /* There wasn't enough room to store this conversion or single - character. CONVBYTES says how much room is needed. Allocate - enough room (and then some) and do it again. */ - ptrdiff_t used = p - buf; - if (max_bufsize - used < convbytes) + ptrdiff_t buflen_needed; + if (INT_ADD_WRAPV (used, convbytes, &buflen_needed)) string_overflow (); - bufsize = used + convbytes; - bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize; - - if (buf == initial_buffer) - { - buf = xmalloc (bufsize); - sa_must_free = true; - buf_save_value_index = SPECPDL_INDEX (); - record_unwind_protect_ptr (xfree, buf); - memcpy (buf, initial_buffer, used); - } - else + if (bufsize <= buflen_needed) { - buf = xrealloc (buf, bufsize); - set_unwind_protect_ptr (buf_save_value_index, xfree, buf); - } + if (max_bufsize <= buflen_needed) + string_overflow (); + + /* Either there wasn't enough room to store this conversion, + or there won't be enough room to do a sprintf the next + time through the loop. Allocate enough room (and then some). */ - p = buf + used; - format = format0; - n = n0; - ispec = ispec0; + bufsize = (buflen_needed <= max_bufsize / 2 + ? buflen_needed * 2 : max_bufsize); + + if (buf == initial_buffer) + { + buf = xmalloc (bufsize); + buf_save_value_index = SPECPDL_INDEX (); + record_unwind_protect_ptr (xfree, buf); + memcpy (buf, initial_buffer, used); + } + else + { + buf = xrealloc (buf, bufsize); + set_unwind_protect_ptr (buf_save_value_index, xfree, buf); + } + + p = buf + used; + if (convbytes != CONVBYTES_ROOM) + { + /* There wasn't enough room for this conversion; do it over. */ + eassert (CONVBYTES_ROOM < convbytes); + format = format0; + n = n0; + ispec = ispec0; + } + } } if (bufsize < p - buf) @@ -4949,8 +3837,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) if (string_intervals (args[0]) || arg_intervals) { /* Add text properties from the format string. */ - Lisp_Object len = make_number (SCHARS (args[0])); - Lisp_Object props = text_property_list (args[0], make_number (0), + Lisp_Object len = make_fixnum (SCHARS (args[0])); + Lisp_Object props = text_property_list (args[0], make_fixnum (0), len, Qnil); if (CONSP (props)) { @@ -4974,7 +3862,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) Lisp_Object item = XCAR (list); /* First adjust the property start position. */ - ptrdiff_t pos = XINT (XCAR (item)); + ptrdiff_t pos = XFIXNUM (XCAR (item)); /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN up to this position. */ @@ -4995,10 +3883,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } } - XSETCAR (item, make_number (translated)); + XSETCAR (item, make_fixnum (translated)); /* Likewise adjust the property end position. */ - pos = XINT (XCAR (XCDR (item))); + pos = XFIXNUM (XCAR (XCDR (item))); for (; position < pos; bytepos++) { @@ -5017,10 +3905,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } } - XSETCAR (XCDR (item), make_number (translated)); + XSETCAR (XCDR (item), make_fixnum (translated)); } - add_text_properties_from_list (val, props, make_number (0)); + add_text_properties_from_list (val, props, make_fixnum (0)); } /* Add text properties from arguments. */ @@ -5028,17 +3916,17 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) for (ptrdiff_t i = 0; i < nspec; i++) if (info[i].intervals) { - len = make_number (SCHARS (info[i].argument)); - Lisp_Object new_len = make_number (info[i].end - info[i].start); + len = make_fixnum (SCHARS (info[i].argument)); + Lisp_Object new_len = make_fixnum (info[i].end - info[i].start); props = text_property_list (info[i].argument, - make_number (0), len, Qnil); + make_fixnum (0), len, Qnil); 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) make_composition_value_copy (props); add_text_properties_from_list (val, props, - make_number (info[i].start)); + make_fixnum (info[i].start)); } } @@ -5061,13 +3949,13 @@ Case is ignored if `case-fold-search' is non-nil in the current buffer. */) CHECK_CHARACTER (c1); CHECK_CHARACTER (c2); - if (XINT (c1) == XINT (c2)) + if (XFIXNUM (c1) == XFIXNUM (c2)) return Qt; if (NILP (BVAR (current_buffer, case_fold_search))) return Qnil; - i1 = XFASTINT (c1); - i2 = XFASTINT (c2); + i1 = XFIXNAT (c1); + i2 = XFIXNAT (c2); /* FIXME: It is possible to compare multibyte characters even when the current buffer is unibyte. Unfortunately this is ambiguous @@ -5170,7 +4058,16 @@ transpose_markers (ptrdiff_t start1, ptrdiff_t end1, } } -DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0, +DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, + "(if (< (length mark-ring) 2)\ + (error \"Other region must be marked before transposing two regions\")\ + (let* ((num (if current-prefix-arg\ + (prefix-numeric-value current-prefix-arg)\ + 0))\ + (ring-length (length mark-ring))\ + (eltnum (mod num ring-length))\ + (eltnum2 (mod (1+ num) ring-length)))\ + (list (point) (mark) (elt mark-ring eltnum) (elt mark-ring eltnum2))))", doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2. The regions should not be overlapping, because the size of the buffer is never changed in a transposition. @@ -5178,7 +4075,14 @@ never changed in a transposition. Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update any markers that happen to be located in the regions. -Transposing beyond buffer boundaries is an error. */) +Transposing beyond buffer boundaries is an error. + +Interactively, STARTR1 and ENDR1 are point and mark; STARTR2 and ENDR2 +are the last two marks pushed to the mark ring; LEAVE-MARKERS is nil. +If a prefix argument N is given, STARTR2 and ENDR2 are the two +successive marks N entries back in the mark ring. A negative prefix +argument instead counts forward from the oldest mark in the mark +ring. */) (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers) { register ptrdiff_t start1, end1, start2, end2; @@ -5195,10 +4099,10 @@ Transposing beyond buffer boundaries is an error. */) validate_region (&startr1, &endr1); validate_region (&startr2, &endr2); - start1 = XFASTINT (startr1); - end1 = XFASTINT (endr1); - start2 = XFASTINT (startr2); - end2 = XFASTINT (endr2); + start1 = XFIXNAT (startr1); + end1 = XFIXNAT (endr1); + start2 = XFIXNAT (startr2); + end2 = XFIXNAT (endr2); gap = GPT; /* Swap the regions if they're reversed. */ @@ -5351,8 +4255,7 @@ Transposing beyond buffer boundaries is an error. */) { USE_SAFE_ALLOCA; - modify_text (start1, end1); - modify_text (start2, end2); + modify_text (start1, end2); record_change (start1, len1); record_change (start2, len2); tmp_interval1 = copy_intervals (cur_intv, start1, len1); @@ -5525,6 +4428,22 @@ functions if all the text being accessed has this property. */); DEFVAR_LISP ("operating-system-release", Voperating_system_release, doc: /* The release of the operating system Emacs is running on. */); + DEFVAR_BOOL ("binary-as-unsigned", + binary_as_unsigned, + doc: /* Non-nil means `format' %x and %o treat integers as unsigned. +This has machine-dependent results. Nil means to treat integers as +signed, which is portable; for example, if N is a negative integer, +(read (format "#x%x") N) returns N only when this variable is nil. + +This variable is experimental; email 32252@debbugs.gnu.org if you need +it to be non-nil. */); + /* For now, default to true if bignums exist, false in traditional Emacs. */ +#ifdef lisp_h_FIXNUMP + binary_as_unsigned = false; +#else + binary_as_unsigned = true; +#endif + defsubr (&Spropertize); defsubr (&Schar_equal); defsubr (&Sgoto_char); @@ -5587,6 +4506,7 @@ functions if all the text being accessed has this property. */); defsubr (&Sinsert_byte); defsubr (&Suser_login_name); + defsubr (&Sgroup_name); defsubr (&Suser_real_login_name); defsubr (&Suser_uid); defsubr (&Suser_real_uid); @@ -5594,18 +4514,6 @@ functions if all the text being accessed has this property. */); defsubr (&Sgroup_real_gid); defsubr (&Suser_full_name); defsubr (&Semacs_pid); - defsubr (&Scurrent_time); - defsubr (&Stime_add); - defsubr (&Stime_subtract); - defsubr (&Stime_less_p); - defsubr (&Sget_internal_run_time); - defsubr (&Sformat_time_string); - defsubr (&Sfloat_time); - defsubr (&Sdecode_time); - defsubr (&Sencode_time); - defsubr (&Scurrent_time_string); - defsubr (&Scurrent_time_zone); - defsubr (&Sset_time_zone_rule); defsubr (&Ssystem_name); defsubr (&Smessage); defsubr (&Smessage_box); diff --git a/src/emacs-module.c b/src/emacs-module.c index 0abfd3f6f16..e695a3d2e64 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -36,6 +36,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <intprops.h> #include <verify.h> +/* Work around GCC bug 83162. */ +#if GNUC_PREREQ (4, 3, 0) +# pragma GCC diagnostic ignored "-Wclobbered" +#endif + /* This module is lackadaisical about function casts. */ #if GNUC_PREREQ (8, 0, 0) # pragma GCC diagnostic ignored "-Wcast-function-type" @@ -297,15 +302,15 @@ module_make_global_ref (emacs_env *env, emacs_value ref) if (i >= 0) { Lisp_Object value = HASH_VALUE (h, i); - EMACS_INT refcount = XFASTINT (value) + 1; + EMACS_INT refcount = XFIXNAT (value) + 1; if (MOST_POSITIVE_FIXNUM < refcount) - xsignal0 (Qoverflow_error); - value = make_natnum (refcount); + overflow_error (); + value = make_fixed_natnum (refcount); set_hash_value_slot (h, i, value); } else { - hash_put (h, new_obj, make_natnum (1), hashcode); + hash_put (h, new_obj, make_fixed_natnum (1), hashcode); } return lisp_to_value (module_assertions ? global_env : env, new_obj); @@ -324,9 +329,9 @@ module_free_global_ref (emacs_env *env, emacs_value ref) if (i >= 0) { - EMACS_INT refcount = XFASTINT (HASH_VALUE (h, i)) - 1; + EMACS_INT refcount = XFIXNAT (HASH_VALUE (h, i)) - 1; if (refcount > 0) - set_hash_value_slot (h, i, make_natnum (refcount)); + set_hash_value_slot (h, i, make_fixed_natnum (refcount)); else { eassert (refcount == 0); @@ -342,7 +347,7 @@ module_free_global_ref (emacs_env *env, emacs_value ref) for (Lisp_Object tail = globals; CONSP (tail); tail = XCDR (tail)) { - emacs_value global = XSAVE_POINTER (XCAR (tail), 0); + emacs_value global = xmint_pointer (XCAR (tail)); if (global == ref) { if (NILP (prev)) @@ -436,7 +441,7 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, ? (min_arity <= MOST_POSITIVE_FIXNUM && max_arity == emacs_variadic_function) : min_arity <= max_arity && max_arity <= MOST_POSITIVE_FIXNUM))) - xsignal2 (Qinvalid_arity, make_number (min_arity), make_number (max_arity)); + xsignal2 (Qinvalid_arity, make_fixnum (min_arity), make_fixnum (max_arity)); struct Lisp_Module_Function *function = allocate_module_function (); function->min_arity = min_arity; @@ -470,7 +475,7 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, USE_SAFE_ALLOCA; ptrdiff_t nargs1; if (INT_ADD_WRAPV (nargs, 1, &nargs1)) - xsignal0 (Qoverflow_error); + overflow_error (); SAFE_ALLOCA_LISP (newargs, nargs1); newargs[0] = value_to_lisp (fun); for (ptrdiff_t i = 0; i < nargs; i++) @@ -513,17 +518,18 @@ module_extract_integer (emacs_env *env, emacs_value n) { MODULE_FUNCTION_BEGIN (0); Lisp_Object l = value_to_lisp (n); - CHECK_NUMBER (l); - return XINT (l); + CHECK_INTEGER (l); + intmax_t i; + if (! integer_to_intmax (l, &i)) + xsignal1 (Qoverflow_error, l); + return i; } static emacs_value module_make_integer (emacs_env *env, intmax_t n) { MODULE_FUNCTION_BEGIN (module_nil); - if (FIXNUM_OVERFLOW_P (n)) - xsignal0 (Qoverflow_error); - return lisp_to_value (env, make_number (n)); + return lisp_to_value (env, make_int (n)); } static double @@ -577,7 +583,7 @@ module_make_string (emacs_env *env, const char *str, ptrdiff_t length) { MODULE_FUNCTION_BEGIN (module_nil); if (! (0 <= length && length <= STRING_BYTES_BOUND)) - xsignal0 (Qoverflow_error); + overflow_error (); /* FIXME: AUTO_STRING_WITH_LEN requires STR to be null-terminated, but we shouldn't require that. */ AUTO_STRING_WITH_LEN (lstr, str, length); @@ -634,8 +640,8 @@ 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)); + args_out_of_range_3 (INT_TO_INTEGER (i), + make_fixnum (0), make_fixnum (ASIZE (lvec) - 1)); } static void @@ -730,7 +736,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, rt->private_members = &rt_priv; rt->get_environment = module_get_environment; - Vmodule_runtimes = Fcons (make_save_ptr (rt), Vmodule_runtimes); + Vmodule_runtimes = Fcons (make_mint_ptr (rt), Vmodule_runtimes); ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (finalize_runtime_unwind, rt); @@ -741,11 +747,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, maybe_quit (); if (r != 0) - { - if (FIXNUM_OVERFLOW_P (r)) - xsignal0 (Qoverflow_error); - xsignal2 (Qmodule_init_failed, file, make_number (r)); - } + xsignal2 (Qmodule_init_failed, file, INT_TO_INTEGER (r)); module_signal_or_throw (&env_priv); return unbind_to (count, Qt); @@ -758,7 +760,7 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist) eassume (0 <= func->min_arity); if (! (func->min_arity <= nargs && (func->max_arity < 0 || nargs <= func->max_arity))) - xsignal2 (Qwrong_number_of_arguments, function, make_number (nargs)); + xsignal2 (Qwrong_number_of_arguments, function, make_fixnum (nargs)); emacs_env pub; struct emacs_env_private priv; @@ -781,7 +783,6 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist) } emacs_value ret = func->subr (env, nargs, args, func->data); - SAFE_FREE (); eassert (&priv == env->private_members); @@ -790,7 +791,7 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist) maybe_quit (); module_signal_or_throw (&priv); - return unbind_to (count, value_to_lisp (ret)); + return SAFE_FREE_UNBIND_TO (count, value_to_lisp (ret)); } Lisp_Object @@ -798,25 +799,13 @@ module_function_arity (const struct Lisp_Module_Function *const function) { ptrdiff_t minargs = function->min_arity; ptrdiff_t maxargs = function->max_arity; - return Fcons (make_number (minargs), - maxargs == MANY ? Qmany : make_number (maxargs)); + return Fcons (make_fixnum (minargs), + maxargs == MANY ? Qmany : make_fixnum (maxargs)); } /* Helper functions. */ -static bool -in_current_thread (void) -{ - if (current_thread == NULL) - return false; -#ifdef HAVE_PTHREAD - return pthread_equal (pthread_self (), current_thread->thread_id); -#elif defined WINDOWSNT - return GetCurrentThreadId () == current_thread->thread_id; -#endif -} - static void module_assert_thread (void) { @@ -837,7 +826,7 @@ module_assert_runtime (struct emacs_runtime *ert) ptrdiff_t count = 0; for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail)) { - if (XSAVE_POINTER (XCAR (tail), 0) == ert) + if (xmint_pointer (XCAR (tail)) == ert) return; ++count; } @@ -854,7 +843,7 @@ module_assert_env (emacs_env *env) for (Lisp_Object tail = Vmodule_environments; CONSP (tail); tail = XCDR (tail)) { - if (XSAVE_POINTER (XCAR (tail), 0) == env) + if (xmint_pointer (XCAR (tail)) == env) return; ++count; } @@ -920,9 +909,8 @@ static Lisp_Object ltv_mark; static Lisp_Object value_to_lisp_bits (emacs_value v) { - intptr_t i = (intptr_t) v; if (plain_values || USE_LSB_TAG) - return XIL (i); + return XPL (v); /* With wide EMACS_INT and when tag bits are the most significant, reassembling integers differs from reassembling pointers in two @@ -931,7 +919,8 @@ value_to_lisp_bits (emacs_value v) integer when restoring, but zero-extend pointers because that makes TAG_PTR faster. */ - EMACS_UINT tag = i & (GCALIGNMENT - 1); + intptr_t i = (intptr_t) v; + EMACS_UINT tag = i & ((1 << GCTYPEBITS) - 1); EMACS_UINT untagged = i - tag; switch (tag) { @@ -966,11 +955,11 @@ value_to_lisp (emacs_value v) for (Lisp_Object environments = Vmodule_environments; CONSP (environments); environments = XCDR (environments)) { - emacs_env *env = XSAVE_POINTER (XCAR (environments), 0); + emacs_env *env = xmint_pointer (XCAR (environments)); for (Lisp_Object values = env->private_members->values; CONSP (values); values = XCDR (values)) { - Lisp_Object *p = XSAVE_POINTER (XCAR (values), 0); + Lisp_Object *p = xmint_pointer (XCAR (values)); if (p == optr) return *p; ++num_values; @@ -994,13 +983,22 @@ value_to_lisp (emacs_value v) static emacs_value lisp_to_value_bits (Lisp_Object o) { - EMACS_UINT u = XLI (o); + if (plain_values || USE_LSB_TAG) + return XLP (o); - /* Compress U into the space of a pointer, possibly losing information. */ - uintptr_t p = (plain_values || USE_LSB_TAG - ? u - : (INTEGERP (o) ? u << VALBITS : u & VALMASK) + XTYPE (o)); - return (emacs_value) p; + /* Compress O into the space of a pointer, possibly losing information. */ + EMACS_UINT u = XLI (o); + if (FIXNUMP (o)) + { + uintptr_t i = (u << VALBITS) + XTYPE (o); + return (emacs_value) i; + } + else + { + char *p = XLP (o); + void *v = p - (u & ~VALMASK) + XTYPE (o); + return v; + } } /* Convert O to an emacs_value. Allocate storage if needed; this can @@ -1019,7 +1017,7 @@ lisp_to_value (emacs_env *env, Lisp_Object o) void *vptr = optr; ATTRIBUTE_MAY_ALIAS emacs_value ret = vptr; struct emacs_env_private *priv = env->private_members; - priv->values = Fcons (make_save_ptr (ret), priv->values); + priv->values = Fcons (make_mint_ptr (ret), priv->values); return ret; } @@ -1084,7 +1082,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) env->vec_get = module_vec_get; env->vec_size = module_vec_size; env->should_quit = module_should_quit; - Vmodule_environments = Fcons (make_save_ptr (env), Vmodule_environments); + Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments); return env; } @@ -1093,7 +1091,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) static void finalize_environment (emacs_env *env) { - eassert (XSAVE_POINTER (XCAR (Vmodule_environments), 0) == env); + eassert (xmint_pointer (XCAR (Vmodule_environments)) == env); Vmodule_environments = XCDR (Vmodule_environments); if (module_assertions) /* There is always at least the global environment. */ @@ -1107,10 +1105,10 @@ finalize_environment_unwind (void *env) } static void -finalize_runtime_unwind (void* raw_ert) +finalize_runtime_unwind (void *raw_ert) { struct emacs_runtime *ert = raw_ert; - eassert (XSAVE_POINTER (XCAR (Vmodule_runtimes), 0) == ert); + eassert (xmint_pointer (XCAR (Vmodule_runtimes)) == ert); Vmodule_runtimes = XCDR (Vmodule_runtimes); finalize_environment (ert->private_members->env); } @@ -1121,7 +1119,7 @@ mark_modules (void) for (Lisp_Object tail = Vmodule_environments; CONSP (tail); tail = XCDR (tail)) { - emacs_env *env = XSAVE_POINTER (XCAR (tail), 0); + emacs_env *env = xmint_pointer (XCAR (tail)); struct emacs_env_private *priv = env->private_members; mark_object (priv->non_local_exit_symbol); mark_object (priv->non_local_exit_data); @@ -1165,15 +1163,11 @@ module_handle_throw (emacs_env *env, Lisp_Object tag_val) void init_module_assertions (bool enable) { + /* If enabling module assertions, use a hidden environment for + storing the globals. This environment is never freed. */ module_assertions = enable; if (enable) - { - /* We use a hidden environment for storing the globals. This - environment is never freed. */ - emacs_env env; - global_env = initialize_environment (&env, &global_env_private); - eassert (global_env != &env); - } + global_env = initialize_environment (NULL, &global_env_private); } static _Noreturn void diff --git a/src/emacs.c b/src/emacs.c index ba57da7213a..221b074afc9 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -66,6 +66,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ +#include "bignum.h" #include "intervals.h" #include "character.h" #include "buffer.h" @@ -83,7 +84,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "charset.h" #include "composite.h" #include "dispextern.h" -#include "regex.h" +#include "ptr-bounds.h" +#include "regex-emacs.h" #include "sheap.h" #include "syntax.h" #include "sysselect.h" @@ -93,10 +95,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "getpagesize.h" #include "gnutls.h" -#if (defined PROFILING \ - && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__)) +#ifdef PROFILING # include <sys/gmon.h> extern void moncontrol (int mode); +# ifdef __MINGW32__ +extern unsigned char etext asm ("etext"); +# else +extern char etext; +# endif #endif #ifdef HAVE_SETLOCALE @@ -198,6 +204,9 @@ HANDLE w32_daemon_event; char **initial_argv; int initial_argc; +/* The name of the working directory, or NULL if this info is unavailable. */ +char const *emacs_wd; + static void sort_args (int argc, char **argv); static void syms_of_emacs (void); @@ -372,7 +381,7 @@ terminate_due_to_signal (int sig, int backtrace_limit) totally_unblock_input (); if (sig == SIGTERM || sig == SIGHUP || sig == SIGINT) - Fkill_emacs (make_number (sig)); + Fkill_emacs (make_fixnum (sig)); shut_down_emacs (sig, Qnil); emacs_backtrace (backtrace_limit); @@ -400,7 +409,7 @@ terminate_due_to_signal (int sig, int backtrace_limit) /* Code for dealing with Lisp access to the Unix command line. */ static void -init_cmdargs (int argc, char **argv, int skip_args, char *original_pwd) +init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) { int i; Lisp_Object name, dir, handler; @@ -441,7 +450,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char *original_pwd) { Lisp_Object found; int yes = openp (Vexec_path, Vinvocation_name, - Vexec_suffixes, &found, make_number (X_OK), false); + Vexec_suffixes, &found, make_fixnum (X_OK), false); if (yes == 1) { /* Add /: to the front of the name @@ -688,7 +697,7 @@ main (int argc, char **argv) char *ch_to_dir = 0; /* If we use --chdir, this records the original directory. */ - char *original_pwd = 0; + char const *original_pwd = 0; /* Record (approximately) where the stack begins. */ stack_bottom = (char *) &stack_bottom_variable; @@ -700,28 +709,7 @@ main (int argc, char **argv) dumping = false; #endif - /* 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 () - && !getenv ("EMACS_HEAP_EXEC")) - { - /* Set this so the personality will be reverted before execs - after this one, and to work around an re-exec loop on buggy - kernels (Bug#32083). */ - 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 and then try anyway. */ - perror (argv[0]); - } + argc = maybe_disable_address_randomization (dumping, argc, argv); #ifndef CANNOT_DUMP might_dump = !initialized; @@ -748,6 +736,8 @@ main (int argc, char **argv) /* Initialize the codepage for file names, needed to decode non-ASCII file names during startup. */ w32_init_file_name_codepage (); + /* Initialize the startup directory, needed for emacs_wd below. */ + w32_init_current_directory (); #endif w32_init_main_thread (); #endif @@ -809,6 +799,8 @@ main (int argc, char **argv) exit (0); } + emacs_wd = emacs_get_current_dir_name (); + if (argmatch (argv, argc, "-chdir", "--chdir", 4, &ch_to_dir, &skip_args)) { #ifdef WINDOWSNT @@ -819,13 +811,18 @@ main (int argc, char **argv) filename_from_ansi (ch_to_dir, newdir); ch_to_dir = newdir; #endif - original_pwd = emacs_get_current_dir_name (); if (chdir (ch_to_dir) != 0) { fprintf (stderr, "%s: Can't chdir to %s: %s\n", argv[0], ch_to_dir, strerror (errno)); exit (1); } + original_pwd = emacs_wd; +#ifdef WINDOWSNT + /* Reinitialize Emacs's notion of the startup directory. */ + w32_init_current_directory (); +#endif + emacs_wd = emacs_get_current_dir_name (); } #if defined (HAVE_SETRLIMIT) && defined (RLIMIT_STACK) && !defined (CYGWIN) @@ -841,9 +838,9 @@ main (int argc, char **argv) { rlim_t lim = rlim.rlim_cur; - /* Approximate the amount regex.c needs per unit of + /* Approximate the amount regex-emacs.c needs per unit of emacs_re_max_failures, then add 33% to cover the size of the - smaller stacks that regex.c successively allocates and + smaller stacks that regex-emacs.c successively allocates and discards on its way to the maximum. */ int min_ratio = 20 * sizeof (char *); int ratio = min_ratio + min_ratio / 3; @@ -883,12 +880,13 @@ main (int argc, char **argv) lim = newlim; } } - /* If the stack is big enough, let regex.c more of it before - falling back to heap allocation. */ + /* If the stack is big enough, let regex-emacs.c use more of it + before falling back to heap allocation. */ if (lim < extra) - lim = extra; /* avoid wrap-around in unsigned subtraction */ - emacs_re_safe_alloca = - max (min (lim - extra, SIZE_MAX) * (min_ratio / ratio), MAX_ALLOCA); + lim = extra; /* avoid wrap-around in unsigned subtraction */ + ptrdiff_t max_failures + = min (lim - extra, min (PTRDIFF_MAX, SIZE_MAX)) / ratio; + emacs_re_safe_alloca = max (max_failures * min_ratio, MAX_ALLOCA); } #endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */ @@ -1252,6 +1250,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem } init_alloc (); + init_bignum (); init_threads (); if (do_initial_setlocale) @@ -1266,6 +1265,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem running_asynch_code = 0; init_random (); +#if defined HAVE_JSON && !defined WINDOWSNT + init_json (); +#endif + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); @@ -1298,21 +1301,21 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem { #ifdef NS_IMPL_COCOA /* Started from GUI? */ - /* FIXME: Do the right thing if getenv returns NULL, or if + /* FIXME: Do the right thing if get_homedir returns "", or if chdir fails. */ if (! inhibit_window_system && ! isatty (STDIN_FILENO) && ! ch_to_dir) - chdir (getenv ("HOME")); + chdir (get_homedir ()); if (skip_args < argc) { if (!strncmp (argv[skip_args], "-psn", 4)) { skip_args += 1; - if (! ch_to_dir) chdir (getenv ("HOME")); + if (! ch_to_dir) chdir (get_homedir ()); } else if (skip_args+1 < argc && !strncmp (argv[skip_args+1], "-psn", 4)) { skip_args += 2; - if (! ch_to_dir) chdir (getenv ("HOME")); + if (! ch_to_dir) chdir (get_homedir ()); } } #endif /* COCOA */ @@ -1503,6 +1506,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_minibuf (); syms_of_process (); syms_of_search (); + syms_of_sysdep (); + syms_of_timefns (); syms_of_frame (); syms_of_syntax (); syms_of_terminal (); @@ -1546,9 +1551,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif #endif /* HAVE_X_WINDOWS */ -#ifdef HAVE_LIBXML2 syms_of_xml (); -#endif #ifdef HAVE_LCMS2 syms_of_lcms2 (); @@ -1567,6 +1570,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_fontset (); #endif /* HAVE_NTGUI */ +#if defined HAVE_NTGUI || defined CYGWIN + syms_of_w32cygwinx (); +#endif + #if defined WINDOWSNT || defined HAVE_NTGUI syms_of_w32select (); #endif @@ -1614,6 +1621,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_threads (); syms_of_profiler (); +#ifdef HAVE_JSON + syms_of_json (); +#endif + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); @@ -1638,9 +1649,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_charset (); - /* This calls putenv and so must precede init_process_emacs. Also, - it sets Voperating_system_release, which init_process_emacs uses. */ - init_editfns (dumping); + /* This calls putenv and so must precede init_process_emacs. */ + init_timefns (dumping); + + /* This sets Voperating_system_release, which init_process_emacs uses. */ + init_editfns (); /* These two call putenv. */ #ifdef HAVE_DBUS @@ -1693,23 +1706,15 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem GNU/Linux and MinGW. It might work on some other systems too. Give it a try and tell us if it works on your system. To compile for profiling, use the configure option --enable-profiling. */ -#if defined (__FreeBSD__) || defined (GNU_LINUX) || defined (__MINGW32__) #ifdef PROFILING if (initialized) { -#ifdef __MINGW32__ - extern unsigned char etext asm ("etext"); -#else - extern char etext; -#endif - atexit (_mcleanup); monstartup ((uintptr_t) __executable_start, (uintptr_t) &etext); } else moncontrol (0); #endif -#endif initialized = 1; @@ -2014,6 +2019,10 @@ all of which are called before Emacs is actually killed. */ { int exit_code; +#ifdef HAVE_LIBSYSTEMD + sd_notify(0, "STOPPING=1"); +#endif /* HAVE_LIBSYSTEMD */ + /* Fsignal calls emacs_abort () if it sees that waiting_for_input is set. */ waiting_for_input = 0; @@ -2043,10 +2052,10 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } - if (INTEGERP (arg)) - exit_code = (XINT (arg) < 0 - ? XINT (arg) | INT_MIN - : XINT (arg) & INT_MAX); + if (FIXNUMP (arg)) + exit_code = (XFIXNUM (arg) < 0 + ? XFIXNUM (arg) | INT_MIN + : XFIXNUM (arg) & INT_MAX); else exit_code = EXIT_SUCCESS; exit (exit_code); @@ -2407,7 +2416,7 @@ decode_env_path (const char *evarname, const char *defalt, bool empty) && strncmp (path, emacs_dir_env, emacs_dir_len) == 0) element = Fexpand_file_name (Fsubstring (element, - make_number (emacs_dir_len), + make_fixnum (emacs_dir_len), Qnil), build_unibyte_string (emacs_dir)); #endif @@ -2474,6 +2483,13 @@ from the parent process and its tty file descriptors. */) error ("This function can only be called after loading the init files"); #ifndef WINDOWSNT + if (daemon_type == 1) + { +#ifdef HAVE_LIBSYSTEMD + sd_notify(0, "READY=1"); +#endif /* HAVE_LIBSYSTEMD */ + } + if (daemon_type == 2) { int nfd; diff --git a/src/eval.c b/src/eval.c index 0dc8639a8d4..c64a40b955d 100644 --- a/src/eval.c +++ b/src/eval.c @@ -204,6 +204,10 @@ bool backtrace_p (union specbinding *pdl) { return pdl >= specpdl; } +static bool +backtrace_thread_p (struct thread_state *tstate, union specbinding *pdl) +{ return pdl >= tstate->m_specpdl; } + union specbinding * backtrace_top (void) { @@ -213,6 +217,15 @@ backtrace_top (void) return pdl; } +static union specbinding * +backtrace_thread_top (struct thread_state *tstate) +{ + union specbinding *pdl = tstate->m_specpdl_ptr - 1; + while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE) + pdl--; + return pdl; +} + union specbinding * backtrace_next (union specbinding *pdl) { @@ -222,6 +235,15 @@ backtrace_next (union specbinding *pdl) return pdl; } +static union specbinding * +backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl) +{ + pdl--; + while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE) + pdl--; + return pdl; +} + void init_eval_once (void) { @@ -264,8 +286,8 @@ init_eval (void) static void restore_stack_limits (Lisp_Object data) { - max_specpdl_size = XINT (XCAR (data)); - max_lisp_eval_depth = XINT (XCDR (data)); + max_specpdl_size = XFIXNUM (XCAR (data)); + max_lisp_eval_depth = XFIXNUM (XCDR (data)); } static void grow_specpdl (void); @@ -303,8 +325,8 @@ call_debugger (Lisp_Object arg) /* Restore limits after leaving the debugger. */ record_unwind_protect (restore_stack_limits, - Fcons (make_number (old_max), - make_number (old_depth))); + Fcons (make_fixnum (old_max), + make_fixnum (old_depth))); #ifdef HAVE_WINDOW_SYSTEM if (display_hourglass_p) @@ -511,7 +533,7 @@ usage: (setq [SYM VAL]...) */) Lisp_Object sym = XCAR (tail), lex_binding; tail = XCDR (tail); if (!CONSP (tail)) - xsignal2 (Qwrong_number_of_arguments, Qsetq, make_number (nargs + 1)); + xsignal2 (Qwrong_number_of_arguments, Qsetq, make_fixnum (nargs + 1)); Lisp_Object arg = XCAR (tail); tail = XCDR (tail); val = eval_sub (arg); @@ -627,6 +649,16 @@ The return value is BASE-VARIABLE. */) if (NILP (Fboundp (base_variable))) set_internal (base_variable, find_symbol_value (new_alias), Qnil, SET_INTERNAL_BIND); + else if (!NILP (Fboundp (new_alias)) + && !EQ (find_symbol_value (new_alias), + find_symbol_value (base_variable))) + call2 (intern ("display-warning"), + list3 (intern ("defvaralias"), intern ("losing-value"), new_alias), + CALLN (Fformat_message, + build_string + ("Overwriting value of `%s' by aliasing to `%s'"), + new_alias, base_variable)); + { union specbinding *p; @@ -667,8 +699,10 @@ default_toplevel_binding (Lisp_Object symbol) break; case SPECPDL_UNWIND: + case SPECPDL_UNWIND_ARRAY: case SPECPDL_UNWIND_PTR: case SPECPDL_UNWIND_INT: + case SPECPDL_UNWIND_EXCURSION: case SPECPDL_UNWIND_VOID: case SPECPDL_BACKTRACE: case SPECPDL_LET_LOCAL: @@ -741,6 +775,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) sym = XCAR (args); tail = XCDR (args); + CHECK_SYMBOL (sym); + if (!NILP (tail)) { if (!NILP (XCDR (tail)) && !NILP (XCDR (XCDR (tail)))) @@ -924,7 +960,7 @@ usage: (let VARLIST BODY...) */) CHECK_LIST (varlist); /* Make space to hold the values to give the bound variables. */ - EMACS_INT varlist_len = XFASTINT (Flength (varlist)); + EMACS_INT varlist_len = XFIXNAT (Flength (varlist)); SAFE_ALLOCA_LISP (temps, varlist_len); ptrdiff_t nvars = varlist_len; @@ -971,8 +1007,7 @@ usage: (let VARLIST BODY...) */) specbind (Qinternal_interpreter_environment, lexenv); elt = Fprogn (XCDR (args)); - SAFE_FREE (); - return unbind_to (count, elt); + return SAFE_FREE_UNBIND_TO (count, elt); } DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0, @@ -1202,9 +1237,11 @@ Executes BODYFORM and returns its value if no error happens. Each element of HANDLERS looks like (CONDITION-NAME BODY...) where the BODY is made of Lisp expressions. -A handler is applicable to an error -if CONDITION-NAME is one of the error's condition names. -If an error happens, the first applicable handler is run. +A handler is applicable to an error if CONDITION-NAME is one of the +error's condition names. Handlers may also apply when non-error +symbols are signaled (e.g., `quit'). A CONDITION-NAME of t applies to +any symbol, including non-error symbols. If multiple handlers are +applicable, only the first one runs. The car of a handler may be a list of condition names instead of a single condition name; then it handles all of them. If the special @@ -1420,6 +1457,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), } } +static Lisp_Object +internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument) +{ + struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = function (argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + Fsignal (Qno_catch, val); + } +} + +/* Like a combination of internal_condition_case_1 and internal_catch. + Catches all signals and throws. Never exits nonlocally; returns + Qcatch_all_memory_full if no handler could be allocated. */ + +Lisp_Object +internal_catch_all (Lisp_Object (*function) (void *), void *argument, + Lisp_Object (*handler) (Lisp_Object)) +{ + struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = internal_catch_all_1 (function, argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + return handler (val); + } +} + struct handler * push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) { @@ -1671,33 +1759,25 @@ xsignal3 (Lisp_Object error_symbol, Lisp_Object arg1, Lisp_Object arg2, Lisp_Obj } /* Signal `error' with message S, and additional arg ARG. - If ARG is not a genuine list, make it a one-element list. */ + If ARG is not a proper list, make it a one-element list. */ void signal_error (const char *s, Lisp_Object arg) { - Lisp_Object tortoise, hare; - - hare = tortoise = arg; - while (CONSP (hare)) - { - hare = XCDR (hare); - if (!CONSP (hare)) - break; - - hare = XCDR (hare); - tortoise = XCDR (tortoise); - - if (EQ (hare, tortoise)) - break; - } - - if (!NILP (hare)) + if (NILP (Fproper_list_p (arg))) arg = list1 (arg); xsignal (Qerror, Fcons (build_string (s), arg)); } +/* Use this for arithmetic overflow, e.g., when an integer result is + too large even for a bignum. */ +void +overflow_error (void) +{ + xsignal0 (Qoverflow_error); +} + /* Return true if LIST is a non-nil atom or a list containing one of CONDITIONS. */ @@ -1809,7 +1889,9 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions) for (h = handlers; CONSP (h); h = XCDR (h)) { Lisp_Object handler = XCAR (h); - if (!NILP (Fmemq (handler, conditions))) + if (!NILP (Fmemq (handler, conditions)) + /* t is also used as a catch-all by Lisp code. */ + || EQ (handler, Qt)) return handlers; } @@ -1946,12 +2028,12 @@ this does nothing and returns nil. */) && !AUTOLOADP (XSYMBOL (function)->u.s.function)) return Qnil; - if (!NILP (Vpurify_flag) && EQ (docstring, make_number (0))) + if (!NILP (Vpurify_flag) && EQ (docstring, make_fixnum (0))) /* `read1' in lread.c has found the docstring starting with "\ and assumed the docstring will be provided by Snarf-documentation, so it passed us 0 instead. But that leads to accidental sharing in purecopy's hash-consing, so we use a (hopefully) unique integer instead. */ - docstring = make_number (XHASH (function)); + docstring = make_fixnum (XHASH (function)); return Fdefalias (function, list5 (Qautoload, file, docstring, interactive, type), Qnil); @@ -1971,7 +2053,7 @@ un_autoload (Lisp_Object oldqueue) first = XCAR (queue); second = Fcdr (first); first = Fcar (first); - if (EQ (first, make_number (0))) + if (EQ (first, make_fixnum (0))) Vfeatures = second; else Ffset (first, second); @@ -1996,12 +2078,10 @@ it defines a macro. */) if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef))) return fundef; - if (EQ (macro_only, Qmacro)) - { - Lisp_Object kind = Fnth (make_number (4), fundef); - if (! (EQ (kind, Qt) || EQ (kind, Qmacro))) - return fundef; - } + Lisp_Object kind = Fnth (make_fixnum (4), fundef); + if (EQ (macro_only, Qmacro) + && !(EQ (kind, Qt) || EQ (kind, Qmacro))) + return fundef; /* This is to make sure that loadup.el gives a clear picture of what files are preloaded and when. */ @@ -2024,15 +2104,18 @@ it defines a macro. */) The value saved here is to be restored into Vautoload_queue. */ record_unwind_protect (un_autoload, Vautoload_queue); Vautoload_queue = Qt; - /* If `macro_only', assume this autoload to be a "best-effort", + /* If `macro_only' is set and fundef isn't a macro, assume this autoload to + be a "best-effort" (e.g. to try and find a compiler macro), so don't signal an error if autoloading fails. */ - Fload (Fcar (Fcdr (fundef)), macro_only, Qt, Qnil, Qt); + Lisp_Object ignore_errors + = (EQ (kind, Qt) || EQ (kind, Qmacro)) ? Qnil : macro_only; + Fload (Fcar (Fcdr (fundef)), ignore_errors, Qt, Qnil, Qt); /* Once loading finishes, don't undo it. */ Vautoload_queue = Qt; unbind_to (count, Qnil); - if (NILP (funname)) + if (NILP (funname) || !NILP (ignore_errors)) return Qnil; else { @@ -2184,9 +2267,9 @@ eval_sub (Lisp_Object form) check_cons_list (); - if (XINT (numargs) < XSUBR (fun)->min_args + if (XFIXNUM (numargs) < XSUBR (fun)->min_args || (XSUBR (fun)->max_args >= 0 - && XSUBR (fun)->max_args < XINT (numargs))) + && XSUBR (fun)->max_args < XFIXNUM (numargs))) xsignal2 (Qwrong_number_of_arguments, original_fun, numargs); else if (XSUBR (fun)->max_args == UNEVALLED) @@ -2198,9 +2281,9 @@ eval_sub (Lisp_Object form) ptrdiff_t argnum = 0; USE_SAFE_ALLOCA; - SAFE_ALLOCA_LISP (vals, XINT (numargs)); + SAFE_ALLOCA_LISP (vals, XFIXNUM (numargs)); - while (CONSP (args_left) && argnum < XINT (numargs)) + while (CONSP (args_left) && argnum < XFIXNUM (numargs)) { Lisp_Object arg = XCAR (args_left); args_left = XCDR (args_left); @@ -2230,7 +2313,7 @@ eval_sub (Lisp_Object form) args_left = Fcdr (args_left); } - set_backtrace_args (specpdl + count, argvals, XINT (numargs)); + set_backtrace_args (specpdl + count, argvals, XFIXNUM (numargs)); switch (i) { @@ -2308,7 +2391,7 @@ eval_sub (Lisp_Object form) specbind (Qlexical_binding, NILP (Vinternal_interpreter_environment) ? Qnil : Qt); exp = apply1 (Fcdr (fun), original_args); - unbind_to (count1, Qnil); + exp = unbind_to (count1, exp); val = eval_sub (exp); } else if (EQ (funcar, Qlambda) @@ -2343,7 +2426,7 @@ usage: (apply FUNCTION &rest ARGUMENTS) */) CHECK_LIST (spread_arg); - numargs = XINT (Flength (spread_arg)); + numargs = XFIXNUM (Flength (spread_arg)); if (numargs == 0) return Ffuncall (nargs - 1, args); @@ -2817,7 +2900,7 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) { Lisp_Object fun; XSETSUBR (fun, subr); - xsignal2 (Qwrong_number_of_arguments, fun, make_number (numargs)); + xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs)); } else if (subr->max_args == UNEVALLED) @@ -2898,7 +2981,7 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) Lisp_Object tem; USE_SAFE_ALLOCA; - numargs = XFASTINT (Flength (args)); + numargs = XFIXNAT (Flength (args)); SAFE_ALLOCA_LISP (arg_vector, numargs); args_left = args; @@ -2960,7 +3043,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (size <= COMPILED_STACK_DEPTH) xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); - if (INTEGERP (syms_left)) + if (FIXNUMP (syms_left)) /* 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. @@ -2990,7 +3073,6 @@ 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)) { maybe_quit (); @@ -3001,17 +3083,15 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (EQ (next, Qand_rest)) { - if (rest || previous_optional_or_rest) + if (rest) xsignal1 (Qinvalid_function, fun); rest = 1; - previous_optional_or_rest = true; } else if (EQ (next, Qand_optional)) { - if (optional || rest || previous_optional_or_rest) + if (optional || rest) xsignal1 (Qinvalid_function, fun); optional = 1; - previous_optional_or_rest = true; } else { @@ -3024,7 +3104,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else if (i < nargs) arg = arg_vector[i++]; else if (!optional) - xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); + xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (nargs)); else arg = Qnil; @@ -3035,14 +3115,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else /* Dynamically bind NEXT. */ specbind (next, arg); - previous_optional_or_rest = false; } } - if (!NILP (syms_left) || previous_optional_or_rest) + if (!NILP (syms_left)) xsignal1 (Qinvalid_function, fun); else if (i < nargs) - xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); + xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (nargs)); if (!EQ (lexenv, Vinternal_interpreter_environment)) /* Instantiate a new lexical environment. */ @@ -3149,7 +3228,7 @@ lambda_arity (Lisp_Object fun) if (size <= COMPILED_STACK_DEPTH) xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); - if (INTEGERP (syms_left)) + if (FIXNUMP (syms_left)) return get_byte_code_arity (syms_left); } else @@ -3164,7 +3243,7 @@ lambda_arity (Lisp_Object fun) xsignal1 (Qinvalid_function, fun); if (EQ (next, Qand_rest)) - return Fcons (make_number (minargs), Qmany); + return Fcons (make_fixnum (minargs), Qmany); else if (EQ (next, Qand_optional)) optional = true; else @@ -3178,7 +3257,7 @@ lambda_arity (Lisp_Object fun) if (!NILP (syms_left)) xsignal1 (Qinvalid_function, fun); - return Fcons (make_number (minargs), make_number (maxargs)); + return Fcons (make_fixnum (minargs), make_fixnum (maxargs)); } DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, @@ -3350,6 +3429,16 @@ record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg) specpdl_ptr->unwind.kind = SPECPDL_UNWIND; specpdl_ptr->unwind.func = function; specpdl_ptr->unwind.arg = arg; + specpdl_ptr->unwind.eval_depth = lisp_eval_depth; + grow_specpdl (); +} + +void +record_unwind_protect_array (Lisp_Object *array, ptrdiff_t nelts) +{ + specpdl_ptr->unwind_array.kind = SPECPDL_UNWIND_ARRAY; + specpdl_ptr->unwind_array.array = array; + specpdl_ptr->unwind_array.nelts = nelts; grow_specpdl (); } @@ -3372,6 +3461,14 @@ record_unwind_protect_int (void (*function) (int), int arg) } void +record_unwind_protect_excursion (void) +{ + specpdl_ptr->unwind_excursion.kind = SPECPDL_UNWIND_EXCURSION; + save_excursion_save (specpdl_ptr); + grow_specpdl (); +} + +void record_unwind_protect_void (void (*function) (void)) { specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID; @@ -3405,8 +3502,12 @@ do_one_unbind (union specbinding *this_binding, bool unwinding, switch (this_binding->kind) { case SPECPDL_UNWIND: + lisp_eval_depth = this_binding->unwind.eval_depth; this_binding->unwind.func (this_binding->unwind.arg); break; + case SPECPDL_UNWIND_ARRAY: + xfree (this_binding->unwind_array.array); + break; case SPECPDL_UNWIND_PTR: this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg); break; @@ -3416,6 +3517,10 @@ do_one_unbind (union specbinding *this_binding, bool unwinding, case SPECPDL_UNWIND_VOID: this_binding->unwind_void.func (); break; + case SPECPDL_UNWIND_EXCURSION: + save_excursion_restore (this_binding->unwind_excursion.marker, + this_binding->unwind_excursion.window); + break; case SPECPDL_BACKTRACE: break; case SPECPDL_LET: @@ -3492,6 +3597,7 @@ set_unwind_protect (ptrdiff_t count, void (*func) (Lisp_Object), p->unwind.kind = SPECPDL_UNWIND; p->unwind.func = func; p->unwind.arg = arg; + p->unwind.eval_depth = lisp_eval_depth; } void @@ -3581,11 +3687,11 @@ get_backtrace_frame (Lisp_Object nframes, Lisp_Object base) { register EMACS_INT i; - CHECK_NATNUM (nframes); + CHECK_FIXNAT (nframes); union specbinding *pdl = get_backtrace_starting_at (base); /* Find the frame requested. */ - for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--) + for (i = XFIXNAT (nframes); i > 0 && backtrace_p (pdl); i--) pdl = backtrace_next (pdl); return pdl; @@ -3615,7 +3721,7 @@ DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, The debugger is entered when that frame exits, if the flag is non-nil. */) (Lisp_Object level, Lisp_Object flag) { - CHECK_NUMBER (level); + CHECK_FIXNUM (level); union specbinding *pdl = get_backtrace_frame(level, Qnil); if (backtrace_p (pdl)) @@ -3662,6 +3768,42 @@ Return the result of FUNCTION, or nil if no matching frame could be found. */) return backtrace_frame_apply (function, get_backtrace_frame (nframes, base)); } +DEFUN ("backtrace--frames-from-thread", Fbacktrace_frames_from_thread, + Sbacktrace_frames_from_thread, 1, 1, NULL, + doc: /* Return the list of backtrace frames from current execution point in THREAD. +If a frame has not evaluated the arguments yet (or is a special form), +the value of the list element is (nil FUNCTION ARG-FORMS...). +If a frame has evaluated its arguments and called its function already, +the value of the list element 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. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + union specbinding *pdl = backtrace_thread_top (tstate); + Lisp_Object list = Qnil; + + while (backtrace_thread_p (tstate, pdl)) + { + Lisp_Object frame; + if (backtrace_nargs (pdl) == UNEVALLED) + frame = Fcons (Qnil, + Fcons (backtrace_function (pdl), *backtrace_args (pdl))); + else + { + Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl)); + frame = Fcons (Qt, Fcons (backtrace_function (pdl), tem)); + } + list = Fcons (frame, list); + pdl = backtrace_thread_next (tstate, pdl); + } + return Fnreverse (list); +} + /* For backtrace-eval, we want to temporarily unwind the last few elements of the specpdl stack, and then rewind them. We store the pre-unwind values directly in the pre-existing specpdl elements (i.e. we swap the current @@ -3690,18 +3832,22 @@ backtrace_eval_unrewind (int distance) unwind_protect, but the problem is that we don't know how to rewind them afterwards. */ case SPECPDL_UNWIND: - { - Lisp_Object oldarg = tmp->unwind.arg; - if (tmp->unwind.func == set_buffer_if_live) + if (tmp->unwind.func == set_buffer_if_live) + { + Lisp_Object oldarg = tmp->unwind.arg; tmp->unwind.arg = Fcurrent_buffer (); - else if (tmp->unwind.func == save_excursion_restore) - tmp->unwind.arg = save_excursion_save (); - else - break; - tmp->unwind.func (oldarg); - break; + set_buffer_if_live (oldarg); + } + break; + case SPECPDL_UNWIND_EXCURSION: + { + Lisp_Object marker = tmp->unwind_excursion.marker; + Lisp_Object window = tmp->unwind_excursion.window; + save_excursion_save (tmp); + save_excursion_restore (marker, window); } - + break; + case SPECPDL_UNWIND_ARRAY: case SPECPDL_UNWIND_PTR: case SPECPDL_UNWIND_INT: case SPECPDL_UNWIND_VOID: @@ -3782,7 +3928,7 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. { union specbinding *frame = get_backtrace_frame (nframes, base); union specbinding *prevframe - = get_backtrace_frame (make_number (XFASTINT (nframes) - 1), base); + = get_backtrace_frame (make_fixnum (XFIXNAT (nframes) - 1), base); ptrdiff_t distance = specpdl_ptr - frame; Lisp_Object result = Qnil; eassert (distance >= 0); @@ -3834,8 +3980,10 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. break; case SPECPDL_UNWIND: + case SPECPDL_UNWIND_ARRAY: case SPECPDL_UNWIND_PTR: case SPECPDL_UNWIND_INT: + case SPECPDL_UNWIND_EXCURSION: case SPECPDL_UNWIND_VOID: case SPECPDL_BACKTRACE: break; @@ -3865,6 +4013,15 @@ mark_specpdl (union specbinding *first, union specbinding *ptr) mark_object (specpdl_arg (pdl)); break; + case SPECPDL_UNWIND_ARRAY: + mark_maybe_objects (pdl->unwind_array.array, pdl->unwind_array.nelts); + break; + + case SPECPDL_UNWIND_EXCURSION: + mark_object (pdl->unwind_excursion.marker); + mark_object (pdl->unwind_excursion.window); + break; + case SPECPDL_BACKTRACE: { ptrdiff_t nargs = backtrace_nargs (pdl); @@ -4076,6 +4233,9 @@ alist of active lexical bindings. */); inhibit_lisp_code = Qnil; + DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full"); + Funintern (Qcatch_all_memory_full, Qnil); + defsubr (&Sor); defsubr (&Sand); defsubr (&Sif); @@ -4119,6 +4279,7 @@ alist of active lexical bindings. */); DEFSYM (QCdebug_on_exit, ":debug-on-exit"); defsubr (&Smapbacktrace); defsubr (&Sbacktrace_frame_internal); + defsubr (&Sbacktrace_frames_from_thread); defsubr (&Sbacktrace_eval); defsubr (&Sbacktrace__locals); defsubr (&Sspecial_variable_p); diff --git a/src/fileio.c b/src/fileio.c index ba7caddc978..87442905b18 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -96,6 +96,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <acl.h> #include <allocator.h> #include <careadlinkat.h> +#include <dosname.h> +#include <fsusage.h> #include <stat-time.h> #include <tempname.h> @@ -138,7 +140,7 @@ static bool e_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t, struct coding_system *); -/* Return true if FILENAME exists. */ +/* Return true if FILENAME exists, otherwise return false and set errno. */ static bool check_existing (const char *filename) @@ -231,6 +233,7 @@ report_file_error (char const *string, Lisp_Object name) report_file_errno (string, name, errno); } +#ifdef USE_FILE_NOTIFY /* Like report_file_error, but reports a file-notify-error instead. */ void @@ -245,6 +248,7 @@ report_file_notify_error (const char *string, Lisp_Object name) xsignal (Qfile_notify_error, Fcons (build_string (string), errdata)); } +#endif void close_file_unwind (int fd) @@ -343,7 +347,7 @@ Given a Unix syntax file name, returns a string ending in slash. */) CHECK_STRING (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qfile_name_directory); if (!NILP (handler)) { @@ -438,7 +442,7 @@ or the entire name if it contains no slash. */) CHECK_STRING (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory); if (!NILP (handler)) { @@ -469,7 +473,7 @@ DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory, Sunhandled_file_name_directory, 1, 1, 0, doc: /* Return a directly usable directory name somehow associated with FILENAME. A `directly usable' directory name is one that may be used without the -intervention of any file handler. +intervention of any file name handler. If FILENAME is a directly usable file itself, return \(file-name-as-directory FILENAME). If FILENAME refers to a file which is not accessible from a local process, @@ -481,7 +485,7 @@ get a current directory to run processes in. */) Lisp_Object handler; /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory); if (!NILP (handler)) { @@ -543,7 +547,7 @@ is already present. */) CHECK_STRING (file); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (file, Qfile_name_as_directory); if (!NILP (handler)) { @@ -634,7 +638,7 @@ In Unix-syntax, this function just removes the final slash. */) CHECK_STRING (directory); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (directory, Qdirectory_file_name); if (!NILP (handler)) { @@ -688,7 +692,7 @@ This function does not grok magic file names. */) memset (data + prefix_len, 'X', nX); memcpy (data + prefix_len + nX, SSDATA (encoded_suffix), suffix_len); int kind = (NILP (dir_flag) ? GT_FILE - : EQ (dir_flag, make_number (0)) ? GT_NOCREATE + : EQ (dir_flag, make_fixnum (0)) ? GT_NOCREATE : GT_DIR); int fd = gen_tempname (data, suffix_len, O_BINARY | O_CLOEXEC, kind); bool failed = fd < 0; @@ -729,7 +733,7 @@ later creating the file, which opens all kinds of security holes. For that reason, you should normally use `make-temp-file' instead. */) (Lisp_Object prefix) { - return Fmake_temp_file_internal (prefix, make_number (0), + return Fmake_temp_file_internal (prefix, make_fixnum (0), empty_unibyte_string, Qnil); } @@ -786,7 +790,7 @@ the root directory. */) CHECK_STRING (name); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (name, Qexpand_file_name); if (!NILP (handler)) { @@ -818,17 +822,14 @@ the root directory. */) #endif } - if (!NILP (default_directory)) + handler = Ffind_file_name_handler (default_directory, Qexpand_file_name); + if (!NILP (handler)) { - handler = Ffind_file_name_handler (default_directory, Qexpand_file_name); - if (!NILP (handler)) - { - handled_name = call3 (handler, Qexpand_file_name, - name, default_directory); - if (STRINGP (handled_name)) - return handled_name; - error ("Invalid handler in `file-name-handler-alist'"); - } + handled_name = call3 (handler, Qexpand_file_name, + name, default_directory); + if (STRINGP (handled_name)) + return handled_name; + error ("Invalid handler in `file-name-handler-alist'"); } { @@ -1093,23 +1094,11 @@ the root directory. */) { Lisp_Object tem; - if (!(newdir = egetenv ("HOME"))) - newdir = newdirlim = ""; + newdir = get_homedir (); nm++; -#ifdef WINDOWSNT - if (newdir[0]) - { - char newdir_utf8[MAX_UTF8_PATH]; - - filename_from_ansi (newdir, newdir_utf8); - tem = make_unibyte_string (newdir_utf8, strlen (newdir_utf8)); - newdir = SSDATA (tem); - } - else -#endif - tem = build_string (newdir); + tem = build_string (newdir); newdirlim = newdir + SBYTES (tem); - /* `egetenv' may return a unibyte string, which will bite us + /* get_homedir may return a unibyte string, which will bite us if we expect the directory to be multibyte. */ if (multibyte && !STRING_MULTIBYTE (tem)) { @@ -1458,7 +1447,7 @@ the root directory. */) } /* Again look to see if the file name has special constructs in it - and perhaps call the corresponding file handler. This is needed + and perhaps call the corresponding file name handler. This is needed for filenames such as "/foo/../user@host:/bar/../baz". Expanding the ".." component gives us "/user@host:/bar/../baz" which needs to be expanded again. */ @@ -1637,7 +1626,6 @@ See also the function `substitute-in-file-name'.") } #endif -/* If /~ or // appears, discard everything through first slash. */ static bool file_name_absolute_p (const char *filename) { @@ -1650,6 +1638,102 @@ file_name_absolute_p (const char *filename) ); } +/* Put into BUF the concatenation of DIR and FILE, with an intervening + directory separator if needed. Return a pointer to the null byte + at the end of the concatenated string. */ +char * +splice_dir_file (char *buf, char const *dir, char const *file) +{ + char *e = stpcpy (buf, dir); + *e = DIRECTORY_SEP; + e += ! (buf < e && IS_DIRECTORY_SEP (e[-1])); + return stpcpy (e, file); +} + +/* Get the home directory, an absolute file name. Return the empty + string on failure. The returned value does not survive garbage + collection, calls to this function, or calls to the getpwnam class + of functions. */ +char const * +get_homedir (void) +{ + char const *home = egetenv ("HOME"); + +#ifdef WINDOWSNT + /* getpw* functions return UTF-8 encoded file names, whereas egetenv + returns strings in locale encoding, so we need to convert for + consistency. */ + static char homedir_utf8[MAX_UTF8_PATH]; + if (home) + { + filename_from_ansi (home, homedir_utf8); + home = homedir_utf8; + } +#endif + + if (!home) + { + static char const *userenv[] = {"LOGNAME", "USER"}; + struct passwd *pw = NULL; + for (int i = 0; i < ARRAYELTS (userenv); i++) + { + char *user = egetenv (userenv[i]); + if (user) + { + pw = getpwnam (user); + if (pw) + break; + } + } + if (!pw) + pw = getpwuid (getuid ()); + if (pw) + home = pw->pw_dir; + if (!home) + return ""; + } +#ifdef DOS_NT + /* If home is a drive-relative directory, expand it. */ + if (IS_DRIVE (*home) + && IS_DEVICE_SEP (home[1]) + && !IS_DIRECTORY_SEP (home[2])) + { +# ifdef WINDOWSNT + static char hdir[MAX_UTF8_PATH]; +# else + static char hdir[MAXPATHLEN]; +# endif + if (!getdefdir (c_toupper (*home) - 'A' + 1, hdir)) + { + hdir[0] = c_toupper (*home); + hdir[1] = ':'; + hdir[2] = '/'; + hdir[3] = '\0'; + } + if (home[2]) + { + size_t homelen = strlen (hdir); + if (!IS_DIRECTORY_SEP (hdir[homelen - 1])) + strcat (hdir, "/"); + strcat (hdir, home + 2); + } + home = hdir; + } +#endif + if (IS_ABSOLUTE_FILE_NAME (home)) + return home; + if (!emacs_wd) + error ("$HOME is relative to unknown directory"); + static char *ahome; + static ptrdiff_t ahomesize; + ptrdiff_t ahomelenbound = strlen (emacs_wd) + 1 + strlen (home) + 1; + if (ahomesize <= ahomelenbound) + ahome = xpalloc (ahome, &ahomesize, ahomelenbound + 1 - ahomesize, -1, 1); + splice_dir_file (ahome, emacs_wd, home); + return ahome; +} + +/* If /~ or // appears, discard everything through first slash. */ static char * search_embedded_absfilename (char *nm, char *endp) { @@ -1716,7 +1800,7 @@ those `/' is discarded. */) multibyte = STRING_MULTIBYTE (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name); if (!NILP (handler)) { @@ -1930,7 +2014,7 @@ permissions. */) newname = expand_cp_target (file, newname); /* If the input file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (file, Qcopy_file); /* Likewise for output file name. */ if (NILP (handler)) @@ -1945,9 +2029,9 @@ permissions. */) #ifdef WINDOWSNT if (NILP (ok_if_already_exists) - || INTEGERP (ok_if_already_exists)) + || FIXNUMP (ok_if_already_exists)) barf_or_query_if_file_exists (newname, false, "copy to it", - INTEGERP (ok_if_already_exists), false); + FIXNUMP (ok_if_already_exists), false); result = w32_copy_file (SSDATA (encoded_file), SSDATA (encoded_newname), !NILP (keep_time), !NILP (preserve_uid_gid), @@ -2002,9 +2086,9 @@ permissions. */) new_mask); if (ofd < 0 && errno == EEXIST) { - if (NILP (ok_if_already_exists) || INTEGERP (ok_if_already_exists)) + if (NILP (ok_if_already_exists) || FIXNUMP (ok_if_already_exists)) barf_or_query_if_file_exists (newname, true, "copy to it", - INTEGERP (ok_if_already_exists), false); + FIXNUMP (ok_if_already_exists), false); already_exists = true; ofd = emacs_open (SSDATA (encoded_newname), O_WRONLY, 0); } @@ -2291,11 +2375,26 @@ The arg must be a string. */) filename = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qfile_name_case_insensitive_p); if (!NILP (handler)) return call2 (handler, Qfile_name_case_insensitive_p, filename); + /* If the file doesn't exist, move up the filesystem tree until we + reach an existing directory or the root. */ + if (NILP (Ffile_exists_p (filename))) + { + filename = Ffile_name_directory (filename); + while (NILP (Ffile_exists_p (filename))) + { + Lisp_Object newname = expand_and_dir_to_file (filename); + /* Avoid infinite loop if the root is reported as non-existing + (impossible?). */ + if (!NILP (Fstring_equal (newname, filename))) + break; + filename = newname; + } + } filename = ENCODE_FILE (filename); return file_name_case_insensitive_p (SSDATA (filename)) ? Qt : Qnil; } @@ -2337,7 +2436,7 @@ This is what happens in interactive use with M-x. */) newname = expand_cp_target (Fdirectory_file_name (file), newname); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (file, Qrename_file); if (NILP (handler)) handler = Ffind_file_name_handler (newname, Qrename_file); @@ -2350,7 +2449,7 @@ This is what happens in interactive use with M-x. */) bool plain_rename = (case_only_rename || (!NILP (ok_if_already_exists) - && !INTEGERP (ok_if_already_exists))); + && !FIXNUMP (ok_if_already_exists))); int rename_errno UNINIT; if (!plain_rename) { @@ -2368,7 +2467,7 @@ This is what happens in interactive use with M-x. */) #endif barf_or_query_if_file_exists (newname, rename_errno == EEXIST, "rename to it", - INTEGERP (ok_if_already_exists), + FIXNUMP (ok_if_already_exists), false); plain_rename = true; break; @@ -2439,14 +2538,14 @@ This is what happens in interactive use with M-x. */) newname = expand_cp_target (file, newname); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (file, Qadd_name_to_file); if (!NILP (handler)) return call4 (handler, Qadd_name_to_file, file, newname, ok_if_already_exists); /* If the new name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (newname, Qadd_name_to_file); if (!NILP (handler)) return call4 (handler, Qadd_name_to_file, file, @@ -2461,9 +2560,9 @@ This is what happens in interactive use with M-x. */) if (errno == EEXIST) { if (NILP (ok_if_already_exists) - || INTEGERP (ok_if_already_exists)) + || FIXNUMP (ok_if_already_exists)) barf_or_query_if_file_exists (newname, true, "make it a new name", - INTEGERP (ok_if_already_exists), false); + FIXNUMP (ok_if_already_exists), false); unlink (SSDATA (newname)); if (link (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0) return Qnil; @@ -2489,17 +2588,17 @@ This happens for interactive use with M-x. */) Lisp_Object encoded_target, encoded_linkname; CHECK_STRING (target); - if (INTEGERP (ok_if_already_exists)) + if (FIXNUMP (ok_if_already_exists)) { if (SREF (target, 0) == '~') target = Fexpand_file_name (target, Qnil); else if (SREF (target, 0) == '/' && SREF (target, 1) == ':') - target = Fsubstring_no_properties (target, make_number (2), Qnil); + target = Fsubstring_no_properties (target, make_fixnum (2), Qnil); } linkname = expand_cp_target (target, linkname); /* If the new link name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link); if (!NILP (handler)) return call4 (handler, Qmake_symbolic_link, target, @@ -2518,9 +2617,9 @@ This happens for interactive use with M-x. */) if (errno == EEXIST) { if (NILP (ok_if_already_exists) - || INTEGERP (ok_if_already_exists)) + || FIXNUMP (ok_if_already_exists)) barf_or_query_if_file_exists (linkname, true, "make it a link", - INTEGERP (ok_if_already_exists), false); + FIXNUMP (ok_if_already_exists), false); unlink (SSDATA (encoded_linkname)); if (symlink (SSDATA (encoded_target), SSDATA (encoded_linkname)) == 0) return Qnil; @@ -2554,7 +2653,7 @@ Use `file-symlink-p' to test for such links. */) absname = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qfile_exists_p); if (!NILP (handler)) { @@ -2582,7 +2681,7 @@ purpose, though.) */) absname = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qfile_executable_p); if (!NILP (handler)) return call2 (handler, Qfile_executable_p, absname); @@ -2604,7 +2703,7 @@ See also `file-exists-p' and `file-attributes'. */) absname = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qfile_readable_p); if (!NILP (handler)) return call2 (handler, Qfile_readable_p, absname); @@ -2625,7 +2724,7 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, absname = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qfile_writable_p); if (!NILP (handler)) return call2 (handler, Qfile_writable_p, absname); @@ -2647,7 +2746,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 (SSDATA (dir)) ? Qt : Qnil; + return file_directory_p (dir) ? Qt : Qnil; #else return check_writable (SSDATA (dir), W_OK | X_OK) ? Qt : Qnil; #endif @@ -2667,7 +2766,7 @@ If there is no error, returns nil. */) CHECK_STRING (string); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qaccess_file); if (!NILP (handler)) return call3 (handler, Qaccess_file, absname, string); @@ -2715,7 +2814,7 @@ This function does not check whether the link target exists. */) filename = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qfile_symlink_p); if (!NILP (handler)) return call2 (handler, Qfile_symlink_p, filename); @@ -2734,26 +2833,54 @@ See `file-symlink-p' to distinguish symlinks. */) Lisp_Object absname = expand_and_dir_to_file (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_directory_p); if (!NILP (handler)) return call2 (handler, Qfile_directory_p, absname); absname = ENCODE_FILE (absname); - return file_directory_p (SSDATA (absname)) ? Qt : Qnil; + return file_directory_p (absname) ? Qt : Qnil; } -/* Return true if FILE is a directory or a symlink to a directory. */ +/* Return true if FILE is a directory or a symlink to a directory. + Otherwise return false and set errno. */ bool -file_directory_p (char const *file) +file_directory_p (Lisp_Object file) { -#ifdef WINDOWSNT +#ifdef DOS_NT /* This is cheaper than 'stat'. */ - return faccessat (AT_FDCWD, file, D_OK, AT_EACCESS) == 0; + return faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0; #else +# ifdef O_PATH + /* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */ + int fd = openat (AT_FDCWD, SSDATA (file), O_PATH | O_CLOEXEC | O_DIRECTORY); + if (0 <= fd) + { + emacs_close (fd); + return true; + } + if (errno != EINVAL) + return false; + /* O_PATH is defined but evidently this Linux kernel predates 2.6.39. + Fall back on generic POSIX code. */ +# endif + /* Use file_accessible_directory, as it avoids stat EOVERFLOW + problems and could be cheaper. However, if it fails because FILE + is inaccessible, fall back on stat; if the latter fails with + EOVERFLOW then FILE must have been a directory unless a race + condition occurred (a problem hard to work around portably). */ + if (file_accessible_directory_p (file)) + return true; + if (errno != EACCES) + return false; struct stat st; - return stat (file, &st) == 0 && S_ISDIR (st.st_mode); + if (stat (SSDATA (file), &st) != 0) + return errno == EOVERFLOW; + if (S_ISDIR (st.st_mode)) + return true; + errno = ENOTDIR; + return false; #endif } @@ -2775,7 +2902,7 @@ really is a readable and searchable directory. */) absname = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qfile_accessible_directory_p); if (!NILP (handler)) { @@ -2814,7 +2941,7 @@ file_accessible_directory_p (Lisp_Object file) return (SBYTES (file) == 0 || w32_accessible_directory_p (SSDATA (file), SBYTES (file))); # else /* MSDOS */ - return file_directory_p (SSDATA (file)); + return file_directory_p (file); # endif /* MSDOS */ #else /* !DOS_NT */ /* On POSIXish platforms, use just one system call; this avoids a @@ -2835,12 +2962,15 @@ file_accessible_directory_p (Lisp_Object file) dir = data; else { - /* Just check for trailing '/' when deciding whether to append '/'. - That's simpler than testing the two special cases "/" and "//", - and it's a safe optimization here. */ - char *buf = SAFE_ALLOCA (len + 3); + /* Just check for trailing '/' when deciding whether append '/' + before appending '.'. That's simpler than testing the two + special cases "/" and "//", and it's a safe optimization + here. After appending '.', append another '/' to work around + a macOS bug (Bug#30350). */ + static char const appended[] = "/./"; + char *buf = SAFE_ALLOCA (len + sizeof appended); memcpy (buf, data, len); - strcpy (buf + len, &"/."[data[len - 1] == '/']); + strcpy (buf + len, &appended[data[len - 1] == '/']); dir = buf; } @@ -2863,7 +2993,7 @@ See `file-symlink-p' to distinguish symlinks. */) Lisp_Object absname = expand_and_dir_to_file (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_regular_p); if (!NILP (handler)) return call2 (handler, Qfile_regular_p, absname); @@ -2906,7 +3036,7 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */) Lisp_Object absname = expand_and_dir_to_file (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_selinux_context); if (!NILP (handler)) @@ -2968,7 +3098,7 @@ or if Emacs was not compiled with SELinux support. */) absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qset_file_selinux_context); if (!NILP (handler)) return call3 (handler, Qset_file_selinux_context, absname, context); @@ -3038,7 +3168,7 @@ was unable to determine the ACL entries. */) Lisp_Object absname = expand_and_dir_to_file (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_acl); if (!NILP (handler)) return call2 (handler, Qfile_acl, absname); @@ -3093,7 +3223,7 @@ support. */) absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qset_file_acl); if (!NILP (handler)) return call3 (handler, Qset_file_acl, absname, acl_string); @@ -3135,7 +3265,7 @@ Return nil, if file does not exist or is not accessible. */) Lisp_Object absname = expand_and_dir_to_file (filename); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_modes); if (!NILP (handler)) return call2 (handler, Qfile_modes, absname); @@ -3145,7 +3275,7 @@ Return nil, if file does not exist or is not accessible. */) if (stat (SSDATA (absname), &st) < 0) return Qnil; - return make_number (st.st_mode & 07777); + return make_fixnum (st.st_mode & 07777); } DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, @@ -3162,17 +3292,17 @@ symbolic notation, like the `chmod' command from GNU Coreutils. */) Lisp_Object handler; absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); - CHECK_NUMBER (mode); + CHECK_FIXNUM (mode); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qset_file_modes); if (!NILP (handler)) return call3 (handler, Qset_file_modes, absname, mode); encoded_absname = ENCODE_FILE (absname); - if (chmod (SSDATA (encoded_absname), XINT (mode) & 07777) < 0) + if (chmod (SSDATA (encoded_absname), XFIXNUM (mode) & 07777) < 0) report_file_error ("Doing chmod", absname); return Qnil; @@ -3193,9 +3323,9 @@ by having the corresponding bit in the mask reset. */) (Lisp_Object mode) { mode_t oldrealmask, oldumask, newumask; - CHECK_NUMBER (mode); + CHECK_FIXNUM (mode); oldrealmask = realmask; - newumask = ~ XINT (mode) & 0777; + newumask = ~ XFIXNUM (mode) & 0777; block_input (); realmask = newumask; @@ -3232,7 +3362,7 @@ Use the current time if TIMESTAMP is nil. TIMESTAMP is in the format of absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (absname, Qset_file_times); if (!NILP (handler)) return call3 (handler, Qset_file_times, absname, timestamp); @@ -3244,7 +3374,7 @@ Use the current time if TIMESTAMP is nil. TIMESTAMP is in the format of { #ifdef MSDOS /* Setting times on a directory always fails. */ - if (file_directory_p (SSDATA (encoded_absname))) + if (file_directory_p (encoded_absname)) return Qnil; #endif report_file_error ("Setting file times", absname); @@ -3280,7 +3410,7 @@ otherwise, if FILE2 does not exist, the answer is t. */) Lisp_Object absname2 = expand_and_dir_to_file (file2); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname1, Qfile_newer_than_file_p); if (NILP (handler)) @@ -3339,21 +3469,28 @@ decide_coding_unwind (Lisp_Object unwind_data) bset_undo_list (current_buffer, undo_list); } -/* Read from a non-regular file. STATE is a Lisp_Save_Value - object where slot 0 is the file descriptor, slot 1 specifies - an offset to put the read bytes, and slot 2 is the maximum - amount of bytes to read. Value is the number of bytes read. */ +/* Read from a non-regular file. Return the number of bytes read. */ + +union read_non_regular +{ + struct + { + int fd; + ptrdiff_t inserted, trytry; + } s; + GCALIGNED_UNION_MEMBER +}; +verify (GCALIGNED (union read_non_regular)); static Lisp_Object read_non_regular (Lisp_Object state) { - int nbytes = emacs_read_quit (XSAVE_INTEGER (state, 0), + union read_non_regular *data = XFIXNUMPTR (state); + int nbytes = emacs_read_quit (data->s.fd, ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE - + XSAVE_INTEGER (state, 1)), - XSAVE_INTEGER (state, 2)); - /* Fast recycle this object for the likely next call. */ - free_misc (state); - return make_number (nbytes); + + data->s.inserted), + data->s.trytry); + return make_fixnum (nbytes); } @@ -3371,10 +3508,13 @@ read_non_regular_quit (Lisp_Object ignore) static off_t file_offset (Lisp_Object val) { - if (RANGED_INTEGERP (0, val, TYPE_MAXIMUM (off_t))) - return XINT (val); - - if (FLOATP (val)) + if (INTEGERP (val)) + { + intmax_t v; + if (integer_to_intmax (val, &v) && 0 <= v && v <= TYPE_MAXIMUM (off_t)) + return v; + } + else if (FLOATP (val)) { double v = XFLOAT_DATA (val); if (0 <= v && v < 1.0 + TYPE_MAXIMUM (off_t)) @@ -3431,16 +3571,16 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted, Lisp_Object car = XCAR (window_markers); Lisp_Object marker = XCAR (car); Lisp_Object oldpos = XCDR (car); - if (MARKERP (marker) && INTEGERP (oldpos) - && XINT (oldpos) > same_at_start - && XINT (oldpos) < same_at_end) + if (MARKERP (marker) && FIXNUMP (oldpos) + && XFIXNUM (oldpos) > same_at_start + && XFIXNUM (oldpos) < same_at_end) { ptrdiff_t oldsize = same_at_end - same_at_start; ptrdiff_t newsize = inserted; double growth = newsize / (double)oldsize; ptrdiff_t newpos - = same_at_start + growth * (XINT (oldpos) - same_at_start); - Fset_marker (marker, make_number (newpos), Qnil); + = same_at_start + growth * (XFIXNUM (oldpos) - same_at_start); + Fset_marker (marker, make_fixnum (newpos), Qnil); } } } @@ -3546,15 +3686,15 @@ by calling `format-decode', which see. */) coding_system = Qnil; /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qinsert_file_contents); if (!NILP (handler)) { val = call6 (handler, Qinsert_file_contents, filename, visit, beg, end, replace); if (CONSP (val) && CONSP (XCDR (val)) - && RANGED_INTEGERP (0, XCAR (XCDR (val)), ZV - PT)) - inserted = XINT (XCAR (XCDR (val))); + && RANGED_FIXNUMP (0, XCAR (XCDR (val)), ZV - PT)) + inserted = XFIXNUM (XCAR (XCDR (val))); goto handled; } @@ -3739,7 +3879,7 @@ by calling `format-decode', which see. */) insert_1_both ((char *) read_buf, nread, nread, 0, 0, 0); TEMP_SET_PT_BOTH (BEG, BEG_BYTE); coding_system = call2 (Vset_auto_coding_function, - filename, make_number (nread)); + filename, make_fixnum (nread)); set_buffer_internal (prev); /* Discard the unwind protect for recovering the @@ -4207,9 +4347,9 @@ by calling `format-decode', which see. */) /* Read from the file, capturing `quit'. When an error occurs, end the loop, and arrange for a quit to be signaled after decoding the text we read. */ + union read_non_regular data = {{fd, inserted, trytry}}; nbytes = internal_condition_case_1 - (read_non_regular, - make_save_int_int_int (fd, inserted, trytry), + (read_non_regular, make_pointer_integer (&data), Qerror, read_non_regular_quit); if (NILP (nbytes)) @@ -4218,7 +4358,7 @@ by calling `format-decode', which see. */) break; } - this = XINT (nbytes); + this = XFIXNUM (nbytes); } else { @@ -4314,7 +4454,7 @@ by calling `format-decode', which see. */) if (inserted > 0 && ! NILP (Vset_auto_coding_function)) { coding_system = call2 (Vset_auto_coding_function, - filename, make_number (inserted)); + filename, make_fixnum (inserted)); } if (NILP (coding_system)) @@ -4433,13 +4573,13 @@ by calling `format-decode', which see. */) if (! NILP (Ffboundp (Qafter_insert_file_set_coding))) { - insval = call2 (Qafter_insert_file_set_coding, make_number (inserted), + insval = call2 (Qafter_insert_file_set_coding, make_fixnum (inserted), visit); if (! NILP (insval)) { - if (! RANGED_INTEGERP (0, insval, ZV - PT)) + if (! RANGED_FIXNUMP (0, insval, ZV - PT)) wrong_type_argument (intern ("inserted-chars"), insval); - inserted = XFASTINT (insval); + inserted = XFIXNAT (insval); } } @@ -4459,10 +4599,10 @@ by calling `format-decode', which see. */) if (NILP (replace)) { insval = call3 (Qformat_decode, - Qnil, make_number (inserted), visit); - if (! RANGED_INTEGERP (0, insval, ZV - PT)) + Qnil, make_fixnum (inserted), visit); + if (! RANGED_FIXNUMP (0, insval, ZV - PT)) wrong_type_argument (intern ("inserted-chars"), insval); - inserted = XFASTINT (insval); + inserted = XFIXNAT (insval); } else { @@ -4482,8 +4622,8 @@ by calling `format-decode', which see. */) TEMP_SET_PT_BOTH (BEGV, BEGV_BYTE); insval = call3 (Qformat_decode, - Qnil, make_number (oinserted), visit); - if (! RANGED_INTEGERP (0, insval, ZV - PT)) + Qnil, make_fixnum (oinserted), visit); + if (! RANGED_FIXNUMP (0, insval, ZV - PT)) wrong_type_argument (intern ("inserted-chars"), insval); if (ochars_modiff == CHARS_MODIFF) /* format_decode didn't modify buffer's characters => move @@ -4493,7 +4633,7 @@ by calling `format-decode', which see. */) else /* format_decode modified buffer's characters => consider entire buffer changed and leave point at point-min. */ - inserted = XFASTINT (insval); + inserted = XFIXNAT (insval); } /* For consistency with format-decode call these now iff inserted > 0 @@ -4503,12 +4643,12 @@ by calling `format-decode', which see. */) { if (NILP (replace)) { - insval = call1 (XCAR (p), make_number (inserted)); + insval = call1 (XCAR (p), make_fixnum (inserted)); if (!NILP (insval)) { - if (! RANGED_INTEGERP (0, insval, ZV - PT)) + if (! RANGED_FIXNUMP (0, insval, ZV - PT)) wrong_type_argument (intern ("inserted-chars"), insval); - inserted = XFASTINT (insval); + inserted = XFIXNAT (insval); } } else @@ -4521,10 +4661,10 @@ by calling `format-decode', which see. */) EMACS_INT ochars_modiff = CHARS_MODIFF; TEMP_SET_PT_BOTH (BEGV, BEGV_BYTE); - insval = call1 (XCAR (p), make_number (oinserted)); + insval = call1 (XCAR (p), make_fixnum (oinserted)); if (!NILP (insval)) { - if (! RANGED_INTEGERP (0, insval, ZV - PT)) + if (! RANGED_FIXNUMP (0, insval, ZV - PT)) wrong_type_argument (intern ("inserted-chars"), insval); if (ochars_modiff == CHARS_MODIFF) /* after_insert_file_functions didn't modify @@ -4536,7 +4676,7 @@ by calling `format-decode', which see. */) /* after_insert_file_functions did modify buffer's characters => consider entire buffer changed and leave point at point-min. */ - inserted = XFASTINT (insval); + inserted = XFIXNAT (insval); } } @@ -4552,10 +4692,10 @@ by calling `format-decode', which see. */) /* Adjust the last undo record for the size change during the format conversion. */ Lisp_Object tem = XCAR (old_undo); - if (CONSP (tem) && INTEGERP (XCAR (tem)) - && INTEGERP (XCDR (tem)) - && XFASTINT (XCDR (tem)) == PT + old_inserted) - XSETCDR (tem, make_number (PT + inserted)); + if (CONSP (tem) && FIXNUMP (XCAR (tem)) + && FIXNUMP (XCDR (tem)) + && XFIXNAT (XCDR (tem)) == PT + old_inserted) + XSETCDR (tem, make_fixnum (PT + inserted)); } } else @@ -4590,7 +4730,7 @@ by calling `format-decode', which see. */) /* Retval needs to be dealt with in all cases consistently. */ if (NILP (val)) - val = list2 (orig_filename, make_number (inserted)); + val = list2 (orig_filename, make_fixnum (inserted)); return unbind_to (count, val); } @@ -4817,7 +4957,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, annotations = Qnil; /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qwrite_region); /* If FILENAME has no handler, see if VISIT has one. */ if (NILP (handler) && STRINGP (visit)) @@ -4932,14 +5072,14 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, if (STRINGP (start)) ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding); - else if (XINT (start) != XINT (end)) - ok = a_write (desc, Qnil, XINT (start), XINT (end) - XINT (start), + else if (XFIXNUM (start) != XFIXNUM (end)) + ok = a_write (desc, Qnil, XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), &annotations, &coding); else { /* If file was empty, still need to write the annotations. */ coding.mode |= CODING_MODE_LAST_BLOCK; - ok = a_write (desc, Qnil, XINT (end), 0, &annotations, &coding); + ok = a_write (desc, Qnil, XFIXNUM (end), 0, &annotations, &coding); } save_errno = errno; @@ -5186,7 +5326,7 @@ build_annotations (Lisp_Object start, Lisp_Object end) has written annotations to a temporary buffer, which is now current. */ res = call5 (Qformat_annotate_function, XCAR (p), start, end, - original_buffer, make_number (i)); + original_buffer, make_fixnum (i)); if (current_buffer != given_buffer) { XSETFASTINT (start, BEGV); @@ -5225,8 +5365,8 @@ a_write (int desc, Lisp_Object string, ptrdiff_t pos, { tem = Fcar_safe (Fcar (*annot)); nextpos = pos - 1; - if (INTEGERP (tem)) - nextpos = XFASTINT (tem); + if (FIXNUMP (tem)) + nextpos = XFIXNAT (tem); /* If there are no more annotations in this range, output the rest of the range all at once. */ @@ -5377,7 +5517,7 @@ See Info node `(elisp)Modification Time' for more details. */) if (b->modtime.tv_nsec == UNKNOWN_MODTIME_NSECS) return Qt; /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (BVAR (b, filename), Qverify_visited_file_modtime); if (!NILP (handler)) @@ -5398,16 +5538,15 @@ See Info node `(elisp)Modification Time' for more details. */) DEFUN ("visited-file-modtime", Fvisited_file_modtime, Svisited_file_modtime, 0, 0, 0, doc: /* Return the current buffer's recorded visited file modification time. -The value is a list of the form (HIGH LOW USEC PSEC), like the time values that -`file-attributes' returns. If the current buffer has no recorded file -modification time, this function returns 0. If the visited file -doesn't exist, return -1. +Return a Lisp timestamp (as in `current-time') if the current buffer +has a recorded file modification time, 0 if it doesn't, and -1 if the +visited file doesn't exist. See Info node `(elisp)Modification Time' for more details. */) (void) { int ns = current_buffer->modtime.tv_nsec; if (ns < 0) - return make_number (UNKNOWN_MODTIME_NSECS - ns); + return make_fixnum (UNKNOWN_MODTIME_NSECS - ns); return make_lisp_time (current_buffer->modtime); } @@ -5417,18 +5556,17 @@ DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime, Useful if the buffer was not read from the file normally or if the file itself has been changed for some known benign reason. An argument specifies the modification time value to use -\(instead of that of the visited file), in the form of a list -\(HIGH LOW USEC PSEC) or an integer flag as returned by -`visited-file-modtime'. */) +\(instead of that of the visited file), in the form of a time value as +in `current-time' or an integer flag as returned by `visited-file-modtime'. */) (Lisp_Object time_flag) { if (!NILP (time_flag)) { struct timespec mtime; - if (INTEGERP (time_flag)) + if (FIXNUMP (time_flag)) { CHECK_RANGED_INTEGER (time_flag, -1, 0); - mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - XINT (time_flag)); + mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - XFIXNUM (time_flag)); } else mtime = lisp_time_argument (time_flag); @@ -5445,7 +5583,7 @@ An argument specifies the modification time value to use filename = Fexpand_file_name (BVAR (current_buffer, filename), Qnil); /* If the file name has special constructs in it, - call the corresponding file handler. */ + call the corresponding file name handler. */ handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime); if (!NILP (handler)) /* The handler can find the file name the same way we did. */ @@ -5494,9 +5632,9 @@ auto_save_1 (void) /* But make sure we can overwrite it later! */ auto_save_mode_bits = (st.st_mode | 0600) & 0777; else if (modes = Ffile_modes (BVAR (current_buffer, filename)), - INTEGERP (modes)) + FIXNUMP (modes)) /* Remote files don't cooperate with stat. */ - auto_save_mode_bits = (XINT (modes) | 0600) & 0777; + auto_save_mode_bits = (XFIXNUM (modes) | 0600) & 0777; } return @@ -5663,7 +5801,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b) && BUF_AUTOSAVE_MODIFF (b) < BUF_MODIFF (b) /* -1 means we've turned off autosaving for a while--see below. */ - && XINT (BVAR (b, save_length)) >= 0 + && XFIXNUM (BVAR (b, save_length)) >= 0 && (do_handled_files || NILP (Ffind_file_name_handler (BVAR (b, auto_save_file_name), Qwrite_region)))) @@ -5678,13 +5816,13 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) set_buffer_internal (b); if (NILP (Vauto_save_include_big_deletions) - && (XFASTINT (BVAR (b, save_length)) * 10 + && (XFIXNAT (BVAR (b, save_length)) * 10 > (BUF_Z (b) - BUF_BEG (b)) * 13) /* A short file is likely to change a large fraction; spare the user annoying messages. */ - && XFASTINT (BVAR (b, save_length)) > 5000 + && XFIXNAT (BVAR (b, save_length)) > 5000 /* These messages are frequent and annoying for `*mail*'. */ - && !EQ (BVAR (b, filename), Qnil) + && !NILP (BVAR (b, filename)) && NILP (no_message)) { /* It has shrunk too much; turn off auto-saving here. */ @@ -5695,7 +5833,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) /* Turn off auto-saving until there's a real save, and prevent any more warnings. */ XSETINT (BVAR (b, save_length), -1); - Fsleep_for (make_number (1), Qnil); + Fsleep_for (make_fixnum (1), Qnil); continue; } if (!auto_saved && NILP (no_message)) @@ -5724,7 +5862,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) { /* If we are going to restore an old message, give time to read ours. */ - sit_for (make_number (1), 0, 0); + sit_for (make_fixnum (1), 0, 0); restore_message (); } else if (!auto_save_error_occurred) @@ -5737,8 +5875,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) Vquit_flag = oquit; /* This restores the message-stack status. */ - unbind_to (count, Qnil); - return Qnil; + return unbind_to (count, Qnil); } DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, @@ -5839,6 +5976,52 @@ effect except for flushing STREAM's data. */) return (set_binary_mode (fileno (fp), binmode) == O_BINARY) ? Qt : Qnil; } +#ifndef DOS_NT + +/* Yield a Lisp float as close as possible to BLOCKSIZE * BLOCKS, with + the result negated if NEGATE. */ +static Lisp_Object +blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate) +{ + /* On typical platforms the following code is accurate to 53 bits, + which is close enough. BLOCKSIZE is invariably a power of 2, so + converting it to double does not lose information. */ + double bs = blocksize; + return make_float (negate ? -bs * -blocks : bs * blocks); +} + +DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0, + doc: /* Return storage information about the file system FILENAME is on. +Value is a list of numbers (TOTAL FREE AVAIL), where TOTAL is the total +storage of the file system, FREE is the free storage, and AVAIL is the +storage available to a non-superuser. All 3 numbers are in bytes. +If the underlying system call fails, value is nil. */) + (Lisp_Object filename) +{ + Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (filename, Qnil)); + + /* If the file name has special constructs in it, + call the corresponding file name handler. */ + Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info); + if (!NILP (handler)) + { + Lisp_Object result = call2 (handler, Qfile_system_info, encoded); + if (CONSP (result) || NILP (result)) + return result; + error ("Invalid handler in `file-name-handler-alist'"); + } + + struct fs_usage u; + if (get_fs_usage (SSDATA (encoded), NULL, &u) != 0) + return Qnil; + return list3 (blocks_to_bytes (u.fsu_blocksize, u.fsu_blocks, false), + blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false), + blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail, + u.fsu_bavail_top_bit_set)); +} + +#endif /* !DOS_NT */ + void init_fileio (void) { @@ -5909,6 +6092,7 @@ syms_of_fileio (void) DEFSYM (Qwrite_region, "write-region"); DEFSYM (Qverify_visited_file_modtime, "verify-visited-file-modtime"); DEFSYM (Qset_visited_file_modtime, "set-visited-file-modtime"); + DEFSYM (Qfile_system_info, "file-system-info"); /* The symbol bound to coding-system-for-read when insert-file-contents is called for recovering a file. This is not @@ -6189,6 +6373,10 @@ This includes interactive calls to `delete-file' and defsubr (&Sset_binary_mode); +#ifndef DOS_NT + defsubr (&Sfile_system_info); +#endif + #ifdef HAVE_SYNC defsubr (&Sunix_sync); #endif diff --git a/src/floatfns.c b/src/floatfns.c index 13ecc66fbfa..2d76b97eec7 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -42,18 +42,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include "lisp.h" +#include "bignum.h" #include <math.h> #include <count-leading-zeros.h> -#ifndef isfinite -# define isfinite(x) ((x) - (x) == 0) -#endif -#ifndef isnan -# define isnan(x) ((x) != (x)) -#endif - /* Check that X is a floating point number. */ static void @@ -67,7 +61,7 @@ CHECK_FLOAT (Lisp_Object x) double extract_float (Lisp_Object num) { - CHECK_NUMBER_OR_FLOAT (num); + CHECK_NUMBER (num); return XFLOATINT (num); } @@ -185,7 +179,7 @@ If X is zero, both parts (SGNFCAND and EXP) are zero. */) double f = extract_float (x); int exponent; double sgnfcand = frexp (f, &exponent); - return Fcons (make_float (sgnfcand), make_number (exponent)); + return Fcons (make_float (sgnfcand), make_fixnum (exponent)); } DEFUN ("ldexp", Fldexp, Sldexp, 2, 2, 0, @@ -193,8 +187,8 @@ DEFUN ("ldexp", Fldexp, Sldexp, 2, 2, 0, EXPONENT must be an integer. */) (Lisp_Object sgnfcand, Lisp_Object exponent) { - CHECK_NUMBER (exponent); - int e = min (max (INT_MIN, XINT (exponent)), INT_MAX); + CHECK_FIXNUM (exponent); + int e = min (max (INT_MIN, XFIXNUM (exponent)), INT_MAX); return make_float (ldexp (extract_float (sgnfcand), e)); } @@ -211,29 +205,14 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, doc: /* Return the exponential ARG1 ** ARG2. */) (Lisp_Object arg1, Lisp_Object arg2) { - CHECK_NUMBER_OR_FLOAT (arg1); - CHECK_NUMBER_OR_FLOAT (arg2); - if (INTEGERP (arg1) /* common lisp spec */ - && INTEGERP (arg2) /* don't promote, if both are ints, and */ - && XINT (arg2) >= 0) /* we are sure the result is not fractional */ - { /* this can be improved by pre-calculating */ - EMACS_INT y; /* some binary powers of x then accumulating */ - EMACS_UINT acc, x; /* Unsigned so that overflow is well defined. */ - Lisp_Object val; - - x = XINT (arg1); - y = XINT (arg2); - acc = (y & 1 ? x : 1); - - while ((y >>= 1) != 0) - { - x *= x; - if (y & 1) - acc *= x; - } - XSETINT (val, acc); - return val; - } + CHECK_NUMBER (arg1); + CHECK_NUMBER (arg2); + + /* Common Lisp spec: don't promote if both are integers, and if the + result is not fractional. */ + if (INTEGERP (arg1) && !NILP (Fnatnump (arg2))) + return expt_integer (arg1, arg2); + return make_float (pow (XFLOATINT (arg1), XFLOATINT (arg2))); } @@ -273,14 +252,28 @@ DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, DEFUN ("abs", Fabs, Sabs, 1, 1, 0, doc: /* Return the absolute value of ARG. */) - (register Lisp_Object arg) + (Lisp_Object arg) { - CHECK_NUMBER_OR_FLOAT (arg); + CHECK_NUMBER (arg); - if (FLOATP (arg)) - arg = make_float (fabs (XFLOAT_DATA (arg))); - else if (XINT (arg) < 0) - XSETINT (arg, - XINT (arg)); + if (FIXNUMP (arg)) + { + if (XFIXNUM (arg) < 0) + arg = make_int (-XFIXNUM (arg)); + } + else if (FLOATP (arg)) + { + if (signbit (XFLOAT_DATA (arg))) + arg = make_float (- XFLOAT_DATA (arg)); + } + else + { + if (mpz_sgn (XBIGNUM (arg)->value) < 0) + { + mpz_neg (mpz[0], XBIGNUM (arg)->value); + arg = make_integer_mpz (); + } + } return arg; } @@ -289,12 +282,9 @@ DEFUN ("float", Ffloat, Sfloat, 1, 1, 0, doc: /* Return the floating point number equal to ARG. */) (register Lisp_Object arg) { - CHECK_NUMBER_OR_FLOAT (arg); - - if (INTEGERP (arg)) - return make_float ((double) XINT (arg)); - else /* give 'em the same float back */ - return arg; + CHECK_NUMBER (arg); + /* If ARG is a float, give 'em the same float back. */ + return FLOATP (arg) ? arg : make_float (XFLOATINT (arg)); } static int @@ -311,7 +301,7 @@ This is the same as the exponent of a float. */) (Lisp_Object arg) { EMACS_INT value; - CHECK_NUMBER_OR_FLOAT (arg); + CHECK_NUMBER (arg); if (FLOATP (arg)) { @@ -328,27 +318,42 @@ This is the same as the exponent of a float. */) else value = MOST_POSITIVE_FIXNUM; } + else if (BIGNUMP (arg)) + value = mpz_sizeinbase (XBIGNUM (arg)->value, 2) - 1; else { - EMACS_INT i = eabs (XINT (arg)); + eassert (FIXNUMP (arg)); + EMACS_INT i = eabs (XFIXNUM (arg)); value = (i == 0 ? MOST_NEGATIVE_FIXNUM : EMACS_UINT_WIDTH - 1 - ecount_leading_zeros (i)); } - return make_number (value); + return make_fixnum (value); } +/* True if A is exactly representable as an integer. */ + +static bool +integer_value (Lisp_Object a) +{ + if (FLOATP (a)) + { + double d = XFLOAT_DATA (a); + return d == floor (d) && isfinite (d); + } + return true; +} /* the rounding functions */ static Lisp_Object rounding_driver (Lisp_Object arg, Lisp_Object divisor, double (*double_round) (double), - EMACS_INT (*int_round2) (EMACS_INT, EMACS_INT), - const char *name) + void (*int_divide) (mpz_t, mpz_t const, mpz_t const), + EMACS_INT (*fixnum_divide) (EMACS_INT, EMACS_INT)) { - CHECK_NUMBER_OR_FLOAT (arg); + CHECK_NUMBER (arg); double d; if (NILP (divisor)) @@ -359,18 +364,36 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor, } else { - CHECK_NUMBER_OR_FLOAT (divisor); - if (!FLOATP (arg) && !FLOATP (divisor)) + CHECK_NUMBER (divisor); + if (integer_value (arg) && integer_value (divisor)) { - if (XINT (divisor) == 0) - xsignal0 (Qarith_error); - return make_number (int_round2 (XINT (arg), XINT (divisor))); + /* Divide as integers. Converting to double might lose + info, even for fixnums; also see the FIXME below. */ + + if (FLOATP (arg)) + arg = double_to_integer (XFLOAT_DATA (arg)); + if (FLOATP (divisor)) + divisor = double_to_integer (XFLOAT_DATA (divisor)); + + if (FIXNUMP (divisor)) + { + if (XFIXNUM (divisor) == 0) + xsignal0 (Qarith_error); + if (FIXNUMP (arg)) + return make_int (fixnum_divide (XFIXNUM (arg), + XFIXNUM (divisor))); + } + int_divide (mpz[0], + *bignum_integer (&mpz[0], arg), + *bignum_integer (&mpz[1], divisor)); + return make_integer_mpz (); } - double f1 = FLOATP (arg) ? XFLOAT_DATA (arg) : XINT (arg); - double f2 = FLOATP (divisor) ? XFLOAT_DATA (divisor) : XINT (divisor); + double f1 = XFLOATINT (arg); + double f2 = XFLOATINT (divisor); if (! IEEE_FLOATING_POINT && f2 == 0) xsignal0 (Qarith_error); + /* FIXME: This division rounds, so the result is double-rounded. */ d = f1 / f2; } @@ -383,42 +406,61 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor, { EMACS_INT ir = dr; if (! FIXNUM_OVERFLOW_P (ir)) - return make_number (ir); + return make_fixnum (ir); } - xsignal2 (Qrange_error, build_string (name), arg); + return double_to_integer (dr); } static EMACS_INT -ceiling2 (EMACS_INT i1, EMACS_INT i2) +ceiling2 (EMACS_INT n, EMACS_INT d) { - return i1 / i2 + ((i1 % i2 != 0) & ((i1 < 0) == (i2 < 0))); + return n / d + ((n % d != 0) & ((n < 0) == (d < 0))); } static EMACS_INT -floor2 (EMACS_INT i1, EMACS_INT i2) +floor2 (EMACS_INT n, EMACS_INT d) { - return i1 / i2 - ((i1 % i2 != 0) & ((i1 < 0) != (i2 < 0))); + return n / d - ((n % d != 0) & ((n < 0) != (d < 0))); } static EMACS_INT -truncate2 (EMACS_INT i1, EMACS_INT i2) +truncate2 (EMACS_INT n, EMACS_INT d) { - return i1 / i2; + return n / d; } static EMACS_INT -round2 (EMACS_INT i1, EMACS_INT i2) -{ - /* The C language's division operator gives us one remainder R, but - we want the remainder R1 on the other side of 0 if R1 is closer - to 0 than R is; because we want to round to even, we also want R1 - if R and R1 are the same distance from 0 and if C's quotient is - odd. */ - EMACS_INT q = i1 / i2; - EMACS_INT r = i1 % i2; +round2 (EMACS_INT n, EMACS_INT d) +{ + /* The C language's division operator gives us the remainder R + corresponding to truncated division, but we want the remainder R1 + on the other side of 0 if R1 is closer to 0 than R is; because we + want to round to even, we also want R1 if R and R1 are the same + distance from 0 and if the truncated quotient is odd. */ + EMACS_INT q = n / d; + EMACS_INT r = n % d; + bool neg_d = d < 0; + bool neg_r = r < 0; EMACS_INT abs_r = eabs (r); - EMACS_INT abs_r1 = eabs (i2) - abs_r; - return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1); + EMACS_INT abs_r1 = eabs (d) - abs_r; + if (abs_r1 < abs_r + (q & 1)) + q += neg_d == neg_r ? 1 : -1; + return q; +} + +static void +rounddiv_q (mpz_t q, mpz_t const n, mpz_t const d) +{ + /* Mimic the source code of round2, using mpz_t instead of EMACS_INT. */ + mpz_t *r = &mpz[2], *abs_r = r, *abs_r1 = &mpz[3]; + mpz_tdiv_qr (q, *r, n, d); + bool neg_d = mpz_sgn (d) < 0; + bool neg_r = mpz_sgn (*r) < 0; + mpz_abs (*abs_r, *r); + mpz_abs (*abs_r1, d); + mpz_sub (*abs_r1, *abs_r1, *abs_r); + if (mpz_cmp (*abs_r1, *abs_r) < (mpz_odd_p (q) != 0)) + (neg_d == neg_r ? mpz_add_ui : mpz_sub_ui) (q, q, 1); } /* The code uses emacs_rint, so that it works to undefine HAVE_RINT @@ -435,11 +477,9 @@ emacs_rint (double d) } #endif -#ifdef HAVE_TRUNC -#define emacs_trunc trunc -#else -static double -emacs_trunc (double d) +#ifndef HAVE_TRUNC +double +trunc (double d) { return (d < 0 ? ceil : floor) (d); } @@ -451,7 +491,7 @@ This rounds the value towards +inf. With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */) (Lisp_Object arg, Lisp_Object divisor) { - return rounding_driver (arg, divisor, ceil, ceiling2, "ceiling"); + return rounding_driver (arg, divisor, ceil, mpz_cdiv_q, ceiling2); } DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0, @@ -460,7 +500,7 @@ This rounds the value towards -inf. With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. */) (Lisp_Object arg, Lisp_Object divisor) { - return rounding_driver (arg, divisor, floor, floor2, "floor"); + return rounding_driver (arg, divisor, floor, mpz_fdiv_q, floor2); } DEFUN ("round", Fround, Sround, 1, 2, 0, @@ -473,7 +513,14 @@ your machine. For example, (round 2.5) can return 3 on some systems, but 2 on others. */) (Lisp_Object arg, Lisp_Object divisor) { - return rounding_driver (arg, divisor, emacs_rint, round2, "round"); + return rounding_driver (arg, divisor, emacs_rint, rounddiv_q, round2); +} + +/* Since rounding_driver truncates anyway, no need to call 'trunc'. */ +static double +identity (double x) +{ + return x; } DEFUN ("truncate", Ftruncate, Struncate, 1, 2, 0, @@ -482,18 +529,15 @@ Rounds ARG toward zero. With optional DIVISOR, truncate ARG/DIVISOR. */) (Lisp_Object arg, Lisp_Object divisor) { - return rounding_driver (arg, divisor, emacs_trunc, truncate2, - "truncate"); + return rounding_driver (arg, divisor, identity, mpz_tdiv_q, truncate2); } Lisp_Object fmod_float (Lisp_Object x, Lisp_Object y) { - double f1, f2; - - f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); - f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); + double f1 = XFLOATINT (x); + double f2 = XFLOATINT (y); f1 = fmod (f1, f2); @@ -543,7 +587,7 @@ DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, { CHECK_FLOAT (arg); double d = XFLOAT_DATA (arg); - d = emacs_trunc (d); + d = trunc (d); return make_float (d); } diff --git a/src/fns.c b/src/fns.c index d6299755201..e40eb2e54a4 100644 --- a/src/fns.c +++ b/src/fns.c @@ -28,6 +28,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <errno.h> #include "lisp.h" +#include "bignum.h" #include "character.h" #include "coding.h" #include "composite.h" @@ -56,15 +57,12 @@ DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, } DEFUN ("random", Frandom, Srandom, 0, 1, 0, - doc: /* Return a pseudo-random number. -All integers representable in Lisp, i.e. between `most-negative-fixnum' -and `most-positive-fixnum', inclusive, are equally likely. - -With positive integer LIMIT, return random number in interval [0,LIMIT). + doc: /* Return a pseudo-random integer. +By default, return a fixnum; all fixnums are equally likely. +With positive fixnum LIMIT, return random integer in interval [0,LIMIT). With argument t, set the random number seed from the system's entropy pool if available, otherwise from less-random volatile data such as the time. With a string argument, set the seed based on the string's contents. -Other values of LIMIT are ignored. See Info node `(elisp)Random Numbers' for more details. */) (Lisp_Object limit) @@ -77,18 +75,18 @@ See Info node `(elisp)Random Numbers' for more details. */) seed_random (SSDATA (limit), SBYTES (limit)); val = get_random (); - if (INTEGERP (limit) && 0 < XINT (limit)) + if (FIXNUMP (limit) && 0 < XFIXNUM (limit)) while (true) { /* Return the remainder, except reject the rare case where get_random returns a number so close to INTMASK that the remainder isn't random. */ - EMACS_INT remainder = val % XINT (limit); - if (val - remainder <= INTMASK - XINT (limit) + 1) - return make_number (remainder); + EMACS_INT remainder = val % XFIXNUM (limit); + if (val - remainder <= INTMASK - XFIXNUM (limit) + 1) + return make_fixnum (remainder); val = get_random (); } - return make_number (val); + return make_fixnum (val); } /* Random data-structure functions. */ @@ -121,7 +119,7 @@ To get the number of bytes, use `string-bytes'. */) CHECK_LIST_END (sequence, sequence); if (MOST_POSITIVE_FIXNUM < i) error ("List too long"); - val = make_number (i); + val = make_fixnum (i); } else if (NILP (sequence)) XSETFASTINT (val, 0); @@ -134,14 +132,37 @@ To get the number of bytes, use `string-bytes'. */) DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0, doc: /* Return the length of a list, but avoid error or infinite loop. This function never gets an error. If LIST is not really a list, -it returns 0. If LIST is circular, it returns a finite value -which is at least the number of distinct elements. */) +it returns 0. If LIST is circular, it returns an integer that is at +least the number of distinct elements. +Value is a fixnum, if it's small enough, otherwise a bignum. */) (Lisp_Object list) { intptr_t len = 0; FOR_EACH_TAIL_SAFE (list) len++; - return make_fixnum_or_float (len); + return INT_TO_INTEGER (len); +} + +DEFUN ("proper-list-p", Fproper_list_p, Sproper_list_p, 1, 1, 0, + doc: /* Return OBJECT's length if it is a proper list, nil otherwise. +A proper list is neither circular nor dotted (i.e., its last cdr is nil). */ + attributes: const) + (Lisp_Object object) +{ + intptr_t len = 0; + Lisp_Object last_tail = object; + Lisp_Object tail = object; + FOR_EACH_TAIL_SAFE (tail) + { + len++; + rarely_quit (len); + last_tail = XCDR (tail); + } + if (!NILP (last_tail)) + return Qnil; + if (MOST_POSITIVE_FIXNUM < len) + xsignal0 (Qoverflow_error); + return make_fixnum (len); } DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0, @@ -150,7 +171,73 @@ If STRING is multibyte, this may be greater than the length of STRING. */) (Lisp_Object string) { CHECK_STRING (string); - return make_number (SBYTES (string)); + return make_fixnum (SBYTES (string)); +} + +DEFUN ("string-distance", Fstring_distance, Sstring_distance, 2, 3, 0, + doc: /* Return Levenshtein distance between STRING1 and STRING2. +The distance is the number of deletions, insertions, and substitutions +required to transform STRING1 into STRING2. +If BYTECOMPARE is nil or omitted, compute distance in terms of characters. +If BYTECOMPARE is non-nil, compute distance in terms of bytes. +Letter-case is significant, but text properties are ignored. */) + (Lisp_Object string1, Lisp_Object string2, Lisp_Object bytecompare) + +{ + CHECK_STRING (string1); + CHECK_STRING (string2); + + bool use_byte_compare = + !NILP (bytecompare) + || (!STRING_MULTIBYTE (string1) && !STRING_MULTIBYTE (string2)); + ptrdiff_t len1 = use_byte_compare ? SBYTES (string1) : SCHARS (string1); + ptrdiff_t len2 = use_byte_compare ? SBYTES (string2) : SCHARS (string2); + ptrdiff_t x, y, lastdiag, olddiag; + + USE_SAFE_ALLOCA; + ptrdiff_t *column = SAFE_ALLOCA ((len1 + 1) * sizeof (ptrdiff_t)); + for (y = 1; y <= len1; y++) + column[y] = y; + + if (use_byte_compare) + { + char *s1 = SSDATA (string1); + char *s2 = SSDATA (string2); + + for (x = 1; x <= len2; x++) + { + column[0] = x; + for (y = 1, lastdiag = x - 1; y <= len1; y++) + { + olddiag = column[y]; + column[y] = min (min (column[y] + 1, column[y-1] + 1), + lastdiag + (s1[y-1] == s2[x-1] ? 0 : 1)); + lastdiag = olddiag; + } + } + } + else + { + int c1, c2; + ptrdiff_t i1, i1_byte, i2 = 0, i2_byte = 0; + for (x = 1; x <= len2; x++) + { + column[0] = x; + FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte); + i1 = i1_byte = 0; + for (y = 1, lastdiag = x - 1; y <= len1; y++) + { + olddiag = column[y]; + FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte); + column[y] = min (min (column[y] + 1, column[y-1] + 1), + lastdiag + (c1 == c2 ? 0 : 1)); + lastdiag = olddiag; + } + } + } + + SAFE_FREE (); + return make_fixnum (column[len1]); } DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0, @@ -204,10 +291,10 @@ If string STR1 is greater, the value is a positive number N; /* For backward compatibility, silently bring too-large positive end values into range. */ - if (INTEGERP (end1) && SCHARS (str1) < XINT (end1)) - end1 = make_number (SCHARS (str1)); - if (INTEGERP (end2) && SCHARS (str2) < XINT (end2)) - end2 = make_number (SCHARS (str2)); + if (FIXNUMP (end1) && SCHARS (str1) < XFIXNUM (end1)) + end1 = make_fixnum (SCHARS (str1)); + if (FIXNUMP (end2) && SCHARS (str2) < XFIXNUM (end2)) + end2 = make_fixnum (SCHARS (str2)); validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1); validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2); @@ -232,8 +319,8 @@ If string STR1 is greater, the value is a positive number N; if (! NILP (ignore_case)) { - c1 = XINT (Fupcase (make_number (c1))); - c2 = XINT (Fupcase (make_number (c2))); + c1 = XFIXNUM (Fupcase (make_fixnum (c1))); + c2 = XFIXNUM (Fupcase (make_fixnum (c2))); } if (c1 == c2) @@ -243,15 +330,15 @@ If string STR1 is greater, the value is a positive number N; past the character that we are comparing; hence we don't add or subtract 1 here. */ if (c1 < c2) - return make_number (- i1 + from1); + return make_fixnum (- i1 + from1); else - return make_number (i1 - from1); + return make_fixnum (i1 - from1); } if (i1 < to1) - return make_number (i1 - from1 + 1); + return make_fixnum (i1 - from1 + 1); if (i2 < to2) - return make_number (- i1 + from1 - 1); + return make_fixnum (- i1 + from1 - 1); return Qt; } @@ -579,7 +666,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { EMACS_INT len; this = args[argnum]; - len = XFASTINT (Flength (this)); + len = XFIXNAT (Flength (this)); if (target_type == Lisp_String) { /* We must count the number of bytes needed in the string @@ -594,7 +681,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { ch = AREF (this, i); CHECK_CHARACTER (ch); - c = XFASTINT (ch); + c = XFIXNAT (ch); this_len_byte = CHAR_BYTES (c); if (STRING_BYTES_BOUND - result_len_byte < this_len_byte) string_overflow (); @@ -603,13 +690,13 @@ concat (ptrdiff_t nargs, Lisp_Object *args, some_multibyte = 1; } else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0) - wrong_type_argument (Qintegerp, Faref (this, make_number (0))); + wrong_type_argument (Qintegerp, Faref (this, make_fixnum (0))); else if (CONSP (this)) for (; CONSP (this); this = XCDR (this)) { ch = XCAR (this); CHECK_CHARACTER (ch); - c = XFASTINT (ch); + c = XFIXNAT (ch); this_len_byte = CHAR_BYTES (c); if (STRING_BYTES_BOUND - result_len_byte < this_len_byte) string_overflow (); @@ -643,16 +730,16 @@ concat (ptrdiff_t nargs, Lisp_Object *args, /* Create the output object. */ if (target_type == Lisp_Cons) - val = Fmake_list (make_number (result_len), Qnil); + val = Fmake_list (make_fixnum (result_len), Qnil); else if (target_type == Lisp_Vectorlike) - val = Fmake_vector (make_number (result_len), Qnil); + val = make_nil_vector (result_len); else if (some_multibyte) val = make_uninit_multibyte_string (result_len, result_len_byte); else val = make_uninit_string (result_len); /* In `append', if all but last arg are nil, return last arg. */ - if (target_type == Lisp_Cons && EQ (val, Qnil)) + if (target_type == Lisp_Cons && NILP (val)) return last_tail; /* Copy the contents of the args into the result. */ @@ -674,7 +761,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, this = args[argnum]; if (!CONSP (this)) - thislen = Flength (this), thisleni = XINT (thislen); + thislen = Flength (this), thisleni = XFIXNUM (thislen); /* Between strings of the same kind, copy fast. */ if (STRINGP (this) && STRINGP (val) @@ -761,7 +848,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { int c; CHECK_CHARACTER (elt); - c = XFASTINT (elt); + c = XFIXNAT (elt); if (some_multibyte) toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte); else @@ -782,15 +869,15 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { this = args[textprops[argnum].argnum]; props = text_property_list (this, - make_number (0), - make_number (SCHARS (this)), + make_fixnum (0), + make_fixnum (SCHARS (this)), Qnil); /* If successive arguments have properties, be sure that the value of `composition' property be the copy. */ if (last_to_end == textprops[argnum].to) make_composition_value_copy (props); add_text_properties_from_list (val, props, - make_number (textprops[argnum].to)); + make_fixnum (textprops[argnum].to)); last_to_end = textprops[argnum].to + SCHARS (this); } } @@ -1192,9 +1279,9 @@ validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to, { EMACS_INT f, t; - if (INTEGERP (from)) + if (FIXNUMP (from)) { - f = XINT (from); + f = XFIXNUM (from); if (f < 0) f += size; } @@ -1203,9 +1290,9 @@ validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to, else wrong_type_argument (Qintegerp, from); - if (INTEGERP (to)) + if (FIXNUMP (to)) { - t = XINT (to); + t = XFIXNUM (to); if (t < 0) t += size; } @@ -1251,8 +1338,8 @@ With one argument, just copy STRING (with properties, if any). */) res = make_specified_string (SSDATA (string) + from_byte, ito - ifrom, to_byte - from_byte, STRING_MULTIBYTE (string)); - copy_text_properties (make_number (ifrom), make_number (ito), - string, make_number (0), res, Qnil); + copy_text_properties (make_fixnum (ifrom), make_fixnum (ito), + string, make_fixnum (0), res, Qnil); } else res = Fvector (ito - ifrom, aref_addr (string, ifrom)); @@ -1297,15 +1384,15 @@ substring_both (Lisp_Object string, ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t size = CHECK_VECTOR_OR_STRING (string); if (!(0 <= from && from <= to && to <= size)) - args_out_of_range_3 (string, make_number (from), make_number (to)); + args_out_of_range_3 (string, make_fixnum (from), make_fixnum (to)); if (STRINGP (string)) { res = make_specified_string (SSDATA (string) + from_byte, to - from, to_byte - from_byte, STRING_MULTIBYTE (string)); - copy_text_properties (make_number (from), make_number (to), - string, make_number (0), res, Qnil); + copy_text_properties (make_fixnum (from), make_fixnum (to), + string, make_fixnum (0), res, Qnil); } else res = Fvector (to - from, aref_addr (string, from)); @@ -1317,15 +1404,89 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, doc: /* Take cdr N times on LIST, return the result. */) (Lisp_Object n, Lisp_Object list) { - CHECK_NUMBER (n); Lisp_Object tail = list; - for (EMACS_INT num = XINT (n); 0 < num; num--) + + CHECK_INTEGER (n); + + /* A huge but in-range EMACS_INT that can be substituted for a + positive bignum while counting down. It does not introduce + miscounts because a list or cycle cannot possibly be this long, + and any counting error is fixed up later. */ + EMACS_INT large_num = EMACS_INT_MAX; + + EMACS_INT num; + if (FIXNUMP (n)) { - if (! CONSP (tail)) + num = XFIXNUM (n); + + /* Speed up small lists by omitting circularity and quit checking. */ + if (num <= SMALL_LIST_LEN_MAX) + { + for (; 0 < num; num--, tail = XCDR (tail)) + if (! CONSP (tail)) + { + CHECK_LIST_END (tail, list); + return Qnil; + } + return tail; + } + } + else + { + if (mpz_sgn (XBIGNUM (n)->value) < 0) + return tail; + num = large_num; + } + + EMACS_INT tortoise_num = num; + Lisp_Object saved_tail = tail; + FOR_EACH_TAIL_SAFE (tail) + { + /* If the tortoise just jumped (which is rare), + update TORTOISE_NUM accordingly. */ + if (EQ (tail, li.tortoise)) + tortoise_num = num; + + saved_tail = XCDR (tail); + num--; + if (num == 0) + return saved_tail; + rarely_quit (num); + } + + tail = saved_tail; + if (! CONSP (tail)) + { + CHECK_LIST_END (tail, list); + return Qnil; + } + + /* TAIL is part of a cycle. Reduce NUM modulo the cycle length to + avoid going around this cycle repeatedly. */ + intptr_t cycle_length = tortoise_num - num; + if (! FIXNUMP (n)) + { + /* Undo any error introduced when LARGE_NUM was substituted for + N, by adding N - LARGE_NUM to NUM, using arithmetic modulo + CYCLE_LENGTH. */ + /* Add N mod CYCLE_LENGTH to NUM. */ + if (cycle_length <= ULONG_MAX) + num += mpz_tdiv_ui (XBIGNUM (n)->value, cycle_length); + else { - CHECK_LIST_END (tail, list); - return Qnil; + mpz_set_intmax (mpz[0], cycle_length); + mpz_tdiv_r (mpz[0], XBIGNUM (n)->value, mpz[0]); + intptr_t iz; + mpz_export (&iz, NULL, -1, sizeof iz, 0, 0, mpz[0]); + num += iz; } + num += cycle_length - large_num % cycle_length; + } + num %= cycle_length; + + /* One last time through the cycle. */ + for (; 0 < num; num--) + { tail = XCDR (tail); rarely_quit (num); } @@ -1342,9 +1503,8 @@ N counts from zero. If LIST is not that long, nil is returned. */) DEFUN ("elt", Felt, Selt, 2, 2, 0, doc: /* Return element of SEQUENCE at index N. */) - (register Lisp_Object sequence, Lisp_Object n) + (Lisp_Object sequence, Lisp_Object n) { - CHECK_NUMBER (n); if (CONSP (sequence) || NILP (sequence)) return Fcar (Fnthcdr (n, sequence)); @@ -1353,6 +1513,29 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, return Faref (sequence, n); } +enum { WORDS_PER_DOUBLE = (sizeof (double) / sizeof (EMACS_UINT) + + (sizeof (double) % sizeof (EMACS_UINT) != 0)) }; +union double_and_words +{ + double val; + EMACS_UINT word[WORDS_PER_DOUBLE]; +}; + +/* Return true if X and Y are the same floating-point value. + This looks at X's and Y's representation, since (unlike '==') + it returns true if X and Y are the same NaN. */ +static bool +same_float (Lisp_Object x, Lisp_Object y) +{ + union double_and_words + xu = { .val = XFLOAT_DATA (x) }, + yu = { .val = XFLOAT_DATA (y) }; + EMACS_UINT neql = 0; + for (int i = 0; i < WORDS_PER_DOUBLE; i++) + neql |= xu.word[i] ^ yu.word[i]; + return !neql; +} + DEFUN ("member", Fmember, Smember, 2, 2, 0, doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. The value is actually the tail of LIST whose car is ELT. */) @@ -1391,7 +1574,7 @@ The value is actually the tail of LIST whose car is ELT. */) FOR_EACH_TAIL (tail) { Lisp_Object tem = XCAR (tail); - if (FLOATP (tem) && equal_no_quit (elt, tem)) + if (FLOATP (tem) && same_float (elt, tem)) return tail; } CHECK_LIST_END (tail, list); @@ -1579,7 +1762,7 @@ changing the value of a sequence `foo'. */) cbytes = 1; } - if (!INTEGERP (elt) || c != XINT (elt)) + if (!FIXNUMP (elt) || c != XFIXNUM (elt)) { ++nchars; nbytes += cbytes; @@ -1609,7 +1792,7 @@ changing the value of a sequence `foo'. */) cbytes = 1; } - if (!INTEGERP (elt) || c != XINT (elt)) + if (!FIXNUMP (elt) || c != XFIXNUM (elt)) { unsigned char *from = SDATA (seq) + ibyte; unsigned char *to = SDATA (tem) + nbytes; @@ -1780,7 +1963,7 @@ sort_list (Lisp_Object list, Lisp_Object predicate) front = list; len = Flength (list); - length = XINT (len); + length = XFIXNUM (len); if (length < 2) return list; @@ -1889,7 +2072,7 @@ sort_vector (Lisp_Object vector, Lisp_Object predicate) USE_SAFE_ALLOCA; SAFE_ALLOCA_LISP (tmp, halflen); for (ptrdiff_t i = 0; i < halflen; i++) - tmp[i] = make_number (0); + tmp[i] = make_fixnum (0); sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp); SAFE_FREE (); } @@ -2104,11 +2287,15 @@ The PLIST is modified by side effects. */) } DEFUN ("eql", Feql, Seql, 2, 2, 0, - doc: /* Return t if the two args are the same Lisp object. -Floating-point numbers of equal value are `eql', but they may not be `eq'. */) + doc: /* Return t if the two args are `eq' or are indistinguishable numbers. +Floating-point values with the same sign, exponent and fraction are `eql'. +This differs from numeric comparison: (eql 0.0 -0.0) returns nil and +\(eql 0.0e+NaN 0.0e+NaN) returns t, whereas `=' does the opposite. */) (Lisp_Object obj1, Lisp_Object obj2) { if (FLOATP (obj1)) + return FLOATP (obj2) && same_float (obj1, obj2) ? Qt : Qnil; + else if (BIGNUMP (obj1)) return equal_no_quit (obj1, obj2) ? Qt : Qnil; else return EQ (obj1, obj2) ? Qt : Qnil; @@ -2119,8 +2306,8 @@ DEFUN ("equal", Fequal, Sequal, 2, 2, 0, They must have the same data type. Conses are compared by comparing the cars and the cdrs. Vectors and strings are compared element by element. -Numbers are compared by value, but integers cannot equal floats. - (Use `=' if you want integers and floats to be able to be equal.) +Numbers are compared via `eql', so integers do not equal floats. +\(Use `=' if you want integers and floats to be able to be equal.) Symbols must match exactly. */) (Lisp_Object o1, Lisp_Object o2) { @@ -2172,7 +2359,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, ht = CALLN (Fmake_hash_table, QCtest, Qeq); switch (XTYPE (o1)) { - case Lisp_Cons: case Lisp_Misc: case Lisp_Vectorlike: + case Lisp_Cons: case Lisp_Vectorlike: { struct Lisp_Hash_Table *h = XHASH_TABLE (ht); EMACS_UINT hash; @@ -2200,13 +2387,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, switch (XTYPE (o1)) { case Lisp_Float: - { - double d1 = XFLOAT_DATA (o1); - double d2 = XFLOAT_DATA (o2); - /* If d is a NaN, then d != d. Two NaNs should be `equal' even - though they are not =. */ - return d1 == d2 || (d1 != d1 && d2 != d2); - } + return same_float (o1, o2); case Lisp_Cons: if (equal_kind == EQUAL_NO_QUIT) @@ -2235,29 +2416,6 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, depth++; goto tail_recurse; - case Lisp_Misc: - if (XMISCTYPE (o1) != XMISCTYPE (o2)) - return false; - if (OVERLAYP (o1)) - { - if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2), - equal_kind, depth + 1, ht) - || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2), - equal_kind, depth + 1, ht)) - return false; - o1 = XOVERLAY (o1)->plist; - o2 = XOVERLAY (o2)->plist; - depth++; - goto tail_recurse; - } - if (MARKERP (o1)) - { - return (XMARKER (o1)->buffer == XMARKER (o2)->buffer - && (XMARKER (o1)->buffer == 0 - || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos)); - } - break; - case Lisp_Vectorlike: { register int i; @@ -2267,6 +2425,26 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, same size. */ if (ASIZE (o2) != size) return false; + if (BIGNUMP (o1)) + return mpz_cmp (XBIGNUM (o1)->value, XBIGNUM (o2)->value) == 0; + if (OVERLAYP (o1)) + { + if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2), + equal_kind, depth + 1, ht) + || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2), + equal_kind, depth + 1, ht)) + return false; + o1 = XOVERLAY (o1)->plist; + o2 = XOVERLAY (o2)->plist; + depth++; + goto tail_recurse; + } + if (MARKERP (o1)) + { + return (XMARKER (o1)->buffer == XMARKER (o2)->buffer + && (XMARKER (o1)->buffer == 0 + || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos)); + } /* Boolvectors are compared much like strings. */ if (BOOL_VECTOR_P (o1)) { @@ -2349,7 +2527,7 @@ ARRAY is a vector, string, char-table, or bool-vector. */) register unsigned char *p = SDATA (array); int charval; CHECK_CHARACTER (item); - charval = XFASTINT (item); + charval = XFIXNAT (item); size = SCHARS (array); if (STRING_MULTIBYTE (array)) { @@ -2416,7 +2594,7 @@ usage: (nconc &rest LISTS) */) CHECK_CONS (tem); - Lisp_Object tail; + Lisp_Object tail UNINIT; FOR_EACH_TAIL (tem) tail = tem; @@ -2501,7 +2679,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */) (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator) { USE_SAFE_ALLOCA; - EMACS_INT leni = XFASTINT (Flength (sequence)); + EMACS_INT leni = XFIXNAT (Flength (sequence)); if (CHAR_TABLE_P (sequence)) wrong_type_argument (Qlistp, sequence); EMACS_INT args_alloc = 2 * leni - 1; @@ -2530,7 +2708,7 @@ 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)); + EMACS_INT leni = XFIXNAT (Flength (sequence)); if (CHAR_TABLE_P (sequence)) wrong_type_argument (Qlistp, sequence); Lisp_Object *args; @@ -2549,7 +2727,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */) { register EMACS_INT leni; - leni = XFASTINT (Flength (sequence)); + leni = XFIXNAT (Flength (sequence)); if (CHAR_TABLE_P (sequence)) wrong_type_argument (Qlistp, sequence); mapcar1 (leni, 0, function, sequence); @@ -2564,7 +2742,7 @@ 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)); + EMACS_INT leni = XFIXNAT (Flength (sequence)); if (CHAR_TABLE_P (sequence)) wrong_type_argument (Qlistp, sequence); Lisp_Object *args; @@ -2629,7 +2807,7 @@ if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */) Fding (Qnil); Fdiscard_input (); message1 ("Please answer yes or no."); - Fsleep_for (make_number (2), Qnil); + Fsleep_for (make_fixnum (2), Qnil); } } @@ -2661,7 +2839,7 @@ advisable. */) while (loads-- > 0) { Lisp_Object load = (NILP (use_floats) - ? make_number (100.0 * load_ave[loads]) + ? make_fixnum (100.0 * load_ave[loads]) : make_float (load_ave[loads])); ret = Fcons (load, ret); } @@ -2697,7 +2875,7 @@ particular subfeatures supported in this version of FEATURE. */) CHECK_SYMBOL (feature); CHECK_LIST (subfeatures); if (!NILP (Vautoload_queue)) - Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures), + Vautoload_queue = Fcons (Fcons (make_fixnum (0), Vfeatures), Vautoload_queue); tem = Fmemq (feature, Vfeatures); if (NILP (tem)) @@ -2949,7 +3127,7 @@ The data read from the system are decoded using `locale-coding-system'. */) #ifdef DAY_1 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */ { - Lisp_Object v = Fmake_vector (make_number (7), Qnil); + Lisp_Object v = make_nil_vector (7); const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7}; int i; synchronize_system_time_locale (); @@ -2968,12 +3146,11 @@ The data read from the system are decoded using `locale-coding-system'. */) #ifdef MON_1 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */ { - Lisp_Object v = Fmake_vector (make_number (12), Qnil); + Lisp_Object v = make_nil_vector (12); const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7, MON_8, MON_9, MON_10, MON_11, MON_12}; - int i; synchronize_system_time_locale (); - for (i = 0; i < 12; i++) + for (int i = 0; i < 12; i++) { str = nl_langinfo (months[i]); AUTO_STRING (val, str); @@ -3091,9 +3268,9 @@ into shorter lines. */) validate_region (&beg, &end); - ibeg = CHAR_TO_BYTE (XFASTINT (beg)); - iend = CHAR_TO_BYTE (XFASTINT (end)); - move_gap_both (XFASTINT (beg), ibeg); + ibeg = CHAR_TO_BYTE (XFIXNAT (beg)); + iend = CHAR_TO_BYTE (XFIXNAT (end)); + move_gap_both (XFIXNAT (beg), ibeg); /* We need to allocate enough room for encoding the text. We need 33 1/3% more space, plus a newline every 76 @@ -3118,21 +3295,21 @@ into shorter lines. */) /* Now we have encoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ - SET_PT_BOTH (XFASTINT (beg), ibeg); + SET_PT_BOTH (XFIXNAT (beg), ibeg); insert (encoded, encoded_length); SAFE_FREE (); 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. */ - if (old_pos >= XFASTINT (end)) - old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg)); - else if (old_pos > XFASTINT (beg)) - old_pos = XFASTINT (beg); + if (old_pos >= XFIXNAT (end)) + old_pos += encoded_length - (XFIXNAT (end) - XFIXNAT (beg)); + else if (old_pos > XFIXNAT (beg)) + old_pos = XFIXNAT (beg); SET_PT (old_pos); /* We return the length of the encoded text. */ - return make_number (encoded_length); + return make_fixnum (encoded_length); } DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string, @@ -3291,8 +3468,8 @@ If the region can't be decoded, signal an error and don't modify the buffer. */ validate_region (&beg, &end); - ibeg = CHAR_TO_BYTE (XFASTINT (beg)); - iend = CHAR_TO_BYTE (XFASTINT (end)); + ibeg = CHAR_TO_BYTE (XFIXNAT (beg)); + iend = CHAR_TO_BYTE (XFIXNAT (end)); length = iend - ibeg; @@ -3302,7 +3479,7 @@ If the region can't be decoded, signal an error and don't modify the buffer. */ allength = multibyte ? length * 2 : length; decoded = SAFE_ALLOCA (allength); - move_gap_both (XFASTINT (beg), ibeg); + move_gap_both (XFIXNAT (beg), ibeg); decoded_length = base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg), decoded, length, multibyte, &inserted_chars); @@ -3317,23 +3494,24 @@ If the region can't be decoded, signal an error and don't modify the buffer. */ /* Now we have decoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ - TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg); + TEMP_SET_PT_BOTH (XFIXNAT (beg), ibeg); insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0); + signal_after_change (XFIXNAT (beg), 0, inserted_chars); SAFE_FREE (); /* Delete the original text. */ - del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars, + del_range_both (PT, PT_BYTE, XFIXNAT (end) + inserted_chars, iend + decoded_length, 1); /* If point was outside of the region, restore it exactly; else just move to the beginning of the region. */ - if (old_pos >= XFASTINT (end)) - old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg)); - else if (old_pos > XFASTINT (beg)) - old_pos = XFASTINT (beg); + if (old_pos >= XFIXNAT (end)) + old_pos += inserted_chars - (XFIXNAT (end) - XFIXNAT (beg)); + else if (old_pos > XFIXNAT (beg)) + old_pos = XFIXNAT (beg); SET_PT (old_pos > ZV ? ZV : old_pos); - return make_number (inserted_chars); + return make_fixnum (inserted_chars); } DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string, @@ -3504,7 +3682,7 @@ set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next) static void set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val) { - gc_aset (h->next, idx, make_number (val)); + gc_aset (h->next, idx, make_fixnum (val)); } static void set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash) @@ -3524,7 +3702,7 @@ set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index) static void set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val) { - gc_aset (h->index, idx, make_number (val)); + gc_aset (h->index, idx, make_fixnum (val)); } /* If OBJ is a Lisp hash table, return a pointer to its struct @@ -3627,7 +3805,7 @@ larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max) static ptrdiff_t HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx) { - return XINT (AREF (h->next, idx)); + return XFIXNUM (AREF (h->next, idx)); } /* Return the index of the element in hash table H that is the start @@ -3636,27 +3814,29 @@ HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx) static ptrdiff_t HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx) { - return XINT (AREF (h->index, idx)); + return XFIXNUM (AREF (h->index, idx)); } -/* 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. */ +/* Compare KEY1 and KEY2 in hash table HT using `eql'. Value is true + if KEY1 and KEY2 are the same. KEY1 and KEY2 must not be eq. */ static bool cmpfn_eql (struct hash_table_test *ht, Lisp_Object key1, Lisp_Object key2) { - return (FLOATP (key1) - && FLOATP (key2) - && XFLOAT_DATA (key1) == XFLOAT_DATA (key2)); + if (FLOATP (key1) + && FLOATP (key2) + && same_float (key1, key2)) + return true; + return (BIGNUMP (key1) + && BIGNUMP (key2) + && mpz_cmp (XBIGNUM (key1)->value, XBIGNUM (key2)->value) == 0); } -/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code - HASH2 in hash table H using `equal'. Value is true if KEY1 and - KEY2 are the same. */ +/* Compare KEY1 and KEY2 in hash table HT using `equal'. Value is + true if KEY1 and KEY2 are the same. */ static bool cmpfn_equal (struct hash_table_test *ht, @@ -3667,9 +3847,8 @@ cmpfn_equal (struct hash_table_test *ht, } -/* Compare KEY1 which has hash code HASH1, and KEY2 with hash code - HASH2 in hash table H using H->user_cmp_function. Value is true - if KEY1 and KEY2 are the same. */ +/* Compare KEY1 and KEY2 in hash table HT using HT->user_cmp_function. + Value is true if KEY1 and KEY2 are the same. */ static bool cmpfn_user_defined (struct hash_table_test *ht, @@ -3706,7 +3885,9 @@ hashfn_equal (struct hash_table_test *ht, Lisp_Object key) static EMACS_UINT hashfn_eql (struct hash_table_test *ht, Lisp_Object key) { - return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key); + return ((FLOATP (key) || BIGNUMP (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 @@ -3805,10 +3986,10 @@ make_hash_table (struct hash_table_test test, EMACS_INT size, h->rehash_threshold = rehash_threshold; h->rehash_size = rehash_size; h->count = 0; - h->key_and_value = Fmake_vector (make_number (2 * size), Qnil); - h->hash = Fmake_vector (make_number (size), Qnil); - h->next = Fmake_vector (make_number (size), make_number (-1)); - h->index = Fmake_vector (make_number (index_size), make_number (-1)); + h->key_and_value = make_nil_vector (2 * size); + h->hash = make_nil_vector (size); + h->next = make_vector (size, make_fixnum (-1)); + h->index = make_vector (index_size, make_fixnum (-1)); h->pure = pure; /* Set up the free list. */ @@ -3903,8 +4084,7 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h) set_hash_key_and_value (h, larger_vector (h->key_and_value, 2 * (new_size - old_size), -1)); set_hash_hash (h, larger_vector (h->hash, new_size - old_size, -1)); - set_hash_index (h, Fmake_vector (make_number (index_size), - make_number (-1))); + set_hash_index (h, make_vector (index_size, make_fixnum (-1))); set_hash_next (h, larger_vecalloc (h->next, new_size - old_size, -1)); /* Update the free list. Do it so that new entries are added at @@ -3933,7 +4113,7 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h) for (i = 0; i < old_size; ++i) if (!NILP (HASH_HASH (h, i))) { - EMACS_UINT hash_code = XUINT (HASH_HASH (h, i)); + EMACS_UINT hash_code = XUFIXNUM (HASH_HASH (h, i)); ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index); set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket)); set_hash_index_slot (h, start_of_bucket, i); @@ -3962,7 +4142,7 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash) for (i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i)) if (EQ (key, HASH_KEY (h, i)) || (h->test.cmpfn - && hash_code == XUINT (HASH_HASH (h, i)) + && hash_code == XUFIXNUM (HASH_HASH (h, i)) && h->test.cmpfn (&h->test, key, HASH_KEY (h, i)))) break; @@ -3993,7 +4173,7 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value, set_hash_value_slot (h, i, value); /* Remember its hash code. */ - set_hash_hash_slot (h, i, make_number (hash)); + set_hash_hash_slot (h, i, make_fixnum (hash)); /* Add new entry to its collision chain. */ start_of_bucket = hash % ASIZE (h->index); @@ -4019,7 +4199,7 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key) { if (EQ (key, HASH_KEY (h, i)) || (h->test.cmpfn - && hash_code == XUINT (HASH_HASH (h, i)) + && hash_code == XUFIXNUM (HASH_HASH (h, i)) && h->test.cmpfn (&h->test, key, HASH_KEY (h, i)))) { /* Take entry out of collision chain. */ @@ -4063,7 +4243,7 @@ hash_clear (struct Lisp_Hash_Table *h) } for (i = 0; i < ASIZE (h->index); ++i) - ASET (h->index, i, make_number (-1)); + ASET (h->index, i, make_fixnum (-1)); h->next_free = 0; h->count = 0; @@ -4261,18 +4441,8 @@ static EMACS_UINT sxhash_float (double val) { EMACS_UINT hash = 0; - enum { - WORDS_PER_DOUBLE = (sizeof val / sizeof hash - + (sizeof val % sizeof hash != 0)) - }; - union { - double val; - EMACS_UINT word[WORDS_PER_DOUBLE]; - } u; - int i; - u.val = val; - memset (&u.val + 1, 0, sizeof u - sizeof u.val); - for (i = 0; i < WORDS_PER_DOUBLE; i++) + union double_and_words u = { .val = val }; + for (int i = 0; i < WORDS_PER_DOUBLE; i++) hash = sxhash_combine (hash, u.word[i]); return SXHASH_REDUCE (hash); } @@ -4340,6 +4510,20 @@ sxhash_bool_vector (Lisp_Object vec) return SXHASH_REDUCE (hash); } +/* Return a hash for a bignum. */ + +static EMACS_UINT +sxhash_bignum (struct Lisp_Bignum *bignum) +{ + size_t i, nlimbs = mpz_size (bignum->value); + EMACS_UINT hash = 0; + + for (i = 0; i < nlimbs; ++i) + hash = sxhash_combine (hash, mpz_getlimbn (bignum->value, i)); + + return SXHASH_REDUCE (hash); +} + /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp structure. Value is an unsigned integer clipped to INTMASK. */ @@ -4355,10 +4539,9 @@ sxhash (Lisp_Object obj, int depth) switch (XTYPE (obj)) { case_Lisp_Int: - hash = XUINT (obj); + hash = XUFIXNUM (obj); break; - case Lisp_Misc: case Lisp_Symbol: hash = XHASH (obj); break; @@ -4369,7 +4552,9 @@ sxhash (Lisp_Object obj, int depth) /* This can be everything from a vector to an overlay. */ case Lisp_Vectorlike: - if (VECTORP (obj) || RECORDP (obj)) + if (BIGNUMP (obj)) + hash = sxhash_bignum (XBIGNUM (obj)); + else if (VECTORP (obj) || RECORDP (obj)) /* According to the CL HyperSpec, two arrays are equal only if they are `eq', except for strings and bit-vectors. In Emacs, this works differently. We have to compare element @@ -4409,7 +4594,7 @@ DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0, If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */) (Lisp_Object obj) { - return make_number (hashfn_eq (NULL, obj)); + return make_fixnum (hashfn_eq (NULL, obj)); } DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0, @@ -4417,7 +4602,7 @@ DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0, If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */) (Lisp_Object obj) { - return make_number (hashfn_eql (NULL, obj)); + return make_fixnum (hashfn_eql (NULL, obj)); } DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0, @@ -4425,7 +4610,7 @@ DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0, If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */) (Lisp_Object obj) { - return make_number (hashfn_equal (NULL, obj)); + return make_fixnum (hashfn_equal (NULL, obj)); } DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0, @@ -4511,8 +4696,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) EMACS_INT size; if (NILP (size_arg)) size = DEFAULT_HASH_SIZE; - else if (NATNUMP (size_arg)) - size = XFASTINT (size_arg); + else if (FIXNATP (size_arg)) + size = XFIXNAT (size_arg); else signal_error ("Invalid hash table size", size_arg); @@ -4521,8 +4706,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) i = get_key_arg (QCrehash_size, nargs, args, used); if (!i) rehash_size = DEFAULT_REHASH_SIZE; - else if (INTEGERP (args[i]) && 0 < XINT (args[i])) - rehash_size = - XINT (args[i]); + else if (FIXNUMP (args[i]) && 0 < XFIXNUM (args[i])) + rehash_size = - XFIXNUM (args[i]); else if (FLOATP (args[i]) && 0 < (float) (XFLOAT_DATA (args[i]) - 1)) rehash_size = (float) (XFLOAT_DATA (args[i]) - 1); else @@ -4571,7 +4756,7 @@ DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0, doc: /* Return the number of elements in TABLE. */) (Lisp_Object table) { - return make_number (check_hash_table (table)->count); + return make_fixnum (check_hash_table (table)->count); } @@ -4584,7 +4769,7 @@ DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, if (rehash_size < 0) { EMACS_INT s = -rehash_size; - return make_number (min (s, MOST_POSITIVE_FIXNUM)); + return make_fixnum (min (s, MOST_POSITIVE_FIXNUM)); } else return make_float (rehash_size + 1); @@ -4608,7 +4793,7 @@ without need for resizing. */) (Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); - return make_number (HASH_TABLE_SIZE (h)); + return make_fixnum (HASH_TABLE_SIZE (h)); } @@ -4812,7 +4997,8 @@ extract_data_from_object (Lisp_Object spec, } if (STRING_MULTIBYTE (object)) - object = code_convert_string (object, coding_system, Qnil, 1, 0, 1); + object = code_convert_string (object, coding_system, + Qnil, true, false, true); ptrdiff_t size = SCHARS (object), start_char, end_char; validate_subarray (object, start, end, size, &start_char, &end_char); @@ -4829,8 +5015,6 @@ extract_data_from_object (Lisp_Object spec, record_unwind_current_buffer (); - CHECK_BUFFER (object); - struct buffer *bp = XBUFFER (object); set_buffer_internal (bp); @@ -4838,16 +5022,16 @@ extract_data_from_object (Lisp_Object spec, b = BEGV; else { - CHECK_NUMBER_COERCE_MARKER (start); - b = XINT (start); + CHECK_FIXNUM_COERCE_MARKER (start); + b = XFIXNUM (start); } if (NILP (end)) e = ZV; else { - CHECK_NUMBER_COERCE_MARKER (end); - e = XINT (end); + CHECK_FIXNUM_COERCE_MARKER (end); + e = XFIXNUM (end); } if (b > e) @@ -4869,7 +5053,7 @@ extract_data_from_object (Lisp_Object spec, coding_system = Vcoding_system_for_write; else { - bool force_raw_text = 0; + bool force_raw_text = false; coding_system = BVAR (XBUFFER (object), buffer_file_coding_system); if (NILP (coding_system) @@ -4877,14 +5061,15 @@ extract_data_from_object (Lisp_Object spec, { coding_system = Qnil; if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - force_raw_text = 1; + force_raw_text = true; } if (NILP (coding_system) && !NILP (Fbuffer_file_name (object))) { /* Check file-coding-system-alist. */ Lisp_Object val = CALLN (Ffind_operation_coding_system, - Qwrite_region, start, end, + Qwrite_region, + make_fixnum (b), make_fixnum (e), Fbuffer_file_name (object)); if (CONSP (val) && !NILP (XCDR (val))) coding_system = XCDR (val); @@ -4902,7 +5087,7 @@ extract_data_from_object (Lisp_Object spec, && !NILP (Ffboundp (Vselect_safe_coding_system_function))) /* Confirm that VAL can surely encode the current region. */ coding_system = call4 (Vselect_safe_coding_system_function, - make_number (b), make_number (e), + make_fixnum (b), make_fixnum (e), coding_system, Qnil); if (force_raw_text) @@ -4920,14 +5105,15 @@ extract_data_from_object (Lisp_Object spec, } } - object = make_buffer_string (b, e, 0); + object = make_buffer_string (b, e, false); set_buffer_internal (prev); /* Discard the unwind protect for recovering the current buffer. */ specpdl_ptr--; if (STRING_MULTIBYTE (object)) - object = code_convert_string (object, coding_system, Qnil, 1, 0, 0); + object = code_convert_string (object, coding_system, + Qnil, true, false, false); *start_byte = 0; *end_byte = SBYTES (object); } @@ -4936,11 +5122,11 @@ extract_data_from_object (Lisp_Object spec, #ifdef HAVE_GNUTLS3 /* Format: (iv-auto REQUIRED-LENGTH). */ - if (! NATNUMP (start)) + if (! FIXNATP (start)) error ("Without a length, `iv-auto' can't be used; see ELisp manual"); else { - EMACS_INT start_hold = XFASTINT (start); + EMACS_INT start_hold = XFIXNAT (start); object = make_uninit_string (start_hold); gnutls_rnd (GNUTLS_RND_NONCE, SSDATA (object), start_hold); @@ -5212,7 +5398,7 @@ invoked by mouse clicks and mouse menu items. On some platforms, file selection dialogs are also enabled if this is non-nil. */); - use_dialog_box = 1; + use_dialog_box = true; DEFVAR_BOOL ("use-file-dialog", use_file_dialog, doc: /* Non-nil means mouse commands use a file dialog to ask for files. @@ -5220,13 +5406,15 @@ This applies to commands from menus and tool bar buttons even when they are initiated from the keyboard. If `use-dialog-box' is nil, that disables the use of a file dialog, regardless of the value of this variable. */); - use_file_dialog = 1; + use_file_dialog = true; defsubr (&Sidentity); defsubr (&Srandom); defsubr (&Slength); defsubr (&Ssafe_length); + defsubr (&Sproper_list_p); defsubr (&Sstring_bytes); + defsubr (&Sstring_distance); defsubr (&Sstring_equal); defsubr (&Scompare_strings); defsubr (&Sstring_lessp); diff --git a/src/font.c b/src/font.c index 24075c7e635..cf68160e59c 100644 --- a/src/font.c +++ b/src/font.c @@ -201,7 +201,7 @@ font_make_object (int size, Lisp_Object entity, int pixelsize) = Fcopy_alist (AREF (entity, FONT_EXTRA_INDEX)); } if (size > 0) - font->props[FONT_SIZE_INDEX] = make_number (pixelsize); + font->props[FONT_SIZE_INDEX] = make_fixnum (pixelsize); return font_object; } @@ -270,7 +270,7 @@ font_intern_prop (const char *str, ptrdiff_t len, bool force_symbol) (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; ) { if (i == len) - return make_number (n); + return make_fixnum (n); if (INT_MULTIPLY_WRAPV (n, 10, &n)) break; } @@ -302,8 +302,8 @@ font_pixel_size (struct frame *f, Lisp_Object spec) int dpi, pixel_size; Lisp_Object val; - if (INTEGERP (size)) - return XINT (size); + if (FIXNUMP (size)) + return XFIXNUM (size); if (NILP (size)) return 0; if (FRAME_WINDOW_P (f)) @@ -311,8 +311,8 @@ font_pixel_size (struct frame *f, Lisp_Object spec) eassert (FLOATP (size)); point_size = XFLOAT_DATA (size); val = AREF (spec, FONT_DPI_INDEX); - if (INTEGERP (val)) - dpi = XINT (val); + if (FIXNUMP (val)) + dpi = XFIXNUM (val); else dpi = FRAME_RES_Y (f); pixel_size = POINT_TO_PIXEL (point_size, dpi); @@ -353,8 +353,8 @@ font_style_to_value (enum font_property_index prop, Lisp_Object val, for (j = 1; j < ASIZE (AREF (table, i)); j++) if (EQ (val, AREF (AREF (table, i), j))) { - CHECK_NUMBER (AREF (AREF (table, i), 0)); - return ((XINT (AREF (AREF (table, i), 0)) << 8) + CHECK_FIXNUM (AREF (AREF (table, i), 0)); + return ((XFIXNUM (AREF (AREF (table, i), 0)) << 8) | (i << 4) | (j - 1)); } } @@ -366,32 +366,32 @@ font_style_to_value (enum font_property_index prop, Lisp_Object val, elt = AREF (AREF (table, i), j); if (xstrcasecmp (s, SSDATA (SYMBOL_NAME (elt))) == 0) { - CHECK_NUMBER (AREF (AREF (table, i), 0)); - return ((XINT (AREF (AREF (table, i), 0)) << 8) + CHECK_FIXNUM (AREF (AREF (table, i), 0)); + return ((XFIXNUM (AREF (AREF (table, i), 0)) << 8) | (i << 4) | (j - 1)); } } if (! noerror) return -1; eassert (len < 255); - elt = Fmake_vector (make_number (2), make_number (100)); + elt = make_vector (2, make_fixnum (100)); ASET (elt, 1, val); ASET (font_style_table, prop - FONT_WEIGHT_INDEX, - CALLN (Fvconcat, table, Fmake_vector (make_number (1), elt))); + CALLN (Fvconcat, table, make_vector (1, elt))); return (100 << 8) | (i << 4); } else { int i, last_n; - EMACS_INT numeric = XINT (val); + EMACS_INT numeric = XFIXNUM (val); for (i = 0, last_n = -1; i < len; i++) { int n; CHECK_VECTOR (AREF (table, i)); - CHECK_NUMBER (AREF (AREF (table, i), 0)); - n = XINT (AREF (AREF (table, i), 0)); + CHECK_FIXNUM (AREF (AREF (table, i), 0)); + n = XFIXNUM (AREF (AREF (table, i), 0)); if (numeric == n) return (n << 8) | (i << 4); if (numeric < n) @@ -421,7 +421,7 @@ font_style_symbolic (Lisp_Object font, enum font_property_index prop, return Qnil; table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX); CHECK_VECTOR (table); - i = XINT (val) & 0xFF; + i = XFIXNUM (val) & 0xFF; eassert (((i >> 4) & 0xF) < ASIZE (table)); elt = AREF (table, ((i >> 4) & 0xF)); CHECK_VECTOR (elt); @@ -470,33 +470,33 @@ font_registry_charsets (Lisp_Object registry, struct charset **encoding, struct val = XCDR (val); if (NILP (val)) return -1; - encoding_id = XINT (XCAR (val)); - repertory_id = XINT (XCDR (val)); + encoding_id = XFIXNUM (XCAR (val)); + repertory_id = XFIXNUM (XCDR (val)); } else { val = find_font_encoding (SYMBOL_NAME (registry)); if (SYMBOLP (val) && CHARSETP (val)) { - encoding_id = repertory_id = XINT (CHARSET_SYMBOL_ID (val)); + encoding_id = repertory_id = XFIXNUM (CHARSET_SYMBOL_ID (val)); } else if (CONSP (val)) { if (! CHARSETP (XCAR (val))) goto invalid_entry; - encoding_id = XINT (CHARSET_SYMBOL_ID (XCAR (val))); + encoding_id = XFIXNUM (CHARSET_SYMBOL_ID (XCAR (val))); if (NILP (XCDR (val))) repertory_id = -1; else { if (! CHARSETP (XCDR (val))) goto invalid_entry; - repertory_id = XINT (CHARSET_SYMBOL_ID (XCDR (val))); + repertory_id = XFIXNUM (CHARSET_SYMBOL_ID (XCDR (val))); } } else goto invalid_entry; - val = Fcons (make_number (encoding_id), make_number (repertory_id)); + val = Fcons (make_fixnum (encoding_id), make_fixnum (repertory_id)); font_charset_alist = nconc2 (font_charset_alist, list1 (Fcons (registry, val))); } @@ -543,9 +543,9 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val) enum font_property_index prop = (EQ (style, QCweight) ? FONT_WEIGHT_INDEX : EQ (style, QCslant) ? FONT_SLANT_INDEX : FONT_WIDTH_INDEX); - if (INTEGERP (val)) + if (FIXNUMP (val)) { - EMACS_INT n = XINT (val); + EMACS_INT n = XFIXNUM (val); CHECK_VECTOR (AREF (font_style_table, prop - FONT_WEIGHT_INDEX)); if (((n >> 4) & 0xF) >= ASIZE (AREF (font_style_table, prop - FONT_WEIGHT_INDEX))) @@ -559,8 +559,8 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val) val = Qerror; else { - CHECK_NUMBER (AREF (elt, 0)); - if (XINT (AREF (elt, 0)) != (n >> 8)) + CHECK_FIXNUM (AREF (elt, 0)); + if (XFIXNUM (AREF (elt, 0)) != (n >> 8)) val = Qerror; } } @@ -569,7 +569,7 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val) { int n = font_style_to_value (prop, val, 0); - val = n >= 0 ? make_number (n) : Qerror; + val = n >= 0 ? make_fixnum (n) : Qerror; } else val = Qerror; @@ -579,27 +579,27 @@ font_prop_validate_style (Lisp_Object style, Lisp_Object val) static Lisp_Object font_prop_validate_non_neg (Lisp_Object prop, Lisp_Object val) { - return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0) + return (FIXNATP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0) ? val : Qerror); } static Lisp_Object font_prop_validate_spacing (Lisp_Object prop, Lisp_Object val) { - if (NILP (val) || (NATNUMP (val) && XINT (val) <= FONT_SPACING_CHARCELL)) + if (NILP (val) || (FIXNATP (val) && XFIXNUM (val) <= FONT_SPACING_CHARCELL)) return val; if (SYMBOLP (val) && SBYTES (SYMBOL_NAME (val)) == 1) { char spacing = SDATA (SYMBOL_NAME (val))[0]; if (spacing == 'c' || spacing == 'C') - return make_number (FONT_SPACING_CHARCELL); + return make_fixnum (FONT_SPACING_CHARCELL); if (spacing == 'm' || spacing == 'M') - return make_number (FONT_SPACING_MONO); + return make_fixnum (FONT_SPACING_MONO); if (spacing == 'p' || spacing == 'P') - return make_number (FONT_SPACING_PROPORTIONAL); + return make_fixnum (FONT_SPACING_PROPORTIONAL); if (spacing == 'd' || spacing == 'D') - return make_number (FONT_SPACING_DUAL); + return make_fixnum (FONT_SPACING_DUAL); } return Qerror; } @@ -875,9 +875,9 @@ font_expand_wildcards (Lisp_Object *field, int n) int from, to; unsigned mask; - if (INTEGERP (val)) + if (FIXNUMP (val)) { - EMACS_INT numeric = XINT (val); + EMACS_INT numeric = XFIXNUM (val); if (i + 1 == n) from = to = XLFD_ENCODING_INDEX, @@ -999,7 +999,7 @@ font_expand_wildcards (Lisp_Object *field, int n) if (! NILP (tmp[n - 1]) && j < XLFD_REGISTRY_INDEX) return -1; memclear (field + j, (XLFD_LAST_INDEX - j) * word_size); - if (INTEGERP (field[XLFD_ENCODING_INDEX])) + if (FIXNUMP (field[XLFD_ENCODING_INDEX])) field[XLFD_ENCODING_INDEX] = Fintern (Fnumber_to_string (field[XLFD_ENCODING_INDEX]), Qnil); return 0; @@ -1064,7 +1064,7 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) { if ((n = font_style_to_value (j, INTERN_FIELD_SYM (i), 0)) < 0) return -1; - ASET (font, j, make_number (n)); + ASET (font, j, make_fixnum (n)); } } ASET (font, FONT_ADSTYLE_INDEX, INTERN_FIELD_SYM (XLFD_ADSTYLE_INDEX)); @@ -1077,11 +1077,11 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) 1)); p = f[XLFD_PIXEL_INDEX]; if (*p == '[' && (pixel_size = parse_matrix (p)) >= 0) - ASET (font, FONT_SIZE_INDEX, make_number (pixel_size)); + ASET (font, FONT_SIZE_INDEX, make_fixnum (pixel_size)); else { val = INTERN_FIELD (XLFD_PIXEL_INDEX); - if (INTEGERP (val)) + if (FIXNUMP (val)) ASET (font, FONT_SIZE_INDEX, val); else if (FONT_ENTITY_P (font)) return -1; @@ -1101,14 +1101,14 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) } val = INTERN_FIELD (XLFD_RESY_INDEX); - if (! NILP (val) && ! INTEGERP (val)) + if (! NILP (val) && ! FIXNUMP (val)) return -1; ASET (font, FONT_DPI_INDEX, val); val = INTERN_FIELD (XLFD_SPACING_INDEX); if (! NILP (val)) { val = font_prop_validate_spacing (QCspacing, val); - if (! INTEGERP (val)) + if (! FIXNUMP (val)) return -1; ASET (font, FONT_SPACING_INDEX, val); } @@ -1116,7 +1116,7 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) if (*p == '~') p++; val = font_intern_prop (p, f[XLFD_REGISTRY_INDEX] - 1 - p, 0); - if (! NILP (val) && ! INTEGERP (val)) + if (! NILP (val) && ! FIXNUMP (val)) return -1; ASET (font, FONT_AVGWIDTH_INDEX, val); } @@ -1154,7 +1154,7 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) { if ((n = font_style_to_value (j, prop[i], 1)) < 0) return -1; - ASET (font, j, make_number (n)); + ASET (font, j, make_fixnum (n)); } ASET (font, FONT_ADSTYLE_INDEX, prop[XLFD_ADSTYLE_INDEX]); val = prop[XLFD_REGISTRY_INDEX]; @@ -1181,26 +1181,26 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) if (! NILP (val)) ASET (font, FONT_REGISTRY_INDEX, Fintern (val, Qnil)); - if (INTEGERP (prop[XLFD_PIXEL_INDEX])) + if (FIXNUMP (prop[XLFD_PIXEL_INDEX])) ASET (font, FONT_SIZE_INDEX, prop[XLFD_PIXEL_INDEX]); - else if (INTEGERP (prop[XLFD_POINT_INDEX])) + else if (FIXNUMP (prop[XLFD_POINT_INDEX])) { - double point_size = XINT (prop[XLFD_POINT_INDEX]); + double point_size = XFIXNUM (prop[XLFD_POINT_INDEX]); ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10)); } - if (INTEGERP (prop[XLFD_RESX_INDEX])) + if (FIXNUMP (prop[XLFD_RESX_INDEX])) ASET (font, FONT_DPI_INDEX, prop[XLFD_RESY_INDEX]); if (! NILP (prop[XLFD_SPACING_INDEX])) { val = font_prop_validate_spacing (QCspacing, prop[XLFD_SPACING_INDEX]); - if (! INTEGERP (val)) + if (! FIXNUMP (val)) return -1; ASET (font, FONT_SPACING_INDEX, val); } - if (INTEGERP (prop[XLFD_AVGWIDTH_INDEX])) + if (FIXNUMP (prop[XLFD_AVGWIDTH_INDEX])) ASET (font, FONT_AVGWIDTH_INDEX, prop[XLFD_AVGWIDTH_INDEX]); } @@ -1289,13 +1289,15 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes) 1 + DBL_MAX_10_EXP + 1)]; if (INTEGERP (val)) { - EMACS_INT v = XINT (val); - if (v <= 0) + intmax_t v; + if (! (integer_to_intmax (val, &v) + && 0 < v && v <= TYPE_MAXIMUM (uprintmax_t))) v = pixel_size; if (v > 0) { + uprintmax_t u = v; f[XLFD_PIXEL_INDEX] = p = font_size_index_buf; - sprintf (p, "%"pI"d-*", v); + sprintf (p, "%"pMu"-*", u); } else f[XLFD_PIXEL_INDEX] = "*-*"; @@ -1310,18 +1312,18 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes) f[XLFD_PIXEL_INDEX] = "*-*"; char dpi_index_buf[sizeof "-" + 2 * INT_STRLEN_BOUND (EMACS_INT)]; - if (INTEGERP (AREF (font, FONT_DPI_INDEX))) + if (FIXNUMP (AREF (font, FONT_DPI_INDEX))) { - EMACS_INT v = XINT (AREF (font, FONT_DPI_INDEX)); + EMACS_INT v = XFIXNUM (AREF (font, FONT_DPI_INDEX)); f[XLFD_RESX_INDEX] = p = dpi_index_buf; sprintf (p, "%"pI"d-%"pI"d", v, v); } else f[XLFD_RESX_INDEX] = "*-*"; - if (INTEGERP (AREF (font, FONT_SPACING_INDEX))) + if (FIXNUMP (AREF (font, FONT_SPACING_INDEX))) { - EMACS_INT spacing = XINT (AREF (font, FONT_SPACING_INDEX)); + EMACS_INT spacing = XFIXNUM (AREF (font, FONT_SPACING_INDEX)); f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p" : spacing <= FONT_SPACING_DUAL ? "d" @@ -1332,10 +1334,10 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes) f[XLFD_SPACING_INDEX] = "*"; char avgwidth_index_buf[INT_BUFSIZE_BOUND (EMACS_INT)]; - if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX))) + if (FIXNUMP (AREF (font, FONT_AVGWIDTH_INDEX))) { f[XLFD_AVGWIDTH_INDEX] = p = avgwidth_index_buf; - sprintf (p, "%"pI"d", XINT (AREF (font, FONT_AVGWIDTH_INDEX))); + sprintf (p, "%"pI"d", XFIXNUM (AREF (font, FONT_AVGWIDTH_INDEX))); } else f[XLFD_AVGWIDTH_INDEX] = "*"; @@ -1456,19 +1458,19 @@ font_parse_fcname (char *name, ptrdiff_t len, Lisp_Object font) FONT_SET_STYLE (font, FONT_SLANT_INDEX, val); else if (PROP_MATCH ("charcell")) ASET (font, FONT_SPACING_INDEX, - make_number (FONT_SPACING_CHARCELL)); + make_fixnum (FONT_SPACING_CHARCELL)); else if (PROP_MATCH ("mono")) ASET (font, FONT_SPACING_INDEX, - make_number (FONT_SPACING_MONO)); + make_fixnum (FONT_SPACING_MONO)); else if (PROP_MATCH ("proportional")) ASET (font, FONT_SPACING_INDEX, - make_number (FONT_SPACING_PROPORTIONAL)); + make_fixnum (FONT_SPACING_PROPORTIONAL)); #undef PROP_MATCH } else { /* KEY=VAL pairs */ - Lisp_Object key; + Lisp_Object key UNINIT; int prop; if (q - p == 10 && memcmp (p + 1, "pixelsize", 9) == 0) @@ -1621,10 +1623,10 @@ font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes) } val = AREF (font, FONT_SIZE_INDEX); - if (INTEGERP (val)) + if (FIXNUMP (val)) { - if (XINT (val) != 0) - pixel_size = XINT (val); + if (XFIXNUM (val) != 0) + pixel_size = XFIXNUM (val); point_size = -1; } else @@ -1688,28 +1690,28 @@ font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes) p += len; } - if (INTEGERP (AREF (font, FONT_DPI_INDEX))) + if (FIXNUMP (AREF (font, FONT_DPI_INDEX))) { int len = snprintf (p, lim - p, ":dpi=%"pI"d", - XINT (AREF (font, FONT_DPI_INDEX))); + XFIXNUM (AREF (font, FONT_DPI_INDEX))); if (! (0 <= len && len < lim - p)) return -1; p += len; } - if (INTEGERP (AREF (font, FONT_SPACING_INDEX))) + if (FIXNUMP (AREF (font, FONT_SPACING_INDEX))) { int len = snprintf (p, lim - p, ":spacing=%"pI"d", - XINT (AREF (font, FONT_SPACING_INDEX))); + XFIXNUM (AREF (font, FONT_SPACING_INDEX))); if (! (0 <= len && len < lim - p)) return -1; p += len; } - if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX))) + if (FIXNUMP (AREF (font, FONT_AVGWIDTH_INDEX))) { int len = snprintf (p, lim - p, - (XINT (AREF (font, FONT_AVGWIDTH_INDEX)) == 0 + (XFIXNUM (AREF (font, FONT_AVGWIDTH_INDEX)) == 0 ? ":scalable=true" : ":scalable=false")); if (! (0 <= len && len < lim - p)) @@ -1807,15 +1809,15 @@ check_gstring (Lisp_Object gstring) goto err; CHECK_FONT_OBJECT (LGSTRING_FONT (gstring)); if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING))) - CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)); + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)); if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING))) - CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)); + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)); if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH))) - CHECK_NATNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)); + CHECK_FIXNAT (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)); if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT))) - CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)); + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)); if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT))) - CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)); + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)); for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++) { @@ -1825,13 +1827,13 @@ check_gstring (Lisp_Object gstring) goto err; if (NILP (AREF (val, LGLYPH_IX_CHAR))) break; - CHECK_NATNUM (AREF (val, LGLYPH_IX_FROM)); - CHECK_NATNUM (AREF (val, LGLYPH_IX_TO)); + CHECK_FIXNAT (AREF (val, LGLYPH_IX_FROM)); + CHECK_FIXNAT (AREF (val, LGLYPH_IX_TO)); CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR)); if (!NILP (AREF (val, LGLYPH_IX_CODE))) - CHECK_NATNUM (AREF (val, LGLYPH_IX_CODE)); + CHECK_FIXNAT (AREF (val, LGLYPH_IX_CODE)); if (!NILP (AREF (val, LGLYPH_IX_WIDTH))) - CHECK_NATNUM (AREF (val, LGLYPH_IX_WIDTH)); + CHECK_FIXNAT (AREF (val, LGLYPH_IX_WIDTH)); if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT))) { val = AREF (val, LGLYPH_IX_ADJUSTMENT); @@ -1839,7 +1841,7 @@ check_gstring (Lisp_Object gstring) if (ASIZE (val) < 3) goto err; for (j = 0; j < 3; j++) - CHECK_NUMBER (AREF (val, j)); + CHECK_FIXNUM (AREF (val, j)); } } return i; @@ -1897,11 +1899,11 @@ otf_open (Lisp_Object file) OTF *otf; if (! NILP (val)) - otf = XSAVE_POINTER (XCDR (val), 0); + otf = xmint_pointer (XCDR (val)); else { otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL; - val = make_save_ptr (otf); + val = make_mint_ptr (otf); otf_list = Fcons (Fcons (file, val), otf_list); } return otf; @@ -2026,23 +2028,23 @@ font_otf_DeviceTable (OTF_DeviceTable *device_table) { int len = device_table->StartSize - device_table->EndSize + 1; - return Fcons (make_number (len), + return Fcons (make_fixnum (len), make_unibyte_string (device_table->DeltaValue, len)); } Lisp_Object font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record) { - Lisp_Object val = Fmake_vector (make_number (8), Qnil); + Lisp_Object val = make_nil_vector (8); if (value_format & OTF_XPlacement) - ASET (val, 0, make_number (value_record->XPlacement)); + ASET (val, 0, make_fixnum (value_record->XPlacement)); if (value_format & OTF_YPlacement) - ASET (val, 1, make_number (value_record->YPlacement)); + ASET (val, 1, make_fixnum (value_record->YPlacement)); if (value_format & OTF_XAdvance) - ASET (val, 2, make_number (value_record->XAdvance)); + ASET (val, 2, make_fixnum (value_record->XAdvance)); if (value_format & OTF_YAdvance) - ASET (val, 3, make_number (value_record->YAdvance)); + ASET (val, 3, make_fixnum (value_record->YAdvance)); if (value_format & OTF_XPlaDevice) ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice)); if (value_format & OTF_YPlaDevice) @@ -2057,13 +2059,11 @@ font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record) Lisp_Object font_otf_Anchor (OTF_Anchor *anchor) { - Lisp_Object val; - - val = Fmake_vector (make_number (anchor->AnchorFormat + 1), Qnil); - ASET (val, 0, make_number (anchor->XCoordinate)); - ASET (val, 1, make_number (anchor->YCoordinate)); + Lisp_Object val = make_nil_vector (anchor->AnchorFormat + 1); + ASET (val, 0, make_fixnum (anchor->XCoordinate)); + ASET (val, 1, make_fixnum (anchor->YCoordinate)); if (anchor->AnchorFormat == 2) - ASET (val, 2, make_number (anchor->f.f1.AnchorPoint)); + ASET (val, 2, make_fixnum (anchor->f.f1.AnchorPoint)); else { ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable)); @@ -2134,20 +2134,20 @@ font_score (Lisp_Object entity, Lisp_Object *spec_prop) for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++) if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i])) { - EMACS_INT diff = ((XINT (AREF (entity, i)) >> 8) - - (XINT (spec_prop[i]) >> 8)); + EMACS_INT diff = ((XFIXNUM (AREF (entity, i)) >> 8) + - (XFIXNUM (spec_prop[i]) >> 8)); score |= min (eabs (diff), 127) << sort_shift_bits[i]; } /* Score the size. Maximum difference is 127. */ if (! NILP (spec_prop[FONT_SIZE_INDEX]) - && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0) + && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0) { /* We use the higher 6-bit for the actual size difference. The lowest bit is set if the DPI is different. */ EMACS_INT diff; - EMACS_INT pixel_size = XINT (spec_prop[FONT_SIZE_INDEX]); - EMACS_INT entity_size = XINT (AREF (entity, FONT_SIZE_INDEX)); + EMACS_INT pixel_size = XFIXNUM (spec_prop[FONT_SIZE_INDEX]); + EMACS_INT entity_size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); if (CONSP (Vface_font_rescale_alist)) pixel_size *= font_rescale_ratio (entity); @@ -2174,7 +2174,7 @@ font_score (Lisp_Object entity, Lisp_Object *spec_prop) static Lisp_Object font_vconcat_entity_vectors (Lisp_Object list) { - EMACS_INT nargs = XFASTINT (Flength (list)); + EMACS_INT nargs = XFIXNAT (Flength (list)); Lisp_Object *args; USE_SAFE_ALLOCA; SAFE_ALLOCA_LISP (args, nargs); @@ -2244,7 +2244,7 @@ font_sort_entities (Lisp_Object list, Lisp_Object prefer, prefer_prop[i] = AREF (prefer, i); if (FLOATP (prefer_prop[FONT_SIZE_INDEX])) prefer_prop[FONT_SIZE_INDEX] - = make_number (font_pixel_size (f, prefer)); + = make_fixnum (font_pixel_size (f, prefer)); if (NILP (XCDR (list))) { @@ -2446,7 +2446,7 @@ font_match_p (Lisp_Object spec, Lisp_Object font) for (i = FONT_FOUNDRY_INDEX; i < FONT_SIZE_INDEX; i++) prop[i] = AREF (spec, i); prop[FONT_SIZE_INDEX] - = make_number (font_pixel_size (XFRAME (selected_frame), spec)); + = make_fixnum (font_pixel_size (XFRAME (selected_frame), spec)); props = prop; } @@ -2492,7 +2492,7 @@ font_match_p (Lisp_Object spec, Lisp_Object font) { if (! CHARACTERP (XCAR (val2))) continue; - if (font_encode_char (font, XFASTINT (XCAR (val2))) + if (font_encode_char (font, XFIXNAT (XCAR (val2))) == FONT_INVALID_CODE) return 0; } @@ -2504,7 +2504,7 @@ font_match_p (Lisp_Object spec, Lisp_Object font) { if (! CHARACTERP (AREF (val2, i))) continue; - if (font_encode_char (font, XFASTINT (AREF (val2, i))) + if (font_encode_char (font, XFIXNAT (AREF (val2, i))) != FONT_INVALID_CODE) break; } @@ -2559,13 +2559,13 @@ font_prepare_cache (struct frame *f, struct font_driver const *driver) val = XCDR (val); if (NILP (val)) { - val = list2 (driver->type, make_number (1)); + val = list2 (driver->type, make_fixnum (1)); XSETCDR (cache, Fcons (val, XCDR (cache))); } else { val = XCDR (XCAR (val)); - XSETCAR (val, make_number (XINT (XCAR (val)) + 1)); + XSETCAR (val, make_fixnum (XFIXNUM (XCAR (val)) + 1)); } } @@ -2582,8 +2582,8 @@ font_finish_cache (struct frame *f, struct font_driver const *driver) cache = val, val = XCDR (val); eassert (! NILP (val)); tmp = XCDR (XCAR (val)); - XSETCAR (tmp, make_number (XINT (XCAR (tmp)) - 1)); - if (XINT (XCAR (tmp)) == 0) + XSETCAR (tmp, make_fixnum (XFIXNUM (XCAR (tmp)) - 1)); + if (XFIXNUM (XCAR (tmp)) == 0) { font_clear_cache (f, XCAR (val), driver); XSETCDR (cache, XCDR (val)); @@ -2698,29 +2698,29 @@ font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size) continue; } for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++) - if (INTEGERP (AREF (spec, prop)) - && ((XINT (AREF (spec, prop)) >> 8) - != (XINT (AREF (entity, prop)) >> 8))) + if (FIXNUMP (AREF (spec, prop)) + && ((XFIXNUM (AREF (spec, prop)) >> 8) + != (XFIXNUM (AREF (entity, prop)) >> 8))) prop = FONT_SPEC_MAX; if (prop < FONT_SPEC_MAX && size - && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0) + && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0) { - int diff = XINT (AREF (entity, FONT_SIZE_INDEX)) - size; + int diff = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) - size; if (eabs (diff) > FONT_PIXEL_SIZE_QUANTUM) prop = FONT_SPEC_MAX; } if (prop < FONT_SPEC_MAX - && INTEGERP (AREF (spec, FONT_DPI_INDEX)) - && INTEGERP (AREF (entity, FONT_DPI_INDEX)) - && XINT (AREF (entity, FONT_DPI_INDEX)) != 0 + && FIXNUMP (AREF (spec, FONT_DPI_INDEX)) + && FIXNUMP (AREF (entity, FONT_DPI_INDEX)) + && XFIXNUM (AREF (entity, FONT_DPI_INDEX)) != 0 && ! EQ (AREF (spec, FONT_DPI_INDEX), AREF (entity, FONT_DPI_INDEX))) prop = FONT_SPEC_MAX; if (prop < FONT_SPEC_MAX - && INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX)) - && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX)) - && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0 + && FIXNUMP (AREF (spec, FONT_AVGWIDTH_INDEX)) + && FIXNUMP (AREF (entity, FONT_AVGWIDTH_INDEX)) + && XFIXNUM (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0 && ! EQ (AREF (spec, FONT_AVGWIDTH_INDEX), AREF (entity, FONT_AVGWIDTH_INDEX))) prop = FONT_SPEC_MAX; @@ -2747,8 +2747,8 @@ font_list_entities (struct frame *f, Lisp_Object spec) eassert (FONT_SPEC_P (spec)); - if (INTEGERP (AREF (spec, FONT_SIZE_INDEX))) - size = XINT (AREF (spec, FONT_SIZE_INDEX)); + if (FIXNUMP (AREF (spec, FONT_SIZE_INDEX))) + size = XFIXNUM (AREF (spec, FONT_SIZE_INDEX)); else if (FLOATP (AREF (spec, FONT_SIZE_INDEX))) size = font_pixel_size (f, spec); else @@ -2824,7 +2824,7 @@ font_matching_entity (struct frame *f, Lisp_Object *attrs, Lisp_Object spec) size = AREF (spec, FONT_SIZE_INDEX); if (FLOATP (size)) - ASET (work, FONT_SIZE_INDEX, make_number (font_pixel_size (f, spec))); + ASET (work, FONT_SIZE_INDEX, make_fixnum (font_pixel_size (f, spec))); FONT_SET_STYLE (work, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]); FONT_SET_STYLE (work, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]); FONT_SET_STYLE (work, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]); @@ -2873,8 +2873,8 @@ font_open_entity (struct frame *f, Lisp_Object entity, int pixel_size) eassert (FONT_ENTITY_P (entity)); size = AREF (entity, FONT_SIZE_INDEX); - if (XINT (size) != 0) - pixel_size = XINT (size); + if (XFIXNUM (size) != 0) + pixel_size = XFIXNUM (size); val = AREF (entity, FONT_TYPE_INDEX); for (driver_list = f->font_driver_list; @@ -2910,7 +2910,7 @@ font_open_entity (struct frame *f, Lisp_Object entity, int pixel_size) if (psize > pixel_size + 15) return Qnil; } - ASET (font_object, FONT_SIZE_INDEX, make_number (pixel_size)); + ASET (font_object, FONT_SIZE_INDEX, make_fixnum (pixel_size)); FONT_ADD_LOG ("open", entity, font_object); ASET (entity, FONT_OBJLIST_INDEX, Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX))); @@ -3133,7 +3133,7 @@ font_select_entity (struct frame *f, Lisp_Object entities, FONT_SET_STYLE (prefer, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]); if (NILP (AREF (prefer, FONT_WIDTH_INDEX))) FONT_SET_STYLE (prefer, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]); - ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size)); + ASET (prefer, FONT_SIZE_INDEX, make_fixnum (pixel_size)); return font_sort_entities (entities, prefer, f, c); } @@ -3179,9 +3179,9 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int work = copy_font_spec (spec); ASET (work, FONT_TYPE_INDEX, AREF (spec, FONT_TYPE_INDEX)); pixel_size = font_pixel_size (f, spec); - if (pixel_size == 0 && INTEGERP (attrs[LFACE_HEIGHT_INDEX])) + if (pixel_size == 0 && FIXNUMP (attrs[LFACE_HEIGHT_INDEX])) { - double pt = XINT (attrs[LFACE_HEIGHT_INDEX]); + double pt = XFIXNUM (attrs[LFACE_HEIGHT_INDEX]); pixel_size = POINT_TO_PIXEL (pt / 10, FRAME_RES_Y (f)); if (pixel_size < 1) @@ -3241,7 +3241,7 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int if (! NILP (alters)) { - EMACS_INT alterslen = XFASTINT (Flength (alters)); + EMACS_INT alterslen = XFIXNAT (Flength (alters)); SAFE_ALLOCA_LISP (family, alterslen + 2); for (i = 0; CONSP (alters); i++, alters = XCDR (alters)) family[i] = XCAR (alters); @@ -3298,9 +3298,9 @@ font_open_for_lface (struct frame *f, Lisp_Object entity, Lisp_Object *attrs, Li { int size; - if (INTEGERP (AREF (entity, FONT_SIZE_INDEX)) - && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0) - size = XINT (AREF (entity, FONT_SIZE_INDEX)); + if (FIXNUMP (AREF (entity, FONT_SIZE_INDEX)) + && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0) + size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); else { if (FONT_SPEC_P (spec) && ! NILP (AREF (spec, FONT_SIZE_INDEX))) @@ -3308,14 +3308,14 @@ font_open_for_lface (struct frame *f, Lisp_Object entity, Lisp_Object *attrs, Li else { double pt; - if (INTEGERP (attrs[LFACE_HEIGHT_INDEX])) - pt = XINT (attrs[LFACE_HEIGHT_INDEX]); + if (FIXNUMP (attrs[LFACE_HEIGHT_INDEX])) + pt = XFIXNUM (attrs[LFACE_HEIGHT_INDEX]); else { struct face *def = FACE_FROM_ID (f, DEFAULT_FACE_ID); Lisp_Object height = def->lface[LFACE_HEIGHT_INDEX]; - eassert (INTEGERP (height)); - pt = XINT (height); + eassert (FIXNUMP (height)); + pt = XFIXNUM (height); } pt /= 10; @@ -3325,7 +3325,8 @@ font_open_for_lface (struct frame *f, Lisp_Object entity, Lisp_Object *attrs, Li { Lisp_Object ffsize = get_frame_param (f, Qfontsize); size = (NUMBERP (ffsize) - ? POINT_TO_PIXEL (XINT (ffsize), FRAME_RES_Y (f)) : 0); + ? POINT_TO_PIXEL (XFLOATINT (ffsize), FRAME_RES_Y (f)) + : 0); } #endif } @@ -3372,7 +3373,7 @@ font_load_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec) Lisp_Object lsize = Ffont_get (spec, QCsize); if ((FLOATP (lsize) && XFLOAT_DATA (lsize) == font_size) - || (INTEGERP (lsize) && XINT (lsize) == font_size)) + || (FIXNUMP (lsize) && XFIXNUM (lsize) == font_size)) { ASET (spec, FONT_FAMILY_INDEX, font_intern_prop (p, tail - p, 1)); @@ -3433,9 +3434,9 @@ font_open_by_spec (struct frame *f, Lisp_Object spec) attrs[LFACE_SWIDTH_INDEX] = attrs[LFACE_WEIGHT_INDEX] = attrs[LFACE_SLANT_INDEX] = Qnormal; #ifndef HAVE_NS - attrs[LFACE_HEIGHT_INDEX] = make_number (120); + attrs[LFACE_HEIGHT_INDEX] = make_fixnum (120); #else - attrs[LFACE_HEIGHT_INDEX] = make_number (0); + attrs[LFACE_HEIGHT_INDEX] = make_fixnum (0); #endif attrs[LFACE_FONT_INDEX] = Qnil; @@ -3632,10 +3633,10 @@ font_put_frame_data (struct frame *f, Lisp_Object driver, void *data) else { if (NILP (val)) - fset_font_data (f, Fcons (Fcons (driver, make_save_ptr (data)), + fset_font_data (f, Fcons (Fcons (driver, make_mint_ptr (data)), f->font_data)); else - XSETCDR (val, make_save_ptr (data)); + XSETCDR (val, make_mint_ptr (data)); } } @@ -3644,7 +3645,7 @@ font_get_frame_data (struct frame *f, Lisp_Object driver) { Lisp_Object val = assq_no_quit (driver, f->font_data); - return NILP (val) ? NULL : XSAVE_POINTER (XCDR (val), 0); + return NILP (val) ? NULL : xmint_pointer (XCDR (val)); } #endif /* HAVE_XFT || HAVE_FREETYPE */ @@ -3673,7 +3674,7 @@ font_filter_properties (Lisp_Object font, if (strcmp (boolean_properties[i], keystr) == 0) { - const char *str = INTEGERP (val) ? (XINT (val) ? "true" : "false") + const char *str = FIXNUMP (val) ? (XFIXNUM (val) ? "true" : "false") : SYMBOLP (val) ? SSDATA (SYMBOL_NAME (val)) : "true"; @@ -3810,7 +3811,7 @@ font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit, face_id = NILP (Vface_remapping_alist) ? DEFAULT_FACE_ID - : lookup_basic_face (f, DEFAULT_FACE_ID); + : lookup_basic_face (w, f, DEFAULT_FACE_ID); face_id = face_at_string_position (w, string, pos, 0, &ignore, face_id, false); @@ -3827,8 +3828,8 @@ font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit, else FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte); category = CHAR_TABLE_REF (Vunicode_category_table, c); - if (INTEGERP (category) - && (XINT (category) == UNICODE_CATEGORY_Cf + if (FIXNUMP (category) + && (XFIXNUM (category) == UNICODE_CATEGORY_Cf || CHAR_VARIATION_SELECTOR_P (c))) continue; if (NILP (font_object)) @@ -4142,17 +4143,17 @@ are to be displayed on. If omitted, the selected frame is used. */) } val = AREF (font, FONT_SIZE_INDEX); - if (INTEGERP (val)) + if (FIXNUMP (val)) { Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX); - int dpi = INTEGERP (font_dpi) ? XINT (font_dpi) : FRAME_RES_Y (f); + int dpi = FIXNUMP (font_dpi) ? XFIXNUM (font_dpi) : FRAME_RES_Y (f); plist[n++] = QCheight; - plist[n++] = make_number (PIXEL_TO_POINT (XINT (val) * 10, dpi)); + plist[n++] = make_fixnum (PIXEL_TO_POINT (XFIXNUM (val) * 10, dpi)); } else if (FLOATP (val)) { plist[n++] = QCheight; - plist[n++] = make_number (10 * (int) XFLOAT_DATA (val)); + plist[n++] = make_fixnum (10 * (int) XFLOAT_DATA (val)); } val = FONT_WEIGHT_FOR_FACE (font); @@ -4231,8 +4232,8 @@ how close they are to PREFER. */) CHECK_FONT_SPEC (font_spec); if (! NILP (num)) { - CHECK_NUMBER (num); - n = XINT (num); + CHECK_FIXNUM (num); + n = XFIXNUM (num); if (n <= 0) return Qnil; } @@ -4289,7 +4290,7 @@ DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0, Optional 2nd argument FRAME, if non-nil, specifies the target frame. */) (Lisp_Object font_spec, Lisp_Object frame) { - Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil); + Lisp_Object val = Flist_fonts (font_spec, frame, make_fixnum (1), Qnil); if (CONSP (val)) val = XCAR (val); @@ -4354,12 +4355,11 @@ clear_font_cache (struct frame *f) Lisp_Object val, tmp, cache = driver_list->driver->get_cache (f); val = XCDR (cache); - while (! NILP (val) - && ! EQ (XCAR (XCAR (val)), driver_list->driver->type)) + while (eassert (CONSP (val)), + ! EQ (XCAR (XCAR (val)), driver_list->driver->type)) val = XCDR (val); - eassert (! NILP (val)); tmp = XCDR (XCAR (val)); - if (XINT (XCAR (tmp)) == 0) + if (XFIXNUM (XCAR (tmp)) == 0) { font_clear_cache (f, XCAR (val), driver_list->driver); XSETCDR (cache, XCDR (val)); @@ -4428,15 +4428,15 @@ GSTRING. */) for (i = 0; i < 3; i++) { n = font->driver->shape (gstring); - if (INTEGERP (n)) + if (FIXNUMP (n)) break; gstring = larger_vector (gstring, LGSTRING_GLYPH_LEN (gstring), -1); } - if (i == 3 || XINT (n) == 0) + if (i == 3 || XFIXNUM (n) == 0) return Qnil; - if (XINT (n) < LGSTRING_GLYPH_LEN (gstring)) - LGSTRING_SET_GLYPH (gstring, XINT (n), Qnil); + if (XFIXNUM (n) < LGSTRING_GLYPH_LEN (gstring)) + LGSTRING_SET_GLYPH (gstring, XFIXNUM (n), Qnil); /* Check FROM_IDX and TO_IDX of each GLYPH in GSTRING to assure that GLYPHS covers all characters (except for the last few ones) in @@ -4470,7 +4470,7 @@ GSTRING. */) from = LGLYPH_FROM (glyph); to = LGLYPH_TO (glyph); } - return composition_gstring_put_cache (gstring, XINT (n)); + return composition_gstring_put_cache (gstring, XFIXNUM (n)); shaper_error: return Qnil; @@ -4483,7 +4483,8 @@ Each element of the value is a cons (VARIATION-SELECTOR . GLYPH-ID), where VARIATION-SELECTOR is a character code of variation selection (#xFE00..#xFE0F or #xE0100..#xE01EF) - GLYPH-ID is a glyph code of the corresponding variation glyph. */) + GLYPH-ID is a glyph code of the corresponding variation glyph, +a fixnum, if it's small enough, otherwise a bignum. */) (Lisp_Object font_object, Lisp_Object character) { unsigned variations[256]; @@ -4496,7 +4497,7 @@ where font = XFONT_OBJECT (font_object); if (! font->driver->get_variation_glyphs) return Qnil; - n = font->driver->get_variation_glyphs (font, XINT (character), variations); + n = font->driver->get_variation_glyphs (font, XFIXNUM (character), variations); if (! n) return Qnil; val = Qnil; @@ -4504,8 +4505,8 @@ where if (variations[i]) { int vs = (i < 16 ? 0xFE00 + i : 0xE0100 + (i - 16)); - Lisp_Object code = INTEGER_TO_CONS (variations[i]); - val = Fcons (Fcons (make_number (vs), code), val); + Lisp_Object code = INT_TO_INTEGER (variations[i]); + val = Fcons (Fcons (make_fixnum (vs), code), val); } return val; } @@ -4520,7 +4521,8 @@ where that apply to POSITION. POSITION may be nil, in which case, FONT-SPEC is the font for displaying the character CH with the default face. GLYPH-CODE is the glyph code in the font to use for - the character. + the character, it is a fixnum, if it is small enough, otherwise a + bignum. For a text terminal, return a nonnegative integer glyph code for the character, or a negative integer if the character is not @@ -4557,9 +4559,9 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, if (NILP (position)) { CHECK_CHARACTER (ch); - c = XINT (ch); + c = XFIXNUM (ch); f = XFRAME (selected_frame); - face_id = lookup_basic_face (f, DEFAULT_FACE_ID); + face_id = lookup_basic_face (NULL, f, DEFAULT_FACE_ID); pos = -1; } else @@ -4567,17 +4569,17 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, Lisp_Object window; struct window *w; - CHECK_NUMBER_COERCE_MARKER (position); - if (! (BEGV <= XINT (position) && XINT (position) < ZV)) - args_out_of_range_3 (position, make_number (BEGV), make_number (ZV)); - pos = XINT (position); + CHECK_FIXNUM_COERCE_MARKER (position); + if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); + pos = XFIXNUM (position); pos_byte = CHAR_TO_BYTE (pos); if (NILP (ch)) c = FETCH_CHAR (pos_byte); else { - CHECK_NATNUM (ch); - c = XINT (ch); + CHECK_FIXNAT (ch); + c = XFIXNUM (ch); } window = Fget_buffer_window (Fcurrent_buffer (), Qnil); if (NILP (window)) @@ -4607,7 +4609,7 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, return Qnil; Lisp_Object font_object; XSETFONT (font_object, face->font); - return Fcons (font_object, INTEGER_TO_CONS (code)); + return Fcons (font_object, INT_TO_INTEGER (code)); } #if 0 @@ -4666,20 +4668,20 @@ glyph-string. */) CHECK_CONS (val); len = check_gstring (gstring_in); CHECK_VECTOR (gstring_out); - CHECK_NATNUM (from); - CHECK_NATNUM (to); - CHECK_NATNUM (index); - - if (XINT (from) >= XINT (to) || XINT (to) > len) - args_out_of_range_3 (from, to, make_number (len)); - if (XINT (index) >= ASIZE (gstring_out)) - args_out_of_range (index, make_number (ASIZE (gstring_out))); + CHECK_FIXNAT (from); + CHECK_FIXNAT (to); + CHECK_FIXNAT (index); + + if (XFIXNUM (from) >= XFIXNUM (to) || XFIXNUM (to) > len) + args_out_of_range_3 (from, to, make_fixnum (len)); + if (XFIXNUM (index) >= ASIZE (gstring_out)) + args_out_of_range (index, make_fixnum (ASIZE (gstring_out))); num = font->driver->otf_drive (font, otf_features, - gstring_in, XINT (from), XINT (to), - gstring_out, XINT (index), 0); + gstring_in, XFIXNUM (from), XFIXNUM (to), + gstring_out, XFIXNUM (index), 0); if (num < 0) return Qnil; - return make_number (num); + return make_fixnum (num); } DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates, @@ -4707,14 +4709,14 @@ corresponding character. */) CHECK_CHARACTER (character); CHECK_CONS (otf_features); - gstring_in = Ffont_make_gstring (font_object, make_number (1)); + gstring_in = Ffont_make_gstring (font_object, make_fixnum (1)); g = LGSTRING_GLYPH (gstring_in, 0); - LGLYPH_SET_CHAR (g, XINT (character)); - gstring_out = Ffont_make_gstring (font_object, make_number (10)); + LGLYPH_SET_CHAR (g, XFIXNUM (character)); + gstring_out = Ffont_make_gstring (font_object, make_fixnum (10)); while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1, gstring_out, 0, 1)) < 0) gstring_out = Ffont_make_gstring (font_object, - make_number (ASIZE (gstring_out) * 2)); + make_fixnum (ASIZE (gstring_out) * 2)); alternates = Qnil; for (i = 0; i < num; i++) { @@ -4722,8 +4724,8 @@ corresponding character. */) int c = LGLYPH_CHAR (g); unsigned code = LGLYPH_CODE (g); - alternates = Fcons (Fcons (make_number (code), - c > 0 ? make_number (c) : Qnil), + alternates = Fcons (Fcons (make_fixnum (code), + c > 0 ? make_fixnum (c) : Qnil), alternates); } return Fnreverse (alternates); @@ -4736,20 +4738,20 @@ DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0, doc: /* Open FONT-ENTITY. */) (Lisp_Object font_entity, Lisp_Object size, Lisp_Object frame) { - EMACS_INT isize; + intmax_t isize; struct frame *f = decode_live_frame (frame); CHECK_FONT_ENTITY (font_entity); if (NILP (size)) - isize = XINT (AREF (font_entity, FONT_SIZE_INDEX)); + isize = XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX)); else { - CHECK_NUMBER_OR_FLOAT (size); + CHECK_NUMBER (size); if (FLOATP (size)) isize = POINT_TO_PIXEL (XFLOAT_DATA (size), FRAME_RES_Y (f)); - else - isize = XINT (size); + else if (! integer_to_intmax (size, &isize)) + args_out_of_range (font_entity, size); if (! (INT_MIN <= isize && isize <= INT_MAX)) args_out_of_range (font_entity, size); if (isize == 0) @@ -4815,12 +4817,12 @@ If the font is not OpenType font, CAPABILITY is nil. */) ASET (val, 0, AREF (font_object, FONT_NAME_INDEX)); ASET (val, 1, AREF (font_object, FONT_FILE_INDEX)); - ASET (val, 2, make_number (font->pixel_size)); - ASET (val, 3, make_number (font->max_width)); - ASET (val, 4, make_number (font->ascent)); - ASET (val, 5, make_number (font->descent)); - ASET (val, 6, make_number (font->space_width)); - ASET (val, 7, make_number (font->average_width)); + ASET (val, 2, make_fixnum (font->pixel_size)); + ASET (val, 3, make_fixnum (font->max_width)); + ASET (val, 4, make_fixnum (font->ascent)); + ASET (val, 5, make_fixnum (font->descent)); + ASET (val, 6, make_fixnum (font->space_width)); + ASET (val, 7, make_fixnum (font->average_width)); if (font->driver->otf_capability) ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font))); else @@ -4863,15 +4865,15 @@ the corresponding element is nil. */) validate_region (&from, &to); if (EQ (from, to)) return Qnil; - len = XFASTINT (to) - XFASTINT (from); + len = XFIXNAT (to) - XFIXNAT (from); SAFE_ALLOCA_LISP (chars, len); - charpos = XFASTINT (from); + charpos = XFIXNAT (from); bytepos = CHAR_TO_BYTE (charpos); - for (i = 0; charpos < XFASTINT (to); i++) + for (i = 0; charpos < XFIXNAT (to); i++) { int c; FETCH_CHAR_ADVANCE (c, charpos, bytepos); - chars[i] = make_number (c); + chars[i] = make_fixnum (c); } } else if (STRINGP (object)) @@ -4897,12 +4899,12 @@ the corresponding element is nil. */) for (i = 0; i < len; i++) { c = STRING_CHAR_ADVANCE (p); - chars[i] = make_number (c); + chars[i] = make_fixnum (c); } } else for (i = 0; i < len; i++) - chars[i] = make_number (p[ifrom + i]); + chars[i] = make_fixnum (p[ifrom + i]); } else if (VECTORP (object)) { @@ -4926,7 +4928,7 @@ the corresponding element is nil. */) for (i = 0; i < len; i++) { Lisp_Object g; - int c = XFASTINT (chars[i]); + int c = XFIXNAT (chars[i]); unsigned code; struct font_metrics metrics; @@ -4979,19 +4981,19 @@ character at index specified by POSITION. */) { if (XBUFFER (w->contents) != current_buffer) error ("Specified window is not displaying the current buffer"); - CHECK_NUMBER_COERCE_MARKER (position); - if (! (BEGV <= XINT (position) && XINT (position) < ZV)) - args_out_of_range_3 (position, make_number (BEGV), make_number (ZV)); + CHECK_FIXNUM_COERCE_MARKER (position); + if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); } else { - CHECK_NUMBER (position); + CHECK_FIXNUM (position); CHECK_STRING (string); - if (! (0 <= XINT (position) && XINT (position) < SCHARS (string))) + if (! (0 <= XFIXNUM (position) && XFIXNUM (position) < SCHARS (string))) args_out_of_range (string, position); } - return font_at (-1, XINT (position), NULL, w, string); + return font_at (-1, XFIXNUM (position), NULL, w, string); } #if 0 @@ -5014,9 +5016,9 @@ Type C-l to recover what previously shown. */) code = alloca (sizeof (unsigned) * len); for (i = 0; i < len; i++) { - Lisp_Object ch = Faref (string, make_number (i)); + Lisp_Object ch = Faref (string, make_fixnum (i)); Lisp_Object val; - int c = XINT (ch); + int c = XFIXNUM (ch); code[i] = font->driver->encode_char (font, c); if (code[i] == FONT_INVALID_CODE) @@ -5031,7 +5033,7 @@ Type C-l to recover what previously shown. */) if (font->driver->done_face) font->driver->done_face (f, face); face->fontp = NULL; - return make_number (len); + return make_fixnum (len); } #endif @@ -5134,16 +5136,16 @@ If the named font is not yet loaded, return nil. */) info = make_uninit_vector (14); ASET (info, 0, AREF (font_object, FONT_NAME_INDEX)); ASET (info, 1, AREF (font_object, FONT_FULLNAME_INDEX)); - ASET (info, 2, make_number (font->pixel_size)); - ASET (info, 3, make_number (font->height)); - ASET (info, 4, make_number (font->baseline_offset)); - ASET (info, 5, make_number (font->relative_compose)); - ASET (info, 6, make_number (font->default_ascent)); - ASET (info, 7, make_number (font->max_width)); - ASET (info, 8, make_number (font->ascent)); - ASET (info, 9, make_number (font->descent)); - ASET (info, 10, make_number (font->space_width)); - ASET (info, 11, make_number (font->average_width)); + ASET (info, 2, make_fixnum (font->pixel_size)); + ASET (info, 3, make_fixnum (font->height)); + ASET (info, 4, make_fixnum (font->baseline_offset)); + ASET (info, 5, make_fixnum (font->relative_compose)); + ASET (info, 6, make_fixnum (font->default_ascent)); + ASET (info, 7, make_fixnum (font->max_width)); + ASET (info, 8, make_fixnum (font->ascent)); + ASET (info, 9, make_fixnum (font->descent)); + ASET (info, 10, make_fixnum (font->space_width)); + ASET (info, 11, make_fixnum (font->average_width)); ASET (info, 12, AREF (font_object, FONT_FILE_INDEX)); if (font->driver->otf_capability) ASET (info, 13, Fcons (Qopentype, font->driver->otf_capability (font))); @@ -5166,15 +5168,14 @@ If the named font is not yet loaded, return nil. */) static Lisp_Object build_style_table (const struct table_entry *entry, int nelement) { - int i, j; - Lisp_Object table, elt; - - table = make_uninit_vector (nelement); - for (i = 0; i < nelement; i++) + Lisp_Object table = make_uninit_vector (nelement); + for (int i = 0; i < nelement; i++) { - for (j = 0; entry[i].names[j]; j++); - elt = Fmake_vector (make_number (j + 1), Qnil); - ASET (elt, 0, make_number (entry[i].numeric)); + int j; + for (j = 0; entry[i].names[j]; j++) + continue; + Lisp_Object elt = make_nil_vector (j + 1); + ASET (elt, 0, make_fixnum (entry[i].numeric)); for (j = 0; entry[i].names[j]; j++) ASET (elt, j + 1, intern_c_string (entry[i].names[j])); ASET (table, i, elt); @@ -5355,7 +5356,7 @@ syms_of_font (void) scratch_font_prefer = Ffont_spec (0, NULL); staticpro (&Vfont_log_deferred); - Vfont_log_deferred = Fmake_vector (make_number (3), Qnil); + Vfont_log_deferred = make_nil_vector (3); #if 0 #ifdef HAVE_LIBOTF diff --git a/src/font.h b/src/font.h index d358110ce9a..741bc1033f3 100644 --- a/src/font.h +++ b/src/font.h @@ -185,16 +185,16 @@ enum font_property_index /* Return the numeric weight value of FONT. */ #define FONT_WEIGHT_NUMERIC(font) \ - (INTEGERP (AREF ((font), FONT_WEIGHT_INDEX)) \ - ? (XINT (AREF ((font), FONT_WEIGHT_INDEX)) >> 8) : -1) + (FIXNUMP (AREF ((font), FONT_WEIGHT_INDEX)) \ + ? (XFIXNUM (AREF ((font), FONT_WEIGHT_INDEX)) >> 8) : -1) /* Return the numeric slant value of FONT. */ #define FONT_SLANT_NUMERIC(font) \ - (INTEGERP (AREF ((font), FONT_SLANT_INDEX)) \ - ? (XINT (AREF ((font), FONT_SLANT_INDEX)) >> 8) : -1) + (FIXNUMP (AREF ((font), FONT_SLANT_INDEX)) \ + ? (XFIXNUM (AREF ((font), FONT_SLANT_INDEX)) >> 8) : -1) /* Return the numeric width value of FONT. */ #define FONT_WIDTH_NUMERIC(font) \ - (INTEGERP (AREF ((font), FONT_WIDTH_INDEX)) \ - ? (XINT (AREF ((font), FONT_WIDTH_INDEX)) >> 8) : -1) + (FIXNUMP (AREF ((font), FONT_WIDTH_INDEX)) \ + ? (XFIXNUM (AREF ((font), FONT_WIDTH_INDEX)) >> 8) : -1) /* Return the symbolic weight value of FONT. */ #define FONT_WEIGHT_SYMBOLIC(font) \ font_style_symbolic (font, FONT_WEIGHT_INDEX, false) @@ -228,7 +228,7 @@ enum font_property_index style-related font property index (FONT_WEIGHT/SLANT/WIDTH_INDEX). VAL (integer or symbol) is the numeric or symbolic style value. */ #define FONT_SET_STYLE(font, prop, val) \ - ASET ((font), prop, make_number (font_style_to_value (prop, val, true))) + ASET ((font), prop, make_fixnum (font_style_to_value (prop, val, true))) #ifndef MSDOS #define FONT_WIDTH(f) ((f)->max_width) @@ -494,42 +494,42 @@ INLINE struct font_spec * XFONT_SPEC (Lisp_Object p) { eassert (FONT_SPEC_P (p)); - return XUNTAG (p, Lisp_Vectorlike); + return XUNTAG (p, Lisp_Vectorlike, struct font_spec); } INLINE struct font_spec * GC_XFONT_SPEC (Lisp_Object p) { eassert (GC_FONT_SPEC_P (p)); - return XUNTAG (p, Lisp_Vectorlike); + return XUNTAG (p, Lisp_Vectorlike, struct font_spec); } INLINE struct font_entity * XFONT_ENTITY (Lisp_Object p) { eassert (FONT_ENTITY_P (p)); - return XUNTAG (p, Lisp_Vectorlike); + return XUNTAG (p, Lisp_Vectorlike, struct font_entity); } INLINE struct font_entity * GC_XFONT_ENTITY (Lisp_Object p) { eassert (GC_FONT_ENTITY_P (p)); - return XUNTAG (p, Lisp_Vectorlike); + return XUNTAG (p, Lisp_Vectorlike, struct font_entity); } INLINE struct font * XFONT_OBJECT (Lisp_Object p) { eassert (FONT_OBJECT_P (p)); - return XUNTAG (p, Lisp_Vectorlike); + return XUNTAG (p, Lisp_Vectorlike, struct font); } INLINE struct font * GC_XFONT_OBJECT (Lisp_Object p) { eassert (GC_FONT_OBJECT_P (p)); - return XUNTAG (p, Lisp_Vectorlike); + return XUNTAG (p, Lisp_Vectorlike, struct font); } #define XSETFONT(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FONT)) @@ -613,7 +613,7 @@ struct font_driver (symbols). */ Lisp_Object (*list_family) (struct frame *f); - /* Optional (if FONT_EXTRA_INDEX is not Lisp_Save_Value). + /* Optional. Free FONT_EXTRA_INDEX field of FONT_ENTITY. */ void (*free_entity) (Lisp_Object font_entity); @@ -945,6 +945,22 @@ extern void font_deferred_log (const char *, Lisp_Object, Lisp_Object); font_deferred_log ((ACTION), (ARG), (RESULT)); \ } while (false) +/* FIXME: This is for use in functions that can be called while + garbage-collecting, but which assume that Lisp data structures are + properly-formed. This invalid assumption can lead to core dumps + (Bug#20890). */ +INLINE bool +font_data_structures_may_be_ill_formed (void) +{ +#ifdef USE_CAIRO + /* Although this works around Bug#20890, it is probably not the + right thing to do. */ + return gc_in_progress; +#else + return false; +#endif +} + INLINE_HEADER_END #endif /* not EMACS_FONT_H */ diff --git a/src/fontset.c b/src/fontset.c index 8e0c5746fe7..55a3f78e865 100644 --- a/src/fontset.c +++ b/src/fontset.c @@ -266,7 +266,7 @@ set_fontset_fallback (Lisp_Object fontset, Lisp_Object fallback) #define RFONT_DEF_FACE(rfont_def) AREF (rfont_def, 0) #define RFONT_DEF_SET_FACE(rfont_def, face_id) \ - ASET ((rfont_def), 0, make_number (face_id)) + ASET ((rfont_def), 0, make_fixnum (face_id)) #define RFONT_DEF_FONT_DEF(rfont_def) AREF (rfont_def, 1) #define RFONT_DEF_SPEC(rfont_def) FONT_DEF_SPEC (AREF (rfont_def, 1)) #define RFONT_DEF_OBJECT(rfont_def) AREF (rfont_def, 2) @@ -276,15 +276,15 @@ set_fontset_fallback (Lisp_Object fontset, Lisp_Object fallback) the order of listing by font backends, the higher bits represents the order given by charset priority list. The smaller value is preferable. */ -#define RFONT_DEF_SCORE(rfont_def) XINT (AREF (rfont_def, 3)) +#define RFONT_DEF_SCORE(rfont_def) XFIXNUM (AREF (rfont_def, 3)) #define RFONT_DEF_SET_SCORE(rfont_def, score) \ - ASET ((rfont_def), 3, make_number (score)) + ASET ((rfont_def), 3, make_fixnum (score)) #define RFONT_DEF_NEW(rfont_def, font_def) \ do { \ - (rfont_def) = Fmake_vector (make_number (4), Qnil); \ - ASET ((rfont_def), 1, (font_def)); \ - RFONT_DEF_SET_SCORE ((rfont_def), 0); \ - } while (0) + (rfont_def) = make_nil_vector (4); \ + ASET (rfont_def, 1, font_def); \ + RFONT_DEF_SET_SCORE (rfont_def, 0); \ + } while (false) /* Return the element of FONTSET for the character C. If FONTSET is a @@ -327,11 +327,8 @@ fontset_ref (Lisp_Object fontset, int c) #define FONTSET_ADD(fontset, range, elt, add) \ (NILP (add) \ ? (NILP (range) \ - ? (set_fontset_fallback \ - (fontset, Fmake_vector (make_number (1), (elt)))) \ - : ((void) \ - Fset_char_table_range (fontset, range, \ - Fmake_vector (make_number (1), elt)))) \ + ? set_fontset_fallback (fontset, make_vector (1, elt)) \ + : (void) Fset_char_table_range (fontset, range, make_vector (1, elt))) \ : fontset_add ((fontset), (range), (elt), (add))) static void @@ -340,12 +337,12 @@ fontset_add (Lisp_Object fontset, Lisp_Object range, Lisp_Object elt, Lisp_Objec Lisp_Object args[2]; int idx = (EQ (add, Qappend) ? 0 : 1); - args[1 - idx] = Fmake_vector (make_number (1), elt); + args[1 - idx] = make_vector (1, elt); if (CONSP (range)) { - int from = XINT (XCAR (range)); - int to = XINT (XCDR (range)); + int from = XFIXNUM (XCAR (range)); + int to = XFIXNUM (XCDR (range)); int from1, to1; do { @@ -456,7 +453,7 @@ reorder_font_vector (Lisp_Object font_group, struct font *font) qsort (XVECTOR (vec)->contents, size, word_size, fontset_compare_rfontdef); EMACS_INT low_tick_bits = charset_ordered_list_tick & MOST_POSITIVE_FIXNUM; - XSETCAR (font_group, make_number (low_tick_bits)); + XSETCAR (font_group, make_fixnum (low_tick_bits)); } /* Return a font-group (actually a cons (CHARSET_ORDERED_LIST_TICK @@ -496,7 +493,7 @@ fontset_get_font_group (Lisp_Object fontset, int c) for C, or the fontset does not have fallback fonts. */ if (NILP (font_group)) { - font_group = make_number (0); + font_group = make_fixnum (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 @@ -520,7 +517,7 @@ fontset_get_font_group (Lisp_Object fontset, int c) RFONT_DEF_SET_SCORE (rfont_def, i); ASET (font_group, i, rfont_def); } - font_group = Fcons (make_number (-1), font_group); + font_group = Fcons (make_fixnum (-1), font_group); if (c >= 0) char_table_set_range (fontset, from, to, font_group); else @@ -561,7 +558,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, if (ASIZE (vec) > 1) { - if (XINT (XCAR (font_group)) != charset_ordered_list_tick) + if (XFIXNUM (XCAR (font_group)) != charset_ordered_list_tick) /* We have just created the font-group, or the charset priorities were changed. */ reorder_font_vector (font_group, face->ascii_face->font); @@ -577,7 +574,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, break; repertory = FONT_DEF_REPERTORY (RFONT_DEF_FONT_DEF (rfont_def)); - if (XINT (repertory) == charset_id) + if (XFIXNUM (repertory) == charset_id) { charset_matched = i; break; @@ -633,8 +630,8 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, /* This is a sign of not to try the other fonts. */ return Qt; } - if (INTEGERP (RFONT_DEF_FACE (rfont_def)) - && XINT (RFONT_DEF_FACE (rfont_def)) < 0) + if (FIXNUMP (RFONT_DEF_FACE (rfont_def)) + && XFIXNUM (RFONT_DEF_FACE (rfont_def)) < 0) /* We couldn't open this font last time. */ continue; @@ -701,7 +698,6 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, { /* We found a font. Open it and insert a new element for that font in VEC. */ - Lisp_Object new_vec; int j; font_object = font_open_for_lface (f, font_entity, face->lface, @@ -711,7 +707,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, RFONT_DEF_NEW (rfont_def, font_def); RFONT_DEF_SET_OBJECT (rfont_def, font_object); RFONT_DEF_SET_SCORE (rfont_def, RFONT_DEF_SCORE (rfont_def)); - new_vec = Fmake_vector (make_number (ASIZE (vec) + 1), Qnil); + Lisp_Object new_vec = make_nil_vector (ASIZE (vec) + 1); found_index++; for (j = 0; j < found_index; j++) ASET (new_vec, j, AREF (vec, j)); @@ -727,7 +723,7 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face, } /* Record that no font in this font group supports C. */ - FONTSET_SET (fontset, make_number (c), make_number (0)); + FONTSET_SET (fontset, make_fixnum (c), make_fixnum (0)); return Qnil; found: @@ -756,12 +752,12 @@ fontset_font (Lisp_Object fontset, int c, struct face *face, int id) Lisp_Object base_fontset; /* Try a font-group of FONTSET. */ - FONT_DEFERRED_LOG ("current fontset: font for", make_number (c), Qnil); + FONT_DEFERRED_LOG ("current fontset: font for", make_fixnum (c), Qnil); rfont_def = fontset_find_font (fontset, c, face, id, 0); if (VECTORP (rfont_def)) return rfont_def; if (NILP (rfont_def)) - FONTSET_SET (fontset, make_number (c), make_number (0)); + FONTSET_SET (fontset, make_fixnum (c), make_fixnum (0)); /* Try a font-group of the default fontset. */ base_fontset = FONTSET_BASE (fontset); @@ -771,37 +767,37 @@ fontset_font (Lisp_Object fontset, int c, struct face *face, int id) set_fontset_default (fontset, make_fontset (FONTSET_FRAME (fontset), Qnil, Vdefault_fontset)); - FONT_DEFERRED_LOG ("default fontset: font for", make_number (c), Qnil); + FONT_DEFERRED_LOG ("default fontset: font for", make_fixnum (c), Qnil); default_rfont_def = fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 0); if (VECTORP (default_rfont_def)) return default_rfont_def; if (NILP (default_rfont_def)) - FONTSET_SET (FONTSET_DEFAULT (fontset), make_number (c), - make_number (0)); + FONTSET_SET (FONTSET_DEFAULT (fontset), make_fixnum (c), + make_fixnum (0)); } /* Try a fallback font-group of FONTSET. */ if (! EQ (rfont_def, Qt)) { - FONT_DEFERRED_LOG ("current fallback: font for", make_number (c), Qnil); + FONT_DEFERRED_LOG ("current fallback: font for", make_fixnum (c), Qnil); rfont_def = fontset_find_font (fontset, c, face, id, 1); if (VECTORP (rfont_def)) return rfont_def; /* Remember that FONTSET has no font for C. */ - FONTSET_SET (fontset, make_number (c), Qt); + FONTSET_SET (fontset, make_fixnum (c), Qt); } /* Try a fallback font-group of the default fontset. */ if (! EQ (base_fontset, Vdefault_fontset) && ! EQ (default_rfont_def, Qt)) { - FONT_DEFERRED_LOG ("default fallback: font for", make_number (c), Qnil); + FONT_DEFERRED_LOG ("default fallback: font for", make_fixnum (c), Qnil); rfont_def = fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 1); if (VECTORP (rfont_def)) return rfont_def; /* Remember that the default fontset has no font for C. */ - FONTSET_SET (FONTSET_DEFAULT (fontset), make_number (c), Qt); + FONTSET_SET (FONTSET_DEFAULT (fontset), make_fixnum (c), Qt); } return Qnil; @@ -830,7 +826,7 @@ make_fontset (Lisp_Object frame, Lisp_Object name, Lisp_Object base) fontset = Fmake_char_table (Qfontset, Qnil); - set_fontset_id (fontset, make_number (id)); + set_fontset_id (fontset, make_fixnum (id)); if (NILP (base)) set_fontset_name (fontset, name); else @@ -892,7 +888,7 @@ free_face_fontset (struct frame *f, struct face *face) next_fontset_id = face->fontset; if (! NILP (FONTSET_DEFAULT (fontset))) { - int id = XINT (FONTSET_ID (FONTSET_DEFAULT (fontset))); + int id = XFIXNUM (FONTSET_ID (FONTSET_DEFAULT (fontset))); fontset = AREF (Vfontset_table, id); eassert (!NILP (fontset) && ! BASE_FONTSET_P (fontset)); @@ -973,7 +969,7 @@ face_for_char (struct frame *f, struct face *face, int c, } else { - charset = Fget_char_property (make_number (pos), Qcharset, object); + charset = Fget_char_property (make_fixnum (pos), Qcharset, object); if (CHARSETP (charset)) { Lisp_Object val; @@ -981,7 +977,7 @@ face_for_char (struct frame *f, struct face *face, int c, val = assq_no_quit (charset, Vfont_encoding_charset_alist); if (CONSP (val) && CHARSETP (XCDR (val))) charset = XCDR (val); - id = XINT (CHARSET_SYMBOL_ID (charset)); + id = XFIXNUM (CHARSET_SYMBOL_ID (charset)); } else id = -1; @@ -990,8 +986,8 @@ face_for_char (struct frame *f, struct face *face, int c, rfont_def = fontset_font (fontset, c, face, id); if (VECTORP (rfont_def)) { - if (INTEGERP (RFONT_DEF_FACE (rfont_def))) - face_id = XINT (RFONT_DEF_FACE (rfont_def)); + if (FIXNUMP (RFONT_DEF_FACE (rfont_def))) + face_id = XFIXNUM (RFONT_DEF_FACE (rfont_def)); else { Lisp_Object font_object; @@ -1003,12 +999,12 @@ face_for_char (struct frame *f, struct face *face, int c, } else { - if (INTEGERP (FONTSET_NOFONT_FACE (fontset))) - face_id = XINT (FONTSET_NOFONT_FACE (fontset)); + if (FIXNUMP (FONTSET_NOFONT_FACE (fontset))) + face_id = XFIXNUM (FONTSET_NOFONT_FACE (fontset)); else { face_id = face_for_font (f, Qnil, face); - set_fontset_nofont_face (fontset, make_number (face_id)); + set_fontset_nofont_face (fontset, make_fixnum (face_id)); } } eassert (face_id >= 0); @@ -1040,7 +1036,7 @@ font_for_char (struct face *face, int c, ptrdiff_t pos, Lisp_Object object) } else { - charset = Fget_char_property (make_number (pos), Qcharset, object); + charset = Fget_char_property (make_fixnum (pos), Qcharset, object); if (CHARSETP (charset)) { Lisp_Object val; @@ -1048,7 +1044,7 @@ font_for_char (struct face *face, int c, ptrdiff_t pos, Lisp_Object object) val = assq_no_quit (charset, Vfont_encoding_charset_alist); if (CONSP (val) && CHARSETP (XCDR (val))) charset = XCDR (val); - id = XINT (CHARSET_SYMBOL_ID (charset)); + id = XFIXNUM (CHARSET_SYMBOL_ID (charset)); } else id = -1; @@ -1083,7 +1079,7 @@ make_fontset_for_ascii_face (struct frame *f, int base_fontset_id, struct face * base_fontset = Vdefault_fontset; fontset = make_fontset (frame, Qnil, base_fontset); - return XINT (FONTSET_ID (fontset)); + return XFIXNUM (FONTSET_ID (fontset)); } @@ -1306,7 +1302,7 @@ free_realized_fontsets (Lisp_Object base) tail = XCDR (tail)) { struct frame *f = XFRAME (FONTSET_FRAME (this)); - int face_id = XINT (XCDR (XCAR (tail))); + int face_id = XFIXNUM (XCDR (XCAR (tail))); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); /* Face THIS itself is also freed by the following call. */ @@ -1399,7 +1395,7 @@ static void set_fontset_font (Lisp_Object arg, Lisp_Object range) { Lisp_Object fontset, font_def, add, ascii, script_range_list; - int from = XINT (XCAR (range)), to = XINT (XCDR (range)); + int from = XFIXNUM (XCAR (range)), to = XFIXNUM (XCDR (range)); fontset = AREF (arg, 0); font_def = AREF (arg, 1); @@ -1412,11 +1408,11 @@ set_fontset_font (Lisp_Object arg, Lisp_Object range) if (to < 0x80) return; from = 0x80; - range = Fcons (make_number (0x80), XCDR (range)); + range = Fcons (make_fixnum (0x80), XCDR (range)); } -#define SCRIPT_FROM XINT (XCAR (XCAR (script_range_list))) -#define SCRIPT_TO XINT (XCDR (XCAR (script_range_list))) +#define SCRIPT_FROM XFIXNUM (XCAR (XCAR (script_range_list))) +#define SCRIPT_TO XFIXNUM (XCDR (XCAR (script_range_list))) #define POP_SCRIPT_RANGE() script_range_list = XCDR (script_range_list) for (; CONSP (script_range_list) && SCRIPT_TO < from; POP_SCRIPT_RANGE ()) @@ -1424,11 +1420,11 @@ set_fontset_font (Lisp_Object arg, Lisp_Object range) if (CONSP (script_range_list)) { if (SCRIPT_FROM < from) - range = Fcons (make_number (SCRIPT_FROM), XCDR (range)); + range = Fcons (make_fixnum (SCRIPT_FROM), XCDR (range)); while (CONSP (script_range_list) && SCRIPT_TO <= to) POP_SCRIPT_RANGE (); if (CONSP (script_range_list) && SCRIPT_FROM <= to) - XSETCAR (XCAR (script_range_list), make_number (to + 1)); + XSETCAR (XCAR (script_range_list), make_fixnum (to + 1)); } FONTSET_ADD (fontset, range, font_def, add); @@ -1547,7 +1543,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */) if (CHARACTERP (target)) { - if (XFASTINT (target) < 0x80) + if (XFIXNAT (target) < 0x80) error ("Can't set a font for partial ASCII range"); range_list = list1 (Fcons (target, target)); } @@ -1559,9 +1555,9 @@ appended. By default, FONT-SPEC overrides the previous settings. */) to = Fcdr (target); CHECK_CHARACTER (from); CHECK_CHARACTER (to); - if (XFASTINT (from) < 0x80) + if (XFIXNAT (from) < 0x80) { - if (XFASTINT (from) != 0 || XFASTINT (to) < 0x7F) + if (XFIXNAT (from) != 0 || XFIXNAT (to) < 0x7F) error ("Can't set a font for partial ASCII range"); ascii_changed = 1; } @@ -1632,7 +1628,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */) if (ascii_changed) { Lisp_Object tail, fr; - int fontset_id = XINT (FONTSET_ID (fontset)); + int fontset_id = XFIXNUM (FONTSET_ID (fontset)); set_fontset_ascii (fontset, fontname); name = FONTSET_NAME (fontset); @@ -1765,7 +1761,7 @@ fontset_from_font (Lisp_Object font_object) val = assoc_no_quit (font_spec, auto_fontset_alist); if (CONSP (val)) - return XINT (FONTSET_ID (XCDR (val))); + return XFIXNUM (FONTSET_ID (XCDR (val))); if (num_auto_fontsets++ == 0) alias = intern ("fontset-startup"); else @@ -1800,7 +1796,7 @@ fontset_from_font (Lisp_Object font_object) set_fontset_ascii (fontset, font_name); - return XINT (FONTSET_ID (fontset)); + return XFIXNUM (FONTSET_ID (fontset)); } @@ -1988,7 +1984,7 @@ patterns. */) fontset = check_fontset_name (name, &frame); CHECK_CHARACTER (ch); - c = XINT (ch); + c = XFIXNUM (ch); list = Qnil; while (1) { @@ -2003,9 +1999,9 @@ patterns. */) if (NILP (val)) return Qnil; repertory = AREF (val, 1); - if (INTEGERP (repertory)) + if (FIXNUMP (repertory)) { - struct charset *charset = CHARSET_FROM_ID (XINT (repertory)); + struct charset *charset = CHARSET_FROM_ID (XFIXNUM (repertory)); if (! CHAR_CHARSET_P (c, charset)) continue; @@ -2062,9 +2058,7 @@ Lisp_Object dump_fontset (Lisp_Object) EXTERNALLY_VISIBLE; Lisp_Object dump_fontset (Lisp_Object fontset) { - Lisp_Object vec; - - vec = Fmake_vector (make_number (3), Qnil); + Lisp_Object vec = make_nil_vector (3); ASET (vec, 0, FONTSET_ID (fontset)); if (BASE_FONTSET_P (fontset)) @@ -2112,9 +2106,9 @@ void syms_of_fontset (void) { DEFSYM (Qfontset, "fontset"); - Fput (Qfontset, Qchar_table_extra_slots, make_number (8)); + Fput (Qfontset, Qchar_table_extra_slots, make_fixnum (8)); DEFSYM (Qfontset_info, "fontset-info"); - Fput (Qfontset_info, Qchar_table_extra_slots, make_number (1)); + Fput (Qfontset_info, Qchar_table_extra_slots, make_fixnum (1)); DEFSYM (Qappend, "append"); DEFSYM (Qlatin, "latin"); @@ -2122,12 +2116,12 @@ syms_of_fontset (void) Vcached_fontset_data = Qnil; staticpro (&Vcached_fontset_data); - Vfontset_table = Fmake_vector (make_number (32), Qnil); + Vfontset_table = make_nil_vector (32); staticpro (&Vfontset_table); Vdefault_fontset = Fmake_char_table (Qfontset, Qnil); staticpro (&Vdefault_fontset); - set_fontset_id (Vdefault_fontset, make_number (0)); + set_fontset_id (Vdefault_fontset, make_fixnum (0)); set_fontset_name (Vdefault_fontset, build_pure_c_string ("-*-*-*-*-*-*-*-*-*-*-*-*-fontset-default")); diff --git a/src/frame.c b/src/frame.c index 9c3ff72271a..6efc2a61095 100644 --- a/src/frame.c +++ b/src/frame.c @@ -35,6 +35,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "buffer.h" /* These help us bind and responding to switch-frame events. */ #include "keyboard.h" +#include "ptr-bounds.h" #include "frame.h" #include "blockinput.h" #include "termchar.h" @@ -138,14 +139,9 @@ check_window_system (struct frame *f) /* Return the value of frame parameter PROP in frame FRAME. */ Lisp_Object -get_frame_param (register struct frame *frame, Lisp_Object prop) +get_frame_param (struct frame *frame, Lisp_Object prop) { - register Lisp_Object tem; - - tem = Fassq (prop, frame->param_alist); - if (EQ (tem, Qnil)) - return tem; - return Fcdr (tem); + return Fcdr (Fassq (prop, frame->param_alist)); } @@ -157,17 +153,17 @@ frame_size_history_add (struct frame *f, Lisp_Object fun_symbol, XSETFRAME (frame, f); if (CONSP (frame_size_history) - && INTEGERP (XCAR (frame_size_history)) - && 0 < XINT (XCAR (frame_size_history))) + && FIXNUMP (XCAR (frame_size_history)) + && 0 < XFIXNUM (XCAR (frame_size_history))) frame_size_history = - Fcons (make_number (XINT (XCAR (frame_size_history)) - 1), + Fcons (make_fixnum (XFIXNUM (XCAR (frame_size_history)) - 1), Fcons (list4 (frame, fun_symbol, ((width > 0) - ? list4 (make_number (FRAME_TEXT_WIDTH (f)), - make_number (FRAME_TEXT_HEIGHT (f)), - make_number (width), - make_number (height)) + ? list4 (make_fixnum (FRAME_TEXT_WIDTH (f)), + make_fixnum (FRAME_TEXT_HEIGHT (f)), + make_fixnum (width), + make_fixnum (height)) : Qnil), rest), XCDR (frame_size_history))); @@ -188,9 +184,9 @@ frame_inhibit_resize (struct frame *f, bool horizontal, Lisp_Object parameter) || (CONSP (frame_inhibit_implied_resize) && !NILP (Fmemq (parameter, frame_inhibit_implied_resize))) || (horizontal - && !EQ (fullscreen, Qnil) && !EQ (fullscreen, Qfullheight)) + && !NILP (fullscreen) && !EQ (fullscreen, Qfullheight)) || (!horizontal - && !EQ (fullscreen, Qnil) && !EQ (fullscreen, Qfullwidth)) + && !NILP (fullscreen) && !EQ (fullscreen, Qfullwidth)) || FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f)) : ((horizontal && f->inhibit_horizontal_resize) || (!horizontal && f->inhibit_vertical_resize))); @@ -218,8 +214,8 @@ set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) if (FRAME_MINIBUF_ONLY_P (f)) return; - if (TYPE_RANGED_INTEGERP (int, value)) - nlines = XINT (value); + if (TYPE_RANGED_FIXNUMP (int, value)) + nlines = XFIXNUM (value); else nlines = 0; @@ -316,12 +312,12 @@ predicates which report frame's specific UI-related capabilities. */) /* Placeholder used by temacs -nw before window.el is loaded. */ DEFUN ("frame-windows-min-size", Fframe_windows_min_size, Sframe_windows_min_size, 4, 4, 0, - doc: /* */ + doc: /* SKIP: real doc in window.el. */ attributes: const) (Lisp_Object frame, Lisp_Object horizontal, Lisp_Object ignore, Lisp_Object pixelwise) { - return make_number (0); + return make_fixnum (0); } /** @@ -354,11 +350,15 @@ frame_windows_min_size (Lisp_Object frame, Lisp_Object horizontal, int retval; if ((!NILP (horizontal) - && NUMBERP (par_size = get_frame_param (f, Qmin_width))) + && RANGED_FIXNUMP (INT_MIN, + par_size = get_frame_param (f, Qmin_width), + INT_MAX)) || (NILP (horizontal) - && NUMBERP (par_size = get_frame_param (f, Qmin_height)))) + && RANGED_FIXNUMP (INT_MIN, + par_size = get_frame_param (f, Qmin_height), + INT_MAX))) { - int min_size = XINT (par_size); + int min_size = XFIXNUM (par_size); /* Don't allow phantom frames. */ if (min_size < 1) @@ -371,7 +371,7 @@ frame_windows_min_size (Lisp_Object frame, Lisp_Object horizontal, : FRAME_COLUMN_WIDTH (f))); } else - retval = XINT (call4 (Qframe_windows_min_size, frame, horizontal, + retval = XFIXNUM (call4 (Qframe_windows_min_size, frame, horizontal, ignore, pixelwise)); /* Don't allow too small height of text-mode frames, or else cm.c might abort in cmcheckmagic. */ @@ -595,7 +595,7 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit, frame_size_history_add (f, Qadjust_frame_size_1, new_text_width, new_text_height, - list2 (parameter, make_number (inhibit))); + list2 (parameter, make_fixnum (inhibit))); /* The following two values are calculated from the old window body sizes and any "new" settings for scroll bars, dividers, fringes and @@ -741,8 +741,8 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit, frame_size_history_add (f, Qadjust_frame_size_3, new_text_width, new_text_height, - list4 (make_number (old_pixel_width), make_number (old_pixel_height), - make_number (new_pixel_width), make_number (new_pixel_height))); + list4 (make_fixnum (old_pixel_width), make_fixnum (old_pixel_height), + make_fixnum (new_pixel_width), make_fixnum (new_pixel_height))); /* Assign new sizes. */ FRAME_TEXT_WIDTH (f) = new_text_width; @@ -846,6 +846,7 @@ make_frame (bool mini_p) f->no_focus_on_map = false; f->no_accept_focus = false; f->z_group = z_group_none; + f->tooltip = false; #if ! defined (USE_GTK) && ! defined (HAVE_NS) f->last_tool_bar_item = -1; #endif @@ -1078,7 +1079,7 @@ make_initial_frame (void) #endif /* The default value of menu-bar-mode is t. */ - set_menu_bar_lines (f, make_number (1), Qnil); + set_menu_bar_lines (f, make_fixnum (1), Qnil); /* Allocate glyph matrices. */ adjust_frame_glyphs (f); @@ -1453,23 +1454,15 @@ This function returns FRAME, or nil if FRAME has been deleted. */) DEFUN ("handle-switch-frame", Fhandle_switch_frame, Shandle_switch_frame, 1, 1, "^e", doc: /* Handle a switch-frame event EVENT. Switch-frame events are usually bound to this function. -A switch-frame event tells Emacs that the window manager has requested -that the user's events be directed to the frame mentioned in the event. -This function selects the selected window of the frame of EVENT. - -If EVENT is frame object, handle it as if it were a switch-frame event -to that frame. */) +A switch-frame event is an event Emacs sends itself to +indicate that input is arriving in a new frame. It does not +necessarily represent user-visible input focus. */) (Lisp_Object event) { - Lisp_Object value; - /* Preserve prefix arg that the command loop just cleared. */ kset_prefix_arg (current_kboard, Vcurrent_prefix_arg); run_hook (Qmouse_leave_buffer_hook); - /* `switch-frame' implies a focus in. */ - value = do_switch_frame (event, 0, 0, Qnil); - call1 (intern ("handle-focus-in"), event); - return value; + return do_switch_frame (event, 0, 0, Qnil); } DEFUN ("selected-frame", Fselected_frame, Sselected_frame, 0, 0, 0, @@ -1481,20 +1474,21 @@ DEFUN ("selected-frame", Fselected_frame, Sselected_frame, 0, 0, 0, DEFUN ("frame-list", Fframe_list, Sframe_list, 0, 0, 0, - doc: /* Return a list of all live frames. */) + doc: /* Return a list of all live frames. +The return value does not include any tooltip frame. */) (void) { - Lisp_Object frames; - frames = Fcopy_sequence (Vframe_list); #ifdef HAVE_WINDOW_SYSTEM - if (FRAMEP (tip_frame) -#ifdef USE_GTK - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) - frames = Fdelq (tip_frame, frames); -#endif - return frames; + Lisp_Object list = Qnil, tail, frame; + + FOR_EACH_FRAME (tail, frame) + if (!FRAME_TOOLTIP_P (XFRAME (frame))) + list = Fcons (frame, list); + /* Reverse list for consistency with the !HAVE_WINDOW_SYSTEM case. */ + return Fnreverse (list); +#else /* !HAVE_WINDOW_SYSTEM */ + return Fcopy_sequence (Vframe_list); +#endif /* HAVE_WINDOW_SYSTEM */ } DEFUN ("frame-parent", Fframe_parent, Sframe_parent, @@ -1603,7 +1597,7 @@ candidate_frame (Lisp_Object candidate, Lisp_Object frame, Lisp_Object minibuf) FRAME_FOCUS_FRAME (c))) return candidate; } - else if (INTEGERP (minibuf) && XINT (minibuf) == 0) + else if (FIXNUMP (minibuf) && XFIXNUM (minibuf) == 0) { if (FRAME_VISIBLE_P (c) || FRAME_ICONIFIED_P (c)) return candidate; @@ -1725,7 +1719,8 @@ DEFUN ("last-nonminibuffer-frame", Flast_nonminibuf_frame, * other_frames: * * Return true if there exists at least one visible or iconified frame - * but F. Return false otherwise. + * but F. Tooltip frames do not qualify as candidates. Return false + * if no such frame exists. * * INVISIBLE true means we are called from make_frame_invisible where * such a frame must be visible or iconified. INVISIBLE nil means we @@ -1739,7 +1734,6 @@ static bool other_frames (struct frame *f, bool invisible, bool force) { Lisp_Object frames, frame, frame1; - struct frame *f1; Lisp_Object minibuffer_window = FRAME_MINIBUF_WINDOW (f); XSETFRAME (frame, f); @@ -1749,7 +1743,8 @@ other_frames (struct frame *f, bool invisible, bool force) FOR_EACH_FRAME (frames, frame1) { - f1 = XFRAME (frame1); + struct frame *f1 = XFRAME (frame1); + if (f != f1) { /* Verify that we can still talk to the frame's X window, and @@ -1758,7 +1753,7 @@ other_frames (struct frame *f, bool invisible, bool force) if (FRAME_WINDOW_P (f1)) x_sync (f1); #endif - if (NILP (Fframe_parameter (frame1, Qtooltip)) + if (!FRAME_TOOLTIP_P (f1) /* Tooltips and child frames count neither for invisibility nor for deletions. */ && !FRAME_PARENT_FRAME (f1) @@ -1794,7 +1789,7 @@ check_minibuf_window (Lisp_Object frame, int select) if (WINDOWP (minibuf_window) && EQ (f->minibuffer_window, minibuf_window)) { - Lisp_Object frames, this, window = make_number (0); + Lisp_Object frames, this, window = make_fixnum (0); if (!EQ (frame, selected_frame) && FRAME_HAS_MINIBUF_P (XFRAME (selected_frame))) @@ -1891,7 +1886,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force) } } - is_tooltip_frame = !NILP (Fframe_parameter (frame, Qtooltip)); + is_tooltip_frame = FRAME_TOOLTIP_P (f); /* Run `delete-frame-functions' unless FORCE is `noelisp' or frame is a tooltip. FORCE is set to `noelisp' when handling @@ -1940,27 +1935,31 @@ delete_frame (Lisp_Object frame, Lisp_Object force) Do not call next_frame here because it may loop forever. See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=15025. */ FOR_EACH_FRAME (tail, frame1) - if (!EQ (frame, frame1) - && NILP (Fframe_parameter (frame1, Qtooltip)) - && (FRAME_TERMINAL (XFRAME (frame)) - == FRAME_TERMINAL (XFRAME (frame1))) - && FRAME_VISIBLE_P (XFRAME (frame1))) - break; + { + struct frame *f1 = XFRAME (frame1); + + if (!EQ (frame, frame1) + && !FRAME_TOOLTIP_P (f1) + && FRAME_TERMINAL (f) == FRAME_TERMINAL (f1) + && FRAME_VISIBLE_P (f1)) + break; + } /* If there is none, find *some* other frame. */ if (NILP (frame1) || EQ (frame1, frame)) { FOR_EACH_FRAME (tail, frame1) { + struct frame *f1 = XFRAME (frame1); + if (!EQ (frame, frame1) - && FRAME_LIVE_P (XFRAME (frame1)) - && NILP (Fframe_parameter (frame1, Qtooltip))) + && FRAME_LIVE_P (f1) + && !FRAME_TOOLTIP_P (f1)) { - /* Do not change a text terminal's top-frame. */ - struct frame *f1 = XFRAME (frame1); if (FRAME_TERMCAP_P (f1) || FRAME_MSDOS_P (f1)) { Lisp_Object top_frame = FRAME_TTY (f1)->top_frame; + if (!EQ (top_frame, frame)) frame1 = top_frame; } @@ -2161,6 +2160,16 @@ delete_frame (Lisp_Object frame, Lisp_Object force) if (!is_tooltip_frame) update_mode_lines = 15; + /* Now run the post-deletion hooks. */ + if (NILP (Vrun_hooks) || is_tooltip_frame) + ; + else if (EQ (force, Qnoelisp)) + pending_funcalls + = Fcons (list3 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame), + pending_funcalls); + else + safe_call2 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame); + return Qnil; } @@ -2310,8 +2319,8 @@ and returns whatever that function returns. */) if (! NILP (x)) { - int col = XINT (x); - int row = XINT (y); + int col = XFIXNUM (x); + int row = XFIXNUM (y); pixel_to_glyph_coords (f, col, row, &col, &row, NULL, 1); XSETINT (x, col); XSETINT (y, row); @@ -2420,19 +2429,19 @@ before calling this function on it, like this. #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_position (XFRAME (frame), XINT (x), XINT (y)); + frame_set_mouse_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y)); #else #if defined (MSDOS) if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XINT (x), XINT (y)); + mouse_moveto (XFIXNUM (x), XFIXNUM (y)); } #else #ifdef HAVE_GPM { Fselect_frame (frame, Qnil); - term_mouse_moveto (XINT (x), XINT (y)); + term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); } #endif #endif @@ -2461,19 +2470,19 @@ before calling this function on it, like this. #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_pixel_position (XFRAME (frame), XINT (x), XINT (y)); + frame_set_mouse_pixel_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y)); #else #if defined (MSDOS) if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XINT (x), XINT (y)); + mouse_moveto (XFIXNUM (x), XFIXNUM (y)); } #else #ifdef HAVE_GPM { Fselect_frame (frame, Qnil); - term_mouse_moveto (XINT (x), XINT (y)); + term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); } #endif #endif @@ -2798,10 +2807,8 @@ frames_discard_buffer (Lisp_Object buffer) void store_in_alist (Lisp_Object *alistptr, Lisp_Object prop, Lisp_Object val) { - register Lisp_Object tem; - - tem = Fassq (prop, *alistptr); - if (EQ (tem, Qnil)) + Lisp_Object tem = Fassq (prop, *alistptr); + if (NILP (tem)) *alistptr = Fcons (Fcons (prop, val), *alistptr); else Fsetcdr (tem, val); @@ -2965,7 +2972,7 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val) /* Update the frame parameter alist. */ old_alist_elt = Fassq (prop, f->param_alist); - if (EQ (old_alist_elt, Qnil)) + if (NILP (old_alist_elt)) fset_param_alist (f, Fcons (Fcons (prop, val), f->param_alist)); else Fsetcdr (old_alist_elt, val); @@ -2979,7 +2986,7 @@ store_frame_param (struct frame *f, Lisp_Object prop, Lisp_Object val) if (! FRAME_WINDOW_P (f)) { if (EQ (prop, Qmenu_bar_lines)) - set_menu_bar_lines (f, val, make_number (FRAME_MENU_BAR_LINES (f))); + set_menu_bar_lines (f, val, make_fixnum (FRAME_MENU_BAR_LINES (f))); else if (EQ (prop, Qname)) set_term_frame_name (f, val); } @@ -3052,13 +3059,13 @@ If FRAME is omitted or nil, return information on the currently selected frame. ? (f->new_height / FRAME_LINE_HEIGHT (f)) : f->new_height) : FRAME_LINES (f)); - store_in_alist (&alist, Qheight, make_number (height)); + store_in_alist (&alist, Qheight, make_fixnum (height)); width = (f->new_width ? (f->new_pixelwise ? (f->new_width / FRAME_COLUMN_WIDTH (f)) : f->new_width) : FRAME_COLS (f)); - store_in_alist (&alist, Qwidth, make_number (width)); + store_in_alist (&alist, Qwidth, make_fixnum (width)); store_in_alist (&alist, Qmodeline, (FRAME_WANTS_MODELINE_P (f) ? Qt : Qnil)); store_in_alist (&alist, Qunsplittable, (FRAME_NO_SPLIT_P (f) ? Qt : Qnil)); store_in_alist (&alist, Qbuffer_list, f->buffer_list); @@ -3110,7 +3117,7 @@ If FRAME is nil, describe the currently selected frame. */) 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); + value = make_fixnum (0); else if (EQ (parameter, Qfont) && FRAME_X_P (f)) value = FRAME_FONT (f)->props[FONT_NAME_INDEX]; #endif /* HAVE_WINDOW_SYSTEM */ @@ -3183,7 +3190,7 @@ list, but are otherwise ignored. */) #endif { - EMACS_INT length = XFASTINT (Flength (alist)); + EMACS_INT length = XFIXNAT (Flength (alist)); ptrdiff_t i; Lisp_Object *parms; Lisp_Object *values; @@ -3231,10 +3238,10 @@ For a terminal frame, the value is always 1. */) struct frame *f = decode_any_frame (frame); if (FRAME_WINDOW_P (f)) - return make_number (FRAME_LINE_HEIGHT (f)); + return make_fixnum (FRAME_LINE_HEIGHT (f)); else #endif - return make_number (1); + return make_fixnum (1); } @@ -3250,10 +3257,10 @@ For a terminal screen, the value is always 1. */) struct frame *f = decode_any_frame (frame); if (FRAME_WINDOW_P (f)) - return make_number (FRAME_COLUMN_WIDTH (f)); + return make_fixnum (FRAME_COLUMN_WIDTH (f)); else #endif - return make_number (1); + return make_fixnum (1); } DEFUN ("frame-native-width", Fframe_native_width, @@ -3267,10 +3274,10 @@ If FRAME is omitted or nil, the selected frame is used. */) #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (f)) - return make_number (FRAME_PIXEL_WIDTH (f)); + return make_fixnum (FRAME_PIXEL_WIDTH (f)); else #endif - return make_number (FRAME_TOTAL_COLS (f)); + return make_fixnum (FRAME_TOTAL_COLS (f)); } DEFUN ("frame-native-height", Fframe_native_height, @@ -3293,10 +3300,10 @@ to `frame-height'). */) #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (f)) - return make_number (FRAME_PIXEL_HEIGHT (f)); + return make_fixnum (FRAME_PIXEL_HEIGHT (f)); else #endif - return make_number (FRAME_TOTAL_LINES (f)); + return make_fixnum (FRAME_TOTAL_LINES (f)); } DEFUN ("tool-bar-pixel-width", Ftool_bar_pixel_width, @@ -3311,93 +3318,93 @@ is used. */) struct frame *f = decode_any_frame (frame); if (FRAME_WINDOW_P (f)) - return make_number (FRAME_TOOLBAR_WIDTH (f)); + return make_fixnum (FRAME_TOOLBAR_WIDTH (f)); #endif - return make_number (0); + return make_fixnum (0); } DEFUN ("frame-text-cols", Fframe_text_cols, Sframe_text_cols, 0, 1, 0, doc: /* Return width in columns of FRAME's text area. */) (Lisp_Object frame) { - return make_number (FRAME_COLS (decode_any_frame (frame))); + return make_fixnum (FRAME_COLS (decode_any_frame (frame))); } DEFUN ("frame-text-lines", Fframe_text_lines, Sframe_text_lines, 0, 1, 0, doc: /* Return height in lines of FRAME's text area. */) (Lisp_Object frame) { - return make_number (FRAME_LINES (decode_any_frame (frame))); + return make_fixnum (FRAME_LINES (decode_any_frame (frame))); } DEFUN ("frame-total-cols", Fframe_total_cols, Sframe_total_cols, 0, 1, 0, doc: /* Return number of total columns of FRAME. */) (Lisp_Object frame) { - return make_number (FRAME_TOTAL_COLS (decode_any_frame (frame))); + return make_fixnum (FRAME_TOTAL_COLS (decode_any_frame (frame))); } DEFUN ("frame-total-lines", Fframe_total_lines, Sframe_total_lines, 0, 1, 0, doc: /* Return number of total lines of FRAME. */) (Lisp_Object frame) { - return make_number (FRAME_TOTAL_LINES (decode_any_frame (frame))); + return make_fixnum (FRAME_TOTAL_LINES (decode_any_frame (frame))); } DEFUN ("frame-text-width", Fframe_text_width, Sframe_text_width, 0, 1, 0, doc: /* Return text area width of FRAME in pixels. */) (Lisp_Object frame) { - return make_number (FRAME_TEXT_WIDTH (decode_any_frame (frame))); + return make_fixnum (FRAME_TEXT_WIDTH (decode_any_frame (frame))); } DEFUN ("frame-text-height", Fframe_text_height, Sframe_text_height, 0, 1, 0, doc: /* Return text area height of FRAME in pixels. */) (Lisp_Object frame) { - return make_number (FRAME_TEXT_HEIGHT (decode_any_frame (frame))); + return make_fixnum (FRAME_TEXT_HEIGHT (decode_any_frame (frame))); } DEFUN ("frame-scroll-bar-width", Fscroll_bar_width, Sscroll_bar_width, 0, 1, 0, doc: /* Return scroll bar width of FRAME in pixels. */) (Lisp_Object frame) { - return make_number (FRAME_SCROLL_BAR_AREA_WIDTH (decode_any_frame (frame))); + return make_fixnum (FRAME_SCROLL_BAR_AREA_WIDTH (decode_any_frame (frame))); } DEFUN ("frame-scroll-bar-height", Fscroll_bar_height, Sscroll_bar_height, 0, 1, 0, doc: /* Return scroll bar height of FRAME in pixels. */) (Lisp_Object frame) { - return make_number (FRAME_SCROLL_BAR_AREA_HEIGHT (decode_any_frame (frame))); + return make_fixnum (FRAME_SCROLL_BAR_AREA_HEIGHT (decode_any_frame (frame))); } DEFUN ("frame-fringe-width", Ffringe_width, Sfringe_width, 0, 1, 0, doc: /* Return fringe width of FRAME in pixels. */) (Lisp_Object frame) { - return make_number (FRAME_TOTAL_FRINGE_WIDTH (decode_any_frame (frame))); + return make_fixnum (FRAME_TOTAL_FRINGE_WIDTH (decode_any_frame (frame))); } DEFUN ("frame-internal-border-width", Fframe_internal_border_width, Sframe_internal_border_width, 0, 1, 0, doc: /* Return width of FRAME's internal border in pixels. */) (Lisp_Object frame) { - return make_number (FRAME_INTERNAL_BORDER_WIDTH (decode_any_frame (frame))); + return make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (decode_any_frame (frame))); } DEFUN ("frame-right-divider-width", Fright_divider_width, Sright_divider_width, 0, 1, 0, doc: /* Return width (in pixels) of vertical window dividers on FRAME. */) (Lisp_Object frame) { - return make_number (FRAME_RIGHT_DIVIDER_WIDTH (decode_any_frame (frame))); + return make_fixnum (FRAME_RIGHT_DIVIDER_WIDTH (decode_any_frame (frame))); } DEFUN ("frame-bottom-divider-width", Fbottom_divider_width, Sbottom_divider_width, 0, 1, 0, doc: /* Return width (in pixels) of horizontal window dividers on FRAME. */) (Lisp_Object frame) { - return make_number (FRAME_BOTTOM_DIVIDER_WIDTH (decode_any_frame (frame))); + return make_fixnum (FRAME_BOTTOM_DIVIDER_WIDTH (decode_any_frame (frame))); } DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, 0, @@ -3418,8 +3425,8 @@ multiple of the default frame font height. */) CHECK_TYPE_RANGED_INTEGER (int, height); pixel_height = (!NILP (pixelwise) - ? XINT (height) - : XINT (height) * FRAME_LINE_HEIGHT (f)); + ? XFIXNUM (height) + : XFIXNUM (height) * FRAME_LINE_HEIGHT (f)); adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight); return Qnil; @@ -3443,8 +3450,8 @@ multiple of the default frame font width. */) CHECK_TYPE_RANGED_INTEGER (int, width); pixel_width = (!NILP (pixelwise) - ? XINT (width) - : XINT (width) * FRAME_COLUMN_WIDTH (f)); + ? XFIXNUM (width) + : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f)); adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth); return Qnil; @@ -3466,11 +3473,11 @@ font height. */) CHECK_TYPE_RANGED_INTEGER (int, height); pixel_width = (!NILP (pixelwise) - ? XINT (width) - : XINT (width) * FRAME_COLUMN_WIDTH (f)); + ? XFIXNUM (width) + : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f)); pixel_height = (!NILP (pixelwise) - ? XINT (height) - : XINT (height) * FRAME_LINE_HEIGHT (f)); + ? XFIXNUM (height) + : XFIXNUM (height) * FRAME_LINE_HEIGHT (f)); adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize); return Qnil; @@ -3487,7 +3494,7 @@ display. */) { register struct frame *f = decode_live_frame (frame); - return Fcons (make_number (f->left_pos), make_number (f->top_pos)); + return Fcons (make_fixnum (f->left_pos), make_fixnum (f->top_pos)); } DEFUN ("set-frame-position", Fset_frame_position, @@ -3510,7 +3517,7 @@ bottom edge of FRAME's display. */) if (FRAME_WINDOW_P (f)) { #ifdef HAVE_WINDOW_SYSTEM - x_set_offset (f, XINT (x), XINT (y), 1); + x_set_offset (f, XFIXNUM (x), XFIXNUM (y), 1); #endif } @@ -3679,10 +3686,10 @@ frame_float (struct frame *f, Lisp_Object val, enum frame_float_type what, } /* Workarea available. */ - parent_left = XINT (Fnth (make_number (0), workarea)); - parent_top = XINT (Fnth (make_number (1), workarea)); - parent_width = XINT (Fnth (make_number (2), workarea)); - parent_height = XINT (Fnth (make_number (3), workarea)); + parent_left = XFIXNUM (Fnth (make_fixnum (0), workarea)); + parent_top = XFIXNUM (Fnth (make_fixnum (1), workarea)); + parent_width = XFIXNUM (Fnth (make_fixnum (2), workarea)); + parent_height = XFIXNUM (Fnth (make_fixnum (3), workarea)); *parent_done = 1; } } @@ -3710,12 +3717,12 @@ frame_float (struct frame *f, Lisp_Object val, enum frame_float_type what, if (!NILP (outer_edges)) { outer_minus_text_width - = (XINT (Fnth (make_number (2), outer_edges)) - - XINT (Fnth (make_number (0), outer_edges)) + = (XFIXNUM (Fnth (make_fixnum (2), outer_edges)) + - XFIXNUM (Fnth (make_fixnum (0), outer_edges)) - FRAME_TEXT_WIDTH (f)); outer_minus_text_height - = (XINT (Fnth (make_number (3), outer_edges)) - - XINT (Fnth (make_number (1), outer_edges)) + = (XFIXNUM (Fnth (make_fixnum (3), outer_edges)) + - XFIXNUM (Fnth (make_fixnum (1), outer_edges)) - FRAME_TEXT_HEIGHT (f)); } else @@ -3795,7 +3802,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) Lisp_Object icon_left, icon_top; /* And with this. */ - Lisp_Object fullscreen; + Lisp_Object fullscreen UNINIT; bool fullscreen_change = false; /* Record in these vectors all the parms specified. */ @@ -3864,22 +3871,22 @@ 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) ; + if (RANGED_FIXNUMP (0, val, INT_MAX)) + width = XFIXNAT (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)); + && RANGED_FIXNUMP (0, XCDR (val), INT_MAX)) + width = XFIXNAT (XCDR (val)); else if (FLOATP (val)) width = frame_float (f, val, FRAME_FLOAT_WIDTH, &parent_done, &outer_done, -1); } else if (EQ (prop, Qheight)) { - if (RANGED_INTEGERP (0, val, INT_MAX)) - height = XFASTINT (val) * FRAME_LINE_HEIGHT (f); + if (RANGED_FIXNUMP (0, val, INT_MAX)) + height = XFIXNAT (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)); + && RANGED_FIXNUMP (0, XCDR (val), INT_MAX)) + height = XFIXNAT (XCDR (val)); else if (FLOATP (val)) height = frame_float (f, val, FRAME_FLOAT_HEIGHT, &parent_done, &outer_done, -1); @@ -3906,10 +3913,10 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) 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); + if (FIXNATP (param_index) + && XFIXNAT (param_index) < ARRAYELTS (frame_parms) + && FRAME_RIF (f)->frame_parm_handlers[XFIXNUM (param_index)]) + (*(FRAME_RIF (f)->frame_parm_handlers[XFIXNUM (param_index)])) (f, val, old_value); } } @@ -3918,7 +3925,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) { left_no_change = 1; if (f->left_pos < 0) - left = list2 (Qplus, make_number (f->left_pos)); + left = list2 (Qplus, make_fixnum (f->left_pos)); else XSETINT (left, f->left_pos); } @@ -3926,13 +3933,13 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) { top_no_change = 1; if (f->top_pos < 0) - top = list2 (Qplus, make_number (f->top_pos)); + top = list2 (Qplus, make_fixnum (f->top_pos)); else XSETINT (top, f->top_pos); } /* If one of the icon positions was not set, preserve or default it. */ - if (! TYPE_RANGED_INTEGERP (int, icon_left)) + if (! TYPE_RANGED_FIXNUMP (int, icon_left)) { #ifdef HAVE_X_WINDOWS icon_left_no_change = 1; @@ -3941,7 +3948,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) if (NILP (icon_left)) XSETINT (icon_left, 0); } - if (! TYPE_RANGED_INTEGERP (int, icon_top)) + if (! TYPE_RANGED_FIXNUMP (int, icon_top)) { #ifdef HAVE_X_WINDOWS icon_top_no_change = 1; @@ -3971,8 +3978,8 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) if ((!NILP (left) || !NILP (top)) && ! (left_no_change && top_no_change) - && ! (NUMBERP (left) && XINT (left) == f->left_pos - && NUMBERP (top) && XINT (top) == f->top_pos)) + && ! (FIXNUMP (left) && XFIXNUM (left) == f->left_pos + && FIXNUMP (top) && XFIXNUM (top) == f->top_pos)) { int leftpos = 0; int toppos = 0; @@ -3981,46 +3988,46 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) f->size_hint_flags &= ~ (XNegative | YNegative); if (EQ (left, Qminus)) f->size_hint_flags |= XNegative; - else if (TYPE_RANGED_INTEGERP (int, left)) + else if (TYPE_RANGED_FIXNUMP (int, left)) { - leftpos = XINT (left); + leftpos = XFIXNUM (left); if (leftpos < 0) f->size_hint_flags |= XNegative; } else if (CONSP (left) && EQ (XCAR (left), Qminus) && CONSP (XCDR (left)) - && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (left)), INT_MAX)) + && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (left)), INT_MAX)) { - leftpos = - XINT (XCAR (XCDR (left))); + leftpos = - XFIXNUM (XCAR (XCDR (left))); f->size_hint_flags |= XNegative; } else if (CONSP (left) && EQ (XCAR (left), Qplus) && CONSP (XCDR (left)) - && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (left)))) - leftpos = XINT (XCAR (XCDR (left))); + && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (left)))) + leftpos = XFIXNUM (XCAR (XCDR (left))); else if (FLOATP (left)) leftpos = frame_float (f, left, FRAME_FLOAT_LEFT, &parent_done, &outer_done, 0); if (EQ (top, Qminus)) f->size_hint_flags |= YNegative; - else if (TYPE_RANGED_INTEGERP (int, top)) + else if (TYPE_RANGED_FIXNUMP (int, top)) { - toppos = XINT (top); + toppos = XFIXNUM (top); if (toppos < 0) f->size_hint_flags |= YNegative; } else if (CONSP (top) && EQ (XCAR (top), Qminus) && CONSP (XCDR (top)) - && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (top)), INT_MAX)) + && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (top)), INT_MAX)) { - toppos = - XINT (XCAR (XCDR (top))); + toppos = - XFIXNUM (XCAR (XCDR (top))); f->size_hint_flags |= YNegative; } else if (CONSP (top) && EQ (XCAR (top), Qplus) && CONSP (XCDR (top)) - && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (top)))) - toppos = XINT (XCAR (XCDR (top))); + && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (top)))) + toppos = XFIXNUM (XCAR (XCDR (top))); else if (FLOATP (top)) toppos = frame_float (f, top, FRAME_FLOAT_TOP, &parent_done, &outer_done, 0); @@ -4051,7 +4058,7 @@ x_set_frame_parameters (struct frame *f, Lisp_Object alist) #ifdef HAVE_X_WINDOWS if ((!NILP (icon_left) || !NILP (icon_top)) && ! (icon_left_no_change && icon_top_no_change)) - x_wm_set_icon_position (f, XINT (icon_left), XINT (icon_top)); + x_wm_set_icon_position (f, XFIXNUM (icon_left), XFIXNUM (icon_top)); #endif /* HAVE_X_WINDOWS */ SAFE_FREE (); @@ -4086,31 +4093,31 @@ x_report_frame_params (struct frame *f, Lisp_Object *alistptr) store_in_alist (alistptr, Qtop, list2 (Qplus, tem)); store_in_alist (alistptr, Qborder_width, - make_number (f->border_width)); + make_fixnum (f->border_width)); store_in_alist (alistptr, Qinternal_border_width, - make_number (FRAME_INTERNAL_BORDER_WIDTH (f))); + make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f))); store_in_alist (alistptr, Qright_divider_width, - make_number (FRAME_RIGHT_DIVIDER_WIDTH (f))); + make_fixnum (FRAME_RIGHT_DIVIDER_WIDTH (f))); store_in_alist (alistptr, Qbottom_divider_width, - make_number (FRAME_BOTTOM_DIVIDER_WIDTH (f))); + make_fixnum (FRAME_BOTTOM_DIVIDER_WIDTH (f))); store_in_alist (alistptr, Qleft_fringe, - make_number (FRAME_LEFT_FRINGE_WIDTH (f))); + make_fixnum (FRAME_LEFT_FRINGE_WIDTH (f))); store_in_alist (alistptr, Qright_fringe, - make_number (FRAME_RIGHT_FRINGE_WIDTH (f))); + make_fixnum (FRAME_RIGHT_FRINGE_WIDTH (f))); store_in_alist (alistptr, Qscroll_bar_width, (! FRAME_HAS_VERTICAL_SCROLL_BARS (f) - ? make_number (0) + ? make_fixnum (0) : FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0 - ? make_number (FRAME_CONFIG_SCROLL_BAR_WIDTH (f)) + ? make_fixnum (FRAME_CONFIG_SCROLL_BAR_WIDTH (f)) /* nil means "use default width" for non-toolkit scroll bar. ruler-mode.el depends on this. */ : Qnil)); store_in_alist (alistptr, Qscroll_bar_height, (! FRAME_HAS_HORIZONTAL_SCROLL_BARS (f) - ? make_number (0) + ? make_fixnum (0) : FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0 - ? make_number (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f)) + ? make_fixnum (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f)) /* nil means "use default height" for non-toolkit scroll bar. */ : Qnil)); @@ -4140,7 +4147,7 @@ x_report_frame_params (struct frame *f, Lisp_Object *alistptr) if (FRAME_X_OUTPUT (f)->parent_desc == FRAME_DISPLAY_INFO (f)->root_window) tem = Qnil; else - tem = make_natnum ((uintptr_t) FRAME_X_OUTPUT (f)->parent_desc); + tem = make_fixed_natnum ((uintptr_t) FRAME_X_OUTPUT (f)->parent_desc); store_in_alist (alistptr, Qexplicit_name, (f->explicit_name ? Qt : Qnil)); store_in_alist (alistptr, Qparent_id, tem); store_in_alist (alistptr, Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)); @@ -4177,8 +4184,8 @@ x_set_line_spacing (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu { if (NILP (new_value)) f->extra_line_spacing = 0; - else if (RANGED_INTEGERP (0, new_value, INT_MAX)) - f->extra_line_spacing = XFASTINT (new_value); + else if (RANGED_FIXNUMP (0, new_value, INT_MAX)) + f->extra_line_spacing = XFIXNAT (new_value); else if (FLOATP (new_value)) { int new_spacing = XFLOAT_DATA (new_value) * FRAME_LINE_HEIGHT (f) + 0.5; @@ -4216,10 +4223,10 @@ x_set_screen_gamma (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu if (CONSP (bgcolor) && (bgcolor = XCDR (bgcolor), STRINGP (bgcolor))) { Lisp_Object parm_index = Fget (Qbackground_color, Qx_frame_parameter); - if (NATNUMP (parm_index) - && XFASTINT (parm_index) < ARRAYELTS (frame_parms) - && FRAME_RIF (f)->frame_parm_handlers[XFASTINT (parm_index)]) - (*FRAME_RIF (f)->frame_parm_handlers[XFASTINT (parm_index)]) + if (FIXNATP (parm_index) + && XFIXNAT (parm_index) < ARRAYELTS (frame_parms) + && FRAME_RIF (f)->frame_parm_handlers[XFIXNAT (parm_index)]) + (*FRAME_RIF (f)->frame_parm_handlers[XFIXNAT (parm_index)]) (f, bgcolor, Qnil); } @@ -4404,8 +4411,8 @@ x_set_left_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_value int old_width = FRAME_LEFT_FRINGE_WIDTH (f); int new_width; - new_width = (RANGED_INTEGERP (-INT_MAX, new_value, INT_MAX) - ? eabs (XINT (new_value)) : 8); + new_width = (RANGED_FIXNUMP (-INT_MAX, new_value, INT_MAX) + ? eabs (XFIXNUM (new_value)) : 8); if (new_width != old_width) { @@ -4428,8 +4435,8 @@ x_set_right_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu int old_width = FRAME_RIGHT_FRINGE_WIDTH (f); int new_width; - new_width = (RANGED_INTEGERP (-INT_MAX, new_value, INT_MAX) - ? eabs (XINT (new_value)) : 8); + new_width = (RANGED_FIXNUMP (-INT_MAX, new_value, INT_MAX) + ? eabs (XFIXNUM (new_value)) : 8); if (new_width != old_width) { @@ -4450,13 +4457,13 @@ x_set_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { CHECK_TYPE_RANGED_INTEGER (int, arg); - if (XINT (arg) == f->border_width) + if (XFIXNUM (arg) == f->border_width) return; if (FRAME_X_WINDOW (f) != 0) error ("Cannot change the border width of a frame"); - f->border_width = XINT (arg); + f->border_width = XFIXNUM (arg); } void @@ -4464,7 +4471,7 @@ 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); - int new = max (0, XINT (arg)); + int new = max (0, XFIXNUM (arg)); if (new != old) { f->right_divider_width = new; @@ -4479,7 +4486,7 @@ 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); - int new = max (0, XINT (arg)); + int new = max (0, XFIXNUM (arg)); if (new != old) { f->bottom_divider_width = new; @@ -4506,13 +4513,13 @@ x_set_visibility (struct frame *f, Lisp_Object value, Lisp_Object oldval) void x_set_autoraise (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - f->auto_raise = !EQ (Qnil, arg); + f->auto_raise = !NILP (arg); } void x_set_autolower (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - f->auto_lower = !EQ (Qnil, arg); + f->auto_lower = !NILP (arg); } void @@ -4588,11 +4595,11 @@ x_set_scroll_bar_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) SET_FRAME_GARBAGED (f); } - else if (RANGED_INTEGERP (1, arg, INT_MAX) - && XFASTINT (arg) != FRAME_CONFIG_SCROLL_BAR_WIDTH (f)) + else if (RANGED_FIXNUMP (1, arg, INT_MAX) + && XFIXNAT (arg) != FRAME_CONFIG_SCROLL_BAR_WIDTH (f)) { - FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = XFASTINT (arg); - FRAME_CONFIG_SCROLL_BAR_COLS (f) = (XFASTINT (arg) + unit - 1) / unit; + FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = XFIXNAT (arg); + FRAME_CONFIG_SCROLL_BAR_COLS (f) = (XFIXNAT (arg) + unit - 1) / unit; if (FRAME_X_WINDOW (f)) adjust_frame_size (f, -1, -1, 3, 0, Qscroll_bar_width); @@ -4618,11 +4625,11 @@ x_set_scroll_bar_height (struct frame *f, Lisp_Object arg, Lisp_Object oldval) SET_FRAME_GARBAGED (f); } - else if (RANGED_INTEGERP (1, arg, INT_MAX) - && XFASTINT (arg) != FRAME_CONFIG_SCROLL_BAR_HEIGHT (f)) + else if (RANGED_FIXNUMP (1, arg, INT_MAX) + && XFIXNAT (arg) != FRAME_CONFIG_SCROLL_BAR_HEIGHT (f)) { - FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = XFASTINT (arg); - FRAME_CONFIG_SCROLL_BAR_LINES (f) = (XFASTINT (arg) + unit - 1) / unit; + FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = XFIXNAT (arg); + FRAME_CONFIG_SCROLL_BAR_LINES (f) = (XFIXNAT (arg) + unit - 1) / unit; if (FRAME_X_WINDOW (f)) adjust_frame_size (f, -1, -1, 3, 0, Qscroll_bar_height); @@ -4661,11 +4668,11 @@ x_set_alpha (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (! (0 <= alpha && alpha <= 1.0)) args_out_of_range (make_float (0.0), make_float (1.0)); } - else if (INTEGERP (item)) + else if (FIXNUMP (item)) { - EMACS_INT ialpha = XINT (item); + EMACS_INT ialpha = XFIXNUM (item); if (! (0 <= ialpha && ialpha <= 100)) - args_out_of_range (make_number (0), make_number (100)); + args_out_of_range (make_fixnum (0), make_fixnum (100)); alpha = ialpha / 100.0; } else @@ -4833,6 +4840,8 @@ xrdb_get_resource (XrmDatabase rdb, Lisp_Object attribute, Lisp_Object class, Li USE_SAFE_ALLOCA; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; + name_key = ptr_bounds_clip (name_key, name_keysize); + class_key = ptr_bounds_clip (class_key, class_keysize); /* Start with emacs.FRAMENAME for the name (the specific one) and with `Emacs' for the class key (the general one). */ @@ -4911,6 +4920,8 @@ x_get_resource_string (const char *attribute, const char *class) ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; + name_key = ptr_bounds_clip (name_key, name_keysize); + class_key = ptr_bounds_clip (class_key, class_keysize); esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute); sprintf (class_key, "%s.%s", EMACS_CLASS, class); @@ -4959,7 +4970,7 @@ x_get_arg (Display_Info *dpyinfo, Lisp_Object alist, Lisp_Object param, /* If it wasn't specified in ALIST or the Lisp-level defaults, look in the X resources. */ - if (EQ (tem, Qnil)) + if (NILP (tem)) { if (attribute && dpyinfo) { @@ -4973,13 +4984,13 @@ x_get_arg (Display_Info *dpyinfo, Lisp_Object alist, Lisp_Object param, switch (type) { case RES_TYPE_NUMBER: - return make_number (atoi (SSDATA (tem))); + return make_fixnum (atoi (SSDATA (tem))); case RES_TYPE_BOOLEAN_NUMBER: if (!strcmp (SSDATA (tem), "on") || !strcmp (SSDATA (tem), "true")) - return make_number (1); - return make_number (atoi (SSDATA (tem))); + return make_fixnum (1); + return make_fixnum (atoi (SSDATA (tem))); break; case RES_TYPE_FLOAT: @@ -5208,11 +5219,11 @@ On Nextstep, this just calls `ns-parse-geometry'. */) Lisp_Object element; if (x >= 0 && (geometry & XNegative)) - element = list3 (Qleft, Qminus, make_number (-x)); + element = list3 (Qleft, Qminus, make_fixnum (-x)); else if (x < 0 && ! (geometry & XNegative)) - element = list3 (Qleft, Qplus, make_number (x)); + element = list3 (Qleft, Qplus, make_fixnum (x)); else - element = Fcons (Qleft, make_number (x)); + element = Fcons (Qleft, make_fixnum (x)); result = Fcons (element, result); } @@ -5221,18 +5232,18 @@ On Nextstep, this just calls `ns-parse-geometry'. */) Lisp_Object element; if (y >= 0 && (geometry & YNegative)) - element = list3 (Qtop, Qminus, make_number (-y)); + element = list3 (Qtop, Qminus, make_fixnum (-y)); else if (y < 0 && ! (geometry & YNegative)) - element = list3 (Qtop, Qplus, make_number (y)); + element = list3 (Qtop, Qplus, make_fixnum (y)); else - element = Fcons (Qtop, make_number (y)); + element = Fcons (Qtop, make_fixnum (y)); result = Fcons (element, result); } if (geometry & WidthValue) - result = Fcons (Fcons (Qwidth, make_number (width)), result); + result = Fcons (Fcons (Qwidth, make_fixnum (width)), result); if (geometry & HeightValue) - result = Fcons (Fcons (Qheight, make_number (height)), result); + result = Fcons (Fcons (Qheight, make_fixnum (height)), result); return result; } @@ -5288,11 +5299,11 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x ? tool_bar_button_relief : DEFAULT_TOOL_BAR_BUTTON_RELIEF); - if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX)) - margin = XFASTINT (Vtool_bar_button_margin); + if (RANGED_FIXNUMP (1, Vtool_bar_button_margin, INT_MAX)) + margin = XFIXNAT (Vtool_bar_button_margin); else if (CONSP (Vtool_bar_button_margin) - && RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), INT_MAX)) - margin = XFASTINT (XCDR (Vtool_bar_button_margin)); + && RANGED_FIXNUMP (1, XCDR (Vtool_bar_button_margin), INT_MAX)) + margin = XFIXNAT (XCDR (Vtool_bar_button_margin)); else margin = 0; @@ -5313,13 +5324,13 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x { if (CONSP (width) && EQ (XCAR (width), Qtext_pixels)) { - CHECK_NUMBER (XCDR (width)); - if ((XINT (XCDR (width)) < 0 || XINT (XCDR (width)) > INT_MAX)) + CHECK_FIXNUM (XCDR (width)); + if ((XFIXNUM (XCDR (width)) < 0 || XFIXNUM (XCDR (width)) > INT_MAX)) xsignal1 (Qargs_out_of_range, XCDR (width)); - SET_FRAME_WIDTH (f, XINT (XCDR (width))); + SET_FRAME_WIDTH (f, XFIXNUM (XCDR (width))); f->inhibit_horizontal_resize = true; - *x_width = XINT (XCDR (width)); + *x_width = XFIXNUM (XCDR (width)); } else if (FLOATP (width)) { @@ -5338,11 +5349,11 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x } else { - CHECK_NUMBER (width); - if ((XINT (width) < 0 || XINT (width) > INT_MAX)) + CHECK_FIXNUM (width); + if ((XFIXNUM (width) < 0 || XFIXNUM (width) > INT_MAX)) xsignal1 (Qargs_out_of_range, width); - SET_FRAME_WIDTH (f, XINT (width) * FRAME_COLUMN_WIDTH (f)); + SET_FRAME_WIDTH (f, XFIXNUM (width) * FRAME_COLUMN_WIDTH (f)); } } @@ -5350,13 +5361,13 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x { if (CONSP (height) && EQ (XCAR (height), Qtext_pixels)) { - CHECK_NUMBER (XCDR (height)); - if ((XINT (XCDR (height)) < 0 || XINT (XCDR (height)) > INT_MAX)) + CHECK_FIXNUM (XCDR (height)); + if ((XFIXNUM (XCDR (height)) < 0 || XFIXNUM (XCDR (height)) > INT_MAX)) xsignal1 (Qargs_out_of_range, XCDR (height)); - SET_FRAME_HEIGHT (f, XINT (XCDR (height))); + SET_FRAME_HEIGHT (f, XFIXNUM (XCDR (height))); f->inhibit_vertical_resize = true; - *x_height = XINT (XCDR (height)); + *x_height = XFIXNUM (XCDR (height)); } else if (FLOATP (height)) { @@ -5375,11 +5386,11 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x } else { - CHECK_NUMBER (height); - if ((XINT (height) < 0) || (XINT (height) > INT_MAX)) + CHECK_FIXNUM (height); + if ((XFIXNUM (height) < 0) || (XFIXNUM (height) > INT_MAX)) xsignal1 (Qargs_out_of_range, height); - SET_FRAME_HEIGHT (f, XINT (height) * FRAME_LINE_HEIGHT (f)); + SET_FRAME_HEIGHT (f, XFIXNUM (height) * FRAME_LINE_HEIGHT (f)); } } @@ -5402,16 +5413,16 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x } else if (CONSP (top) && EQ (XCAR (top), Qminus) && CONSP (XCDR (top)) - && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (top)), INT_MAX)) + && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (top)), INT_MAX)) { - f->top_pos = - XINT (XCAR (XCDR (top))); + f->top_pos = - XFIXNUM (XCAR (XCDR (top))); window_prompting |= YNegative; } else if (CONSP (top) && EQ (XCAR (top), Qplus) && CONSP (XCDR (top)) - && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (top)))) + && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (top)))) { - f->top_pos = XINT (XCAR (XCDR (top))); + f->top_pos = XFIXNUM (XCAR (XCDR (top))); } else if (FLOATP (top)) f->top_pos = frame_float (f, top, FRAME_FLOAT_TOP, &parent_done, @@ -5421,7 +5432,7 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x else { CHECK_TYPE_RANGED_INTEGER (int, top); - f->top_pos = XINT (top); + f->top_pos = XFIXNUM (top); if (f->top_pos < 0) window_prompting |= YNegative; } @@ -5433,16 +5444,16 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x } else if (CONSP (left) && EQ (XCAR (left), Qminus) && CONSP (XCDR (left)) - && RANGED_INTEGERP (-INT_MAX, XCAR (XCDR (left)), INT_MAX)) + && RANGED_FIXNUMP (-INT_MAX, XCAR (XCDR (left)), INT_MAX)) { - f->left_pos = - XINT (XCAR (XCDR (left))); + f->left_pos = - XFIXNUM (XCAR (XCDR (left))); window_prompting |= XNegative; } else if (CONSP (left) && EQ (XCAR (left), Qplus) && CONSP (XCDR (left)) - && TYPE_RANGED_INTEGERP (int, XCAR (XCDR (left)))) + && TYPE_RANGED_FIXNUMP (int, XCAR (XCDR (left)))) { - f->left_pos = XINT (XCAR (XCDR (left))); + f->left_pos = XFIXNUM (XCAR (XCDR (left))); } else if (FLOATP (left)) f->left_pos = frame_float (f, left, FRAME_FLOAT_LEFT, &parent_done, @@ -5452,7 +5463,7 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x else { CHECK_TYPE_RANGED_INTEGER (int, left); - f->left_pos = XINT (left); + f->left_pos = XFIXNUM (left); if (f->left_pos < 0) window_prompting |= XNegative; } @@ -5777,7 +5788,7 @@ syms_of_frame (void) Lisp_Object v = (frame_parms[i].sym < 0 ? intern_c_string (frame_parms[i].name) : builtin_lisp_symbol (frame_parms[i].sym)); - Fput (v, Qx_frame_parameter, make_number (i)); + Fput (v, Qx_frame_parameter, make_fixnum (i)); } } @@ -5810,7 +5821,7 @@ is a reasonable practice. See also the variable `x-resource-name'. */); doc: /* The lower limit of the frame opacity (alpha transparency). The value should range from 0 (invisible) to 100 (completely opaque). You can also use a floating number between 0.0 and 1.0. */); - Vframe_alpha_lower_limit = make_number (20); + Vframe_alpha_lower_limit = make_fixnum (20); #endif DEFVAR_LISP ("default-frame-alist", Vdefault_frame_alist, @@ -5876,15 +5887,6 @@ when the mouse is over clickable text. */); The pointer becomes visible again when the mouse is moved. */); Vmake_pointer_invisible = Qt; - DEFVAR_LISP ("focus-in-hook", Vfocus_in_hook, - doc: /* Normal hook run when a frame gains input focus. -The frame gaining focus is selected at the time this hook is run. */); - Vfocus_in_hook = Qnil; - - DEFVAR_LISP ("focus-out-hook", Vfocus_out_hook, - doc: /* Normal hook run when all frames lost input focus. */); - Vfocus_out_hook = Qnil; - DEFVAR_LISP ("move-frame-functions", Vmove_frame_functions, doc: /* Functions run after a frame was moved. The functions are run with one arg, the frame that moved. */); @@ -5902,6 +5904,14 @@ recursively). */); Vdelete_frame_functions = Qnil; DEFSYM (Qdelete_frame_functions, "delete-frame-functions"); + DEFVAR_LISP ("after-delete-frame-functions", + Vafter_delete_frame_functions, + doc: /* Functions run after deleting a frame. +The functions are run with one arg, the frame that was deleted and +which is now dead. */); + Vafter_delete_frame_functions = Qnil; + DEFSYM (Qafter_delete_frame_functions, "after-delete-frame-functions"); + DEFVAR_LISP ("menu-bar-mode", Vmenu_bar_mode, doc: /* Non-nil if Menu-Bar mode is enabled. See the command `menu-bar-mode' for a description of this minor mode. diff --git a/src/frame.h b/src/frame.h index c069d18dde8..b7059027fbe 100644 --- a/src/frame.h +++ b/src/frame.h @@ -342,6 +342,9 @@ struct frame ENUM_BF (output_method) output_method : 3; #ifdef HAVE_WINDOW_SYSTEM + /* True if this frame is a tooltip frame. */ + bool_bf tooltip : 1; + /* See FULLSCREEN_ enum on top. */ ENUM_BF (fullscreen_type) want_fullscreen : 4; @@ -351,9 +354,7 @@ struct frame /* Nonzero if we should actually display horizontal scroll bars on this frame. */ bool_bf horizontal_scroll_bars : 1; -#endif /* HAVE_WINDOW_SYSTEM */ -#if defined (HAVE_WINDOW_SYSTEM) /* True if this is an undecorated frame. */ bool_bf undecorated : 1; @@ -577,7 +578,7 @@ struct frame enum ns_appearance_type ns_appearance; bool_bf ns_transparent_titlebar; #endif -}; +} GCALIGNED_STRUCT; /* Most code should use these functions to set Lisp fields in struct frame. */ @@ -725,7 +726,7 @@ default_pixels_per_inch_y (void) #define FRAME_IMAGE_CACHE(F) ((F)->terminal->image_cache) #define XFRAME(p) \ - (eassert (FRAMEP (p)), (struct frame *) XUNTAG (p, Lisp_Vectorlike)) + (eassert (FRAMEP (p)), XUNTAG (p, Lisp_Vectorlike, struct frame)) #define XSETFRAME(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FRAME)) /* Given a window, return its frame as a Lisp_Object. */ @@ -967,6 +968,7 @@ default_pixels_per_inch_y (void) #define FRAME_Z_GROUP_ABOVE_SUSPENDED(f) \ ((f)->z_group == z_group_above_suspended) #define FRAME_Z_GROUP_BELOW(f) ((f)->z_group == z_group_below) +#define FRAME_TOOLTIP_P(f) ((f)->tooltip) #ifdef NS_IMPL_COCOA #define FRAME_NS_APPEARANCE(f) ((f)->ns_appearance) #define FRAME_NS_TRANSPARENT_TITLEBAR(f) ((f)->ns_transparent_titlebar) @@ -983,6 +985,7 @@ default_pixels_per_inch_y (void) #define FRAME_Z_GROUP_NONE(f) ((void) (f), true) #define FRAME_Z_GROUP_ABOVE(f) ((void) (f), false) #define FRAME_Z_GROUP_BELOW(f) ((void) (f), false) +#define FRAME_TOOLTIP_P(f) ((void) f, false) #endif /* HAVE_WINDOW_SYSTEM */ /* Whether horizontal scroll bars are currently enabled for frame F. */ @@ -1357,17 +1360,13 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f) canonical char width is to be used. X must be a Lisp integer or float. Value is a C integer. */ #define FRAME_PIXEL_X_FROM_CANON_X(F, X) \ - (INTEGERP (X) \ - ? XINT (X) * FRAME_COLUMN_WIDTH (F) \ - : (int) (XFLOAT_DATA (X) * FRAME_COLUMN_WIDTH (F))) + ((int) (XFLOATINT (X) * FRAME_COLUMN_WIDTH (F))) /* Convert canonical value Y to pixels. F is the frame whose canonical character height is to be used. X must be a Lisp integer or float. Value is a C integer. */ #define FRAME_PIXEL_Y_FROM_CANON_Y(F, Y) \ - (INTEGERP (Y) \ - ? XINT (Y) * FRAME_LINE_HEIGHT (F) \ - : (int) (XFLOAT_DATA (Y) * FRAME_LINE_HEIGHT (F))) + ((int) (XFLOATINT (Y) * FRAME_LINE_HEIGHT (F))) /* Convert pixel-value X to canonical units. F is the frame whose canonical character width is to be used. X is a C integer. Result @@ -1376,7 +1375,7 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f) #define FRAME_CANON_X_FROM_PIXEL_X(F, X) \ ((X) % FRAME_COLUMN_WIDTH (F) != 0 \ ? make_float ((double) (X) / FRAME_COLUMN_WIDTH (F)) \ - : make_number ((X) / FRAME_COLUMN_WIDTH (F))) + : make_fixnum ((X) / FRAME_COLUMN_WIDTH (F))) /* Convert pixel-value Y to canonical units. F is the frame whose canonical character height is to be used. Y is a C integer. @@ -1385,7 +1384,7 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f) #define FRAME_CANON_Y_FROM_PIXEL_Y(F, Y) \ ((Y) % FRAME_LINE_HEIGHT (F) \ ? make_float ((double) (Y) / FRAME_LINE_HEIGHT (F)) \ - : make_number ((Y) / FRAME_LINE_HEIGHT (F))) + : make_fixnum ((Y) / FRAME_LINE_HEIGHT (F))) diff --git a/src/fringe.c b/src/fringe.c index 4151386ceb8..a7e8dad482e 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "frame.h" +#include "ptr-bounds.h" #include "window.h" #include "dispextern.h" #include "buffer.h" @@ -487,10 +488,10 @@ lookup_fringe_bitmap (Lisp_Object bitmap) EMACS_INT bn; bitmap = Fget (bitmap, Qfringe); - if (!INTEGERP (bitmap)) + if (!FIXNUMP (bitmap)) return 0; - bn = XINT (bitmap); + bn = XFIXNUM (bitmap); if (bn > NO_FRINGE_BITMAP && bn < max_used_fringe_bitmap && (bn < MAX_STANDARD_FRINGE_BITMAPS @@ -518,7 +519,7 @@ get_fringe_bitmap_name (int bn) return Qnil; bitmaps = Vfringe_bitmaps; - num = make_number (bn); + num = make_fixnum (bn); while (CONSP (bitmaps)) { @@ -586,8 +587,8 @@ draw_fringe_bitmap_1 (struct window *w, struct glyph_row *row, int left_p, int o if (face_id == DEFAULT_FACE_ID) { Lisp_Object face = fringe_faces[which]; - face_id = NILP (face) ? lookup_named_face (f, Qfringe, false) - : lookup_derived_face (f, face, FRINGE_FACE_ID, 0); + face_id = NILP (face) ? lookup_named_face (w, f, Qfringe, false) + : lookup_derived_face (w, f, face, FRINGE_FACE_ID, 0); if (face_id < 0) face_id = FRINGE_FACE_ID; } @@ -742,12 +743,12 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in return NO_FRINGE_BITMAP; if (CONSP (bm1)) { - ln1 = XINT (Flength (bm1)); + ln1 = XFIXNUM (Flength (bm1)); if (partial_p) { if (ln1 > ix2) { - bm = Fnth (make_number (ix2), bm1); + bm = Fnth (make_fixnum (ix2), bm1); if (!EQ (bm, Qt)) goto found; } @@ -756,7 +757,7 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in { if (ln1 > ix1) { - bm = Fnth (make_number (ix1), bm1); + bm = Fnth (make_fixnum (ix1), bm1); if (!EQ (bm, Qt)) goto found; } @@ -777,12 +778,12 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in { if (CONSP (bm2)) { - ln2 = XINT (Flength (bm2)); + ln2 = XFIXNUM (Flength (bm2)); if (partial_p) { if (ln2 > ix2) { - bm = Fnth (make_number (ix2), bm2); + bm = Fnth (make_fixnum (ix2), bm2); if (!EQ (bm, Qt)) goto found; } @@ -794,14 +795,14 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in if (ln1 > ix1) { - bm = Fnth (make_number (ix1), bm1); + bm = Fnth (make_fixnum (ix1), bm1); if (!EQ (bm, Qt)) goto found; } if (ln2 > ix1) { - bm = Fnth (make_number (ix1), bm2); + bm = Fnth (make_fixnum (ix1), bm2); if (!EQ (bm, Qt)) goto found; return NO_FRINGE_BITMAP; @@ -908,6 +909,12 @@ draw_window_fringes (struct window *w, bool no_fringe_p) if (w->pseudo_window_p) return updated_p; + /* We must switch to the window's buffer to use its local value of + the fringe face, in case it's been remapped in face-remapping-alist. */ + Lisp_Object window_buffer = w->contents; + struct buffer *oldbuf = current_buffer; + set_buffer_internal_1 (XBUFFER (window_buffer)); + /* Must draw line if no fringe */ if (no_fringe_p && (WINDOW_LEFT_FRINGE_WIDTH (w) == 0 @@ -925,6 +932,8 @@ draw_window_fringes (struct window *w, bool no_fringe_p) updated_p = 1; } + set_buffer_internal_1 (oldbuf); + return updated_p; } @@ -1508,8 +1517,8 @@ If BITMAP already exists, the existing definition is replaced. */) fb.height = h; else { - CHECK_NUMBER (height); - fb.height = max (0, min (XINT (height), 255)); + CHECK_FIXNUM (height); + fb.height = max (0, min (XFIXNUM (height), 255)); if (fb.height > h) { fill1 = (fb.height - h) / 2; @@ -1521,8 +1530,8 @@ If BITMAP already exists, the existing definition is replaced. */) fb.width = 8; else { - CHECK_NUMBER (width); - fb.width = max (0, min (XINT (width), 255)); + CHECK_FIXNUM (width); + fb.width = max (0, min (XFIXNUM (width), 255)); } fb.period = 0; @@ -1585,13 +1594,15 @@ If BITMAP already exists, the existing definition is replaced. */) } Vfringe_bitmaps = Fcons (bitmap, Vfringe_bitmaps); - Fput (bitmap, Qfringe, make_number (n)); + Fput (bitmap, Qfringe, make_fixnum (n)); } fb.dynamic = true; xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW); - fb.bits = b = (unsigned short *) (xfb + 1); + fb.bits = b = ((unsigned short *) + ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW)); + xfb = ptr_bounds_clip (xfb, sizeof *xfb); memset (b, 0, fb.height); j = 0; @@ -1601,8 +1612,8 @@ If BITMAP already exists, the existing definition is replaced. */) b[j++] = 0; for (i = 0; i < h && j < fb.height; i++) { - Lisp_Object elt = Faref (bits, make_number (i)); - b[j++] = NUMBERP (elt) ? XINT (elt) : 0; + Lisp_Object elt = Faref (bits, make_fixnum (i)); + b[j++] = FIXNUMP (elt) ? XFIXNUM (elt) : 0; } for (i = 0; i < fill2 && j < fb.height; i++) b[j++] = 0; @@ -1630,20 +1641,10 @@ If FACE is nil, reset face to default fringe face. */) if (!n) error ("Undefined fringe bitmap"); - /* The purpose of the following code is to signal an error if FACE - is not a face. This is for the caller's convenience only; the - redisplay code should be able to fail gracefully. Skip the check - if FRINGE_FACE_ID is unrealized (as in batch mode and during - daemon startup). */ - if (!NILP (face)) - { - struct frame *f = SELECTED_FRAME (); - - if (FACE_FROM_ID_OR_NULL (f, FRINGE_FACE_ID) - && lookup_derived_face (f, face, FRINGE_FACE_ID, 1) < 0) - error ("No such face"); - } - + /* We used to check, as a convenience to callers, for basic face + validity here, but since validity can depend on the specific + _window_ in which this buffer is being displayed, defer the check + to redisplay, which can cope with bad face specifications. */ fringe_faces[n] = face; return Qnil; } @@ -1668,10 +1669,10 @@ Return nil if POS is not visible in WINDOW. */) if (!NILP (pos)) { - CHECK_NUMBER_COERCE_MARKER (pos); - if (! (BEGV <= XINT (pos) && XINT (pos) <= ZV)) + CHECK_FIXNUM_COERCE_MARKER (pos); + if (! (BEGV <= XFIXNUM (pos) && XFIXNUM (pos) <= ZV)) args_out_of_range (window, pos); - textpos = XINT (pos); + textpos = XFIXNUM (pos); } else if (w == XWINDOW (selected_window)) textpos = PT; diff --git a/src/ftcrfont.c b/src/ftcrfont.c index 0e3490c570e..314fa5b400d 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -138,7 +138,7 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size) FT_UInt size; block_input (); - size = XINT (AREF (entity, FONT_SIZE_INDEX)); + size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); if (size == 0) size = pixel_size; font_object = font_build_object (VECSIZE (struct ftcrfont_info), @@ -165,6 +165,9 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size) static void ftcrfont_close (struct font *font) { + if (font_data_structures_may_be_ill_formed ()) + return; + struct ftcrfont_info *ftcrfont_info = (struct ftcrfont_info *) font; int i; diff --git a/src/ftfont.c b/src/ftfont.c index 4382fd02211..6899a5763a8 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -197,7 +197,7 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra) return Qnil; file = (char *) str; - key = Fcons (build_unibyte_string (file), make_number (idx)); + key = Fcons (build_unibyte_string (file), make_fixnum (idx)); cache = ftfont_lookup_cache (key, FTFONT_CACHE_FOR_ENTITY); entity = XCAR (cache); if (! NILP (entity)) @@ -233,35 +233,35 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra) { if (numeric >= FC_WEIGHT_REGULAR && numeric < FC_WEIGHT_MEDIUM) numeric = FC_WEIGHT_MEDIUM; - FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, make_number (numeric)); + FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, make_fixnum (numeric)); } if (FcPatternGetInteger (p, FC_SLANT, 0, &numeric) == FcResultMatch) { numeric += 100; - FONT_SET_STYLE (entity, FONT_SLANT_INDEX, make_number (numeric)); + FONT_SET_STYLE (entity, FONT_SLANT_INDEX, make_fixnum (numeric)); } if (FcPatternGetInteger (p, FC_WIDTH, 0, &numeric) == FcResultMatch) { - FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_number (numeric)); + FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_fixnum (numeric)); } if (FcPatternGetDouble (p, FC_PIXEL_SIZE, 0, &dbl) == FcResultMatch) { - ASET (entity, FONT_SIZE_INDEX, make_number (dbl)); + ASET (entity, FONT_SIZE_INDEX, make_fixnum (dbl)); } else - ASET (entity, FONT_SIZE_INDEX, make_number (0)); + ASET (entity, FONT_SIZE_INDEX, make_fixnum (0)); if (FcPatternGetInteger (p, FC_SPACING, 0, &numeric) == FcResultMatch) - ASET (entity, FONT_SPACING_INDEX, make_number (numeric)); + ASET (entity, FONT_SPACING_INDEX, make_fixnum (numeric)); if (FcPatternGetDouble (p, FC_DPI, 0, &dbl) == FcResultMatch) { int dpi = dbl; - ASET (entity, FONT_DPI_INDEX, make_number (dpi)); + ASET (entity, FONT_DPI_INDEX, make_fixnum (dpi)); } if (FcPatternGetBool (p, FC_SCALABLE, 0, &b) == FcResultMatch && b == FcTrue) { - ASET (entity, FONT_SIZE_INDEX, make_number (0)); - ASET (entity, FONT_AVGWIDTH_INDEX, make_number (0)); + ASET (entity, FONT_SIZE_INDEX, make_fixnum (0)); + ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (0)); } else { @@ -277,7 +277,7 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra) if (FT_Get_BDF_Property (ft_face, "AVERAGE_WIDTH", &rec) == 0 && rec.type == BDF_PROPERTY_TYPE_INTEGER) - ASET (entity, FONT_AVGWIDTH_INDEX, make_number (rec.u.integer)); + ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (rec.u.integer)); FT_Done_Face (ft_face); } } @@ -346,6 +346,7 @@ struct ftfont_cache_data { FT_Face ft_face; FcCharSet *fc_charset; + intptr_t face_refcount; }; static Lisp_Object @@ -372,17 +373,15 @@ ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for) { if (NILP (ft_face_cache)) ft_face_cache = CALLN (Fmake_hash_table, QCtest, Qequal); - cache_data = xmalloc (sizeof *cache_data); - cache_data->ft_face = NULL; - cache_data->fc_charset = NULL; - val = make_save_ptr_int (cache_data, 0); + cache_data = xzalloc (sizeof *cache_data); + val = make_mint_ptr (cache_data); cache = Fcons (Qnil, val); Fputhash (key, cache, ft_face_cache); } else { val = XCDR (cache); - cache_data = XSAVE_POINTER (val, 0); + cache_data = xmint_pointer (val); } if (cache_for == FTFONT_CACHE_FOR_ENTITY) @@ -392,7 +391,7 @@ ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for) ? ! cache_data->ft_face : ! cache_data->fc_charset) { char *filename = SSDATA (XCAR (key)); - int idx = XINT (XCDR (key)); + int idx = XFIXNUM (XCDR (key)); if (cache_for == FTFONT_CACHE_FOR_FACE) { @@ -448,7 +447,7 @@ ftfont_get_fc_charset (Lisp_Object entity) cache = ftfont_lookup_cache (entity, FTFONT_CACHE_FOR_CHARSET); val = XCDR (cache); - cache_data = XSAVE_POINTER (val, 0); + cache_data = xmint_pointer (val); return cache_data->fc_charset; } @@ -602,9 +601,9 @@ ftfont_get_open_type_spec (Lisp_Object otf_spec) continue; len = Flength (val); spec->features[i] = - (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XINT (len) + (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XFIXNUM (len) ? 0 - : malloc (XINT (len) * sizeof *spec->features[i])); + : malloc (XFIXNUM (len) * sizeof *spec->features[i])); if (! spec->features[i]) { if (i > 0 && spec->features[0]) @@ -648,10 +647,10 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots /* Fontconfig doesn't support reverse-italic/oblique. */ return NULL; - if (INTEGERP (AREF (spec, FONT_DPI_INDEX))) - dpi = XINT (AREF (spec, FONT_DPI_INDEX)); - if (INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX)) - && XINT (AREF (spec, FONT_AVGWIDTH_INDEX)) == 0) + if (FIXNUMP (AREF (spec, FONT_DPI_INDEX))) + dpi = XFIXNUM (AREF (spec, FONT_DPI_INDEX)); + if (FIXNUMP (AREF (spec, FONT_AVGWIDTH_INDEX)) + && XFIXNUM (AREF (spec, FONT_AVGWIDTH_INDEX)) == 0) scalable = 1; registry = AREF (spec, FONT_REGISTRY_INDEX); @@ -688,8 +687,8 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots key = XCAR (XCAR (extra)), val = XCDR (XCAR (extra)); if (EQ (key, QCdpi)) { - if (INTEGERP (val)) - dpi = XINT (val); + if (FIXNUMP (val)) + dpi = XFIXNUM (val); } else if (EQ (key, QClang)) { @@ -737,7 +736,7 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots goto err; for (chars = XCDR (chars); CONSP (chars); chars = XCDR (chars)) if (CHARACTERP (XCAR (chars)) - && ! FcCharSetAddChar (charset, XFASTINT (XCAR (chars)))) + && ! FcCharSetAddChar (charset, XFIXNAT (XCAR (chars)))) goto err; } } @@ -834,8 +833,8 @@ ftfont_list (struct frame *f, Lisp_Object spec) } val = Qnil; } - if (INTEGERP (AREF (spec, FONT_SPACING_INDEX))) - spacing = XINT (AREF (spec, FONT_SPACING_INDEX)); + if (FIXNUMP (AREF (spec, FONT_SPACING_INDEX))) + spacing = XFIXNUM (AREF (spec, FONT_SPACING_INDEX)); family = AREF (spec, FONT_FAMILY_INDEX); if (! NILP (family)) { @@ -957,8 +956,8 @@ ftfont_list (struct frame *f, Lisp_Object spec) != FcResultMatch) continue; for (j = 0; j < ASIZE (chars); j++) - if (TYPE_RANGED_INTEGERP (FcChar32, AREF (chars, j)) - && FcCharSetHasChar (charset, XFASTINT (AREF (chars, j)))) + if (TYPE_RANGED_FIXNUMP (FcChar32, AREF (chars, j)) + && FcCharSetHasChar (charset, XFIXNAT (AREF (chars, j)))) break; if (j == ASIZE (chars)) continue; @@ -1018,12 +1017,12 @@ ftfont_match (struct frame *f, Lisp_Object spec) if (! pattern) return Qnil; - if (INTEGERP (AREF (spec, FONT_SIZE_INDEX))) + if (FIXNUMP (AREF (spec, FONT_SIZE_INDEX))) { FcValue value; value.type = FcTypeDouble; - value.u.d = XINT (AREF (spec, FONT_SIZE_INDEX)); + value.u.d = XFIXNUM (AREF (spec, FONT_SIZE_INDEX)); FcPatternAdd (pattern, FC_PIXEL_SIZE, value, FcFalse); } if (FcConfigSubstitute (NULL, pattern, FcMatchPattern) == FcTrue) @@ -1119,9 +1118,9 @@ ftfont_open2 (struct frame *f, filename = XCAR (val); idx = XCDR (val); val = XCDR (cache); - cache_data = XSAVE_POINTER (XCDR (cache), 0); + cache_data = xmint_pointer (XCDR (cache)); ft_face = cache_data->ft_face; - if (XSAVE_INTEGER (val, 1) > 0) + if (cache_data->face_refcount > 0) { /* FT_Face in this cache is already used by the different size. */ if (FT_New_Size (ft_face, &ft_size) != 0) @@ -1132,22 +1131,25 @@ ftfont_open2 (struct frame *f, return Qnil; } } - set_save_integer (val, 1, XSAVE_INTEGER (val, 1) + 1); - size = XINT (AREF (entity, FONT_SIZE_INDEX)); + size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); if (size == 0) size = pixel_size; if (FT_Set_Pixel_Sizes (ft_face, size, size) != 0) { - if (XSAVE_INTEGER (val, 1) == 0) - FT_Done_Face (ft_face); + if (cache_data->face_refcount == 0) + { + FT_Done_Face (ft_face); + cache_data->ft_face = NULL; + } return Qnil; } + cache_data->face_refcount++; ASET (font_object, FONT_FILE_INDEX, filename); font = XFONT_OBJECT (font_object); ftfont_info = (struct ftfont_info *) font; ftfont_info->ft_size = ft_face->size; - ftfont_info->index = XINT (idx); + ftfont_info->index = XFIXNUM (idx); #ifdef HAVE_LIBOTF ftfont_info->maybe_otf = (ft_face->face_flags & FT_FACE_FLAG_SFNT) != 0; ftfont_info->otf = NULL; @@ -1159,8 +1161,8 @@ ftfont_open2 (struct frame *f, font->encoding_charset = font->repertory_charset = -1; upEM = ft_face->units_per_EM; - scalable = (INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX)) - && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0); + scalable = (FIXNUMP (AREF (entity, FONT_AVGWIDTH_INDEX)) + && XFIXNUM (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0); if (scalable) { font->ascent = ft_face->ascender * size / upEM + 0.5; @@ -1173,8 +1175,8 @@ ftfont_open2 (struct frame *f, font->descent = - ft_face->size->metrics.descender >> 6; font->height = ft_face->size->metrics.height >> 6; } - if (INTEGERP (AREF (entity, FONT_SPACING_INDEX))) - spacing = XINT (AREF (entity, FONT_SPACING_INDEX)); + if (FIXNUMP (AREF (entity, FONT_SPACING_INDEX))) + spacing = XFIXNUM (AREF (entity, FONT_SPACING_INDEX)); else spacing = FC_PROPORTIONAL; if (spacing != FC_PROPORTIONAL @@ -1232,7 +1234,7 @@ ftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) { Lisp_Object font_object; FT_UInt size; - size = XINT (AREF (entity, FONT_SIZE_INDEX)); + size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); if (size == 0) size = pixel_size; font_object = font_build_object (VECSIZE (struct ftfont_info), @@ -1243,22 +1245,20 @@ ftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) void ftfont_close (struct font *font) { - /* FIXME: Although this function can be called while garbage-collecting, - the function assumes that Lisp data structures are properly-formed. - This invalid assumption can lead to core dumps (Bug#20890). */ + if (font_data_structures_may_be_ill_formed ()) + return; struct ftfont_info *ftfont_info = (struct ftfont_info *) font; Lisp_Object val, cache; - val = Fcons (font->props[FONT_FILE_INDEX], make_number (ftfont_info->index)); + val = Fcons (font->props[FONT_FILE_INDEX], make_fixnum (ftfont_info->index)); cache = ftfont_lookup_cache (val, FTFONT_CACHE_FOR_FACE); eassert (CONSP (cache)); val = XCDR (cache); - set_save_integer (val, 1, XSAVE_INTEGER (val, 1) - 1); - if (XSAVE_INTEGER (val, 1) == 0) + struct ftfont_cache_data *cache_data = xmint_pointer (val); + cache_data->face_refcount--; + if (cache_data->face_refcount == 0) { - struct ftfont_cache_data *cache_data = XSAVE_POINTER (val, 0); - FT_Done_Face (cache_data->ft_face); #ifdef HAVE_LIBOTF if (ftfont_info->otf) @@ -2535,7 +2535,7 @@ ftfont_shape_by_flt (Lisp_Object lgstring, struct font *font, flt = mflt_find (LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, 0)), &flt_font_ft.flt_font); if (! flt) - return make_number (0); + return make_fixnum (0); } MFLTGlyphFT *glyphs = (MFLTGlyphFT *) gstring.glyphs; @@ -2604,13 +2604,13 @@ ftfont_shape_by_flt (Lisp_Object lgstring, struct font *font, { Lisp_Object vec = make_uninit_vector (3); - ASET (vec, 0, make_number (g->g.xoff >> 6)); - ASET (vec, 1, make_number (g->g.yoff >> 6)); - ASET (vec, 2, make_number (g->g.xadv >> 6)); + ASET (vec, 0, make_fixnum (g->g.xoff >> 6)); + ASET (vec, 1, make_fixnum (g->g.yoff >> 6)); + ASET (vec, 2, make_fixnum (g->g.xadv >> 6)); LGLYPH_SET_ADJUSTMENT (lglyph, vec); } } - return make_number (i); + return make_fixnum (i); } Lisp_Object diff --git a/src/gfilenotify.c b/src/gfilenotify.c index 1e0f4160816..14fcf7f4776 100644 --- a/src/gfilenotify.c +++ b/src/gfilenotify.c @@ -77,7 +77,6 @@ dir_monitor_callback (GFileMonitor *monitor, /* Determine callback function. */ monitor_object = make_pointer_integer (monitor); - eassert (INTEGERP (monitor_object)); watch_object = assq_no_quit (monitor_object, watch_list); if (CONSP (watch_object)) @@ -203,10 +202,10 @@ will be reported only in case of the `moved' event. */) if (! monitor) xsignal2 (Qfile_notify_error, build_string ("Cannot watch file"), file); - Lisp_Object watch_descriptor = make_pointer_integer (monitor); + Lisp_Object watch_descriptor = make_pointer_integer_unsafe (monitor); - /* Check the dicey assumption that make_pointer_integer is safe. */ - if (! INTEGERP (watch_descriptor)) + if (! (FIXNUMP (watch_descriptor) + && XFIXNUMPTR (watch_descriptor) == monitor)) { g_object_unref (monitor); xsignal2 (Qfile_notify_error, build_string ("Unsupported file watcher"), @@ -239,8 +238,8 @@ WATCH-DESCRIPTOR should be an object returned by `gfile-add-watch'. */) xsignal2 (Qfile_notify_error, build_string ("Not a watch descriptor"), watch_descriptor); - eassert (INTEGERP (watch_descriptor)); - GFileMonitor *monitor = XINTPTR (watch_descriptor); + eassert (FIXNUMP (watch_descriptor)); + GFileMonitor *monitor = XFIXNUMPTR (watch_descriptor); if (!g_file_monitor_is_cancelled (monitor) && !g_file_monitor_cancel (monitor)) xsignal2 (Qfile_notify_error, build_string ("Could not rm watch"), @@ -271,7 +270,7 @@ invalid. */) return Qnil; else { - GFileMonitor *monitor = XINTPTR (watch_descriptor); + GFileMonitor *monitor = XFIXNUMPTR (watch_descriptor); return g_file_monitor_is_cancelled (monitor) ? Qnil : Qt; } } @@ -290,7 +289,7 @@ If WATCH-DESCRIPTOR is not valid, nil is returned. */) return Qnil; else { - GFileMonitor *monitor = XINTPTR (watch_descriptor); + GFileMonitor *monitor = XFIXNUMPTR (watch_descriptor); return intern (G_OBJECT_TYPE_NAME (monitor)); } } diff --git a/src/gmalloc.c b/src/gmalloc.c index f3b3d77aac9..c19885d9f80 100644 --- a/src/gmalloc.c +++ b/src/gmalloc.c @@ -36,9 +36,9 @@ License along with this library. If not, see <https://www.gnu.org/licenses/>. #include <pthread.h> #endif -#ifdef emacs -# include "lisp.h" -#endif +#include "lisp.h" + +#include "ptr-bounds.h" #ifdef HAVE_MALLOC_H # if GNUC_PREREQ (4, 2, 0) @@ -201,7 +201,8 @@ extern size_t _bytes_free; /* Internal versions of `malloc', `realloc', and `free' used when these functions need to call each other. - They are the same but don't call the hooks. */ + They are the same but don't call the hooks + and don't bound the resulting pointers. */ extern void *_malloc_internal (size_t); extern void *_realloc_internal (void *, size_t); extern void _free_internal (void *); @@ -558,7 +559,7 @@ malloc_initialize_1 (void) _heapinfo[0].free.size = 0; _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; _heapindex = 0; - _heapbase = (char *) _heapinfo; + _heapbase = (char *) ptr_bounds_init (_heapinfo); _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); register_heapinfo (); @@ -919,7 +920,8 @@ malloc (size_t size) among multiple threads. We just leave it for compatibility with glibc malloc (i.e., assignments to gmalloc_hook) for now. */ hook = gmalloc_hook; - return (hook != NULL ? *hook : _malloc_internal) (size); + void *result = (hook ? hook : _malloc_internal) (size); + return ptr_bounds_clip (result, size); } #if !(defined (_LIBC) || defined (HYBRID_MALLOC)) @@ -997,6 +999,7 @@ _free_internal_nolock (void *ptr) if (ptr == NULL) return; + ptr = ptr_bounds_init (ptr); PROTECT_MALLOC_STATE (0); @@ -1308,6 +1311,7 @@ _realloc_internal_nolock (void *ptr, size_t size) else if (ptr == NULL) return _malloc_internal_nolock (size); + ptr = ptr_bounds_init (ptr); block = BLOCK (ptr); PROTECT_MALLOC_STATE (0); @@ -1430,7 +1434,8 @@ realloc (void *ptr, size_t size) return NULL; hook = grealloc_hook; - return (hook != NULL ? *hook : _realloc_internal) (ptr, size); + void *result = (hook ? hook : _realloc_internal) (ptr, size); + return ptr_bounds_clip (result, size); } /* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. @@ -1604,6 +1609,7 @@ aligned_alloc (size_t alignment, size_t size) { l->exact = result; result = l->aligned = (char *) result + adj; + result = ptr_bounds_clip (result, size); } UNLOCK_ALIGNED_BLOCKS (); if (l == NULL) @@ -2014,11 +2020,7 @@ mabort (enum mcheck_status status) #else fprintf (stderr, "mcheck: %s\n", msg); fflush (stderr); -# ifdef emacs emacs_abort (); -# else - abort (); -# endif #endif } diff --git a/src/gnutls.c b/src/gnutls.c index 3c16b6c9c31..1fe20d7ce2d 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -30,31 +30,17 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # define HAVE_GNUTLS_X509_SYSTEM_TRUST #endif -/* Although AEAD support started in GnuTLS 3.4.0 and works in 3.5.14, - it was broken through at least GnuTLS 3.4.10; see: - https://lists.gnu.org/r/emacs-devel/2017-07/msg00992.html - The relevant fix seems to have been made in GnuTLS 3.5.1; see: - https://gitlab.com/gnutls/gnutls/commit/568935848dd6b82b9315d8b6c529d00e2605e03d - So, require 3.5.1. */ -#if GNUTLS_VERSION_NUMBER >= 0x030501 -# define HAVE_GNUTLS_AEAD -#elif GNUTLS_VERSION_NUMBER < 0x030202 -/* gnutls_cipher_get_tag_size was introduced in 3.2.2, but it's only - relevant for AEAD ciphers. */ -# define gnutls_cipher_get_tag_size(cipher) 0 +#if GNUTLS_VERSION_NUMBER >= 0x030200 +# define HAVE_GNUTLS_CIPHER_GET_IV_SIZE #endif -#if GNUTLS_VERSION_NUMBER < 0x030200 -/* gnutls_cipher_get_iv_size was introduced in 3.2.0. For the ciphers - available in previous versions, block size is equivalent. */ -#define gnutls_cipher_get_iv_size(cipher) gnutls_cipher_get_block_size (cipher) +#if GNUTLS_VERSION_NUMBER >= 0x030202 +# define HAVE_GNUTLS_CIPHER_GET_TAG_SIZE +# define HAVE_GNUTLS_DIGEST_LIST /* also gnutls_digest_get_name */ #endif -#if GNUTLS_VERSION_NUMBER < 0x030202 -/* gnutls_digest_list and gnutls_digest_get_name were added in 3.2.2. - For previous versions, the mac algorithms are equivalent. */ -# define gnutls_digest_list() ((const gnutls_digest_algorithm_t *) gnutls_mac_list ()) -# define gnutls_digest_get_name(id) gnutls_mac_get_name ((gnutls_mac_algorithm_t) id) +#if GNUTLS_VERSION_NUMBER >= 0x030205 +# define HAVE_GNUTLS_EXT__DUMBFW #endif /* gnutls_mac_get_nonce_size was added in GnuTLS 3.2.0, but was @@ -67,14 +53,21 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # define HAVE_GNUTLS_EXT_GET_NAME #endif -#if GNUTLS_VERSION_NUMBER >= 0x030205 -# define HAVE_GNUTLS_EXT__DUMBFW +/* Although AEAD support started in GnuTLS 3.4.0 and works in 3.5.14, + it was broken through at least GnuTLS 3.4.10; see: + https://lists.gnu.org/r/emacs-devel/2017-07/msg00992.html + The relevant fix seems to have been made in GnuTLS 3.5.1; see: + https://gitlab.com/gnutls/gnutls/commit/568935848dd6b82b9315d8b6c529d00e2605e03d + So, require 3.5.1. */ +#if GNUTLS_VERSION_NUMBER >= 0x030501 +# define HAVE_GNUTLS_AEAD #endif #ifdef HAVE_GNUTLS # ifdef WINDOWSNT # include <windows.h> +# include "w32common.h" # include "w32.h" # endif @@ -222,19 +215,17 @@ DEF_DLL_FN (const gnutls_mac_algorithm_t *, gnutls_mac_list, (void)); DEF_DLL_FN (size_t, gnutls_mac_get_nonce_size, (gnutls_mac_algorithm_t)); # endif DEF_DLL_FN (size_t, gnutls_mac_get_key_size, (gnutls_mac_algorithm_t)); -# ifndef gnutls_digest_list +# ifdef HAVE_GNUTLS_DIGEST_LIST DEF_DLL_FN (const gnutls_digest_algorithm_t *, gnutls_digest_list, (void)); -# endif -# ifndef gnutls_digest_get_name DEF_DLL_FN (const char *, gnutls_digest_get_name, (gnutls_digest_algorithm_t)); # endif DEF_DLL_FN (gnutls_cipher_algorithm_t *, gnutls_cipher_list, (void)); -# ifndef gnutls_cipher_get_iv_size +# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE DEF_DLL_FN (int, gnutls_cipher_get_iv_size, (gnutls_cipher_algorithm_t)); # endif DEF_DLL_FN (size_t, gnutls_cipher_get_key_size, (gnutls_cipher_algorithm_t)); DEF_DLL_FN (int, gnutls_cipher_get_block_size, (gnutls_cipher_algorithm_t)); -# ifndef gnutls_cipher_get_tag_size +# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE DEF_DLL_FN (int, gnutls_cipher_get_tag_size, (gnutls_cipher_algorithm_t)); # endif DEF_DLL_FN (int, gnutls_cipher_init, @@ -364,19 +355,17 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_mac_get_nonce_size); # endif LOAD_DLL_FN (library, gnutls_mac_get_key_size); -# ifndef gnutls_digest_list +# ifdef HAVE_GNUTLS_DIGEST_LIST LOAD_DLL_FN (library, gnutls_digest_list); -# endif -# ifndef gnutls_digest_get_name LOAD_DLL_FN (library, gnutls_digest_get_name); # endif LOAD_DLL_FN (library, gnutls_cipher_list); -# ifndef gnutls_cipher_get_iv_size +# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE LOAD_DLL_FN (library, gnutls_cipher_get_iv_size); # endif LOAD_DLL_FN (library, gnutls_cipher_get_key_size); LOAD_DLL_FN (library, gnutls_cipher_get_block_size); -# ifndef gnutls_cipher_get_tag_size +# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE LOAD_DLL_FN (library, gnutls_cipher_get_tag_size); # endif LOAD_DLL_FN (library, gnutls_cipher_init); @@ -488,19 +477,17 @@ init_gnutls_functions (void) # define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size # endif # define gnutls_mac_get_key_size fn_gnutls_mac_get_key_size -# ifndef gnutls_digest_list +# ifdef HAVE_GNUTLS_DIGEST_LIST # define gnutls_digest_list fn_gnutls_digest_list -# endif -# ifndef gnutls_digest_get_name # define gnutls_digest_get_name fn_gnutls_digest_get_name # endif # define gnutls_cipher_list fn_gnutls_cipher_list -# ifndef gnutls_cipher_get_iv_size +# ifdef HAVE_GNUTLS_CIPHER_GET_IV_SIZE # define gnutls_cipher_get_iv_size fn_gnutls_cipher_get_iv_size # endif # define gnutls_cipher_get_key_size fn_gnutls_cipher_get_key_size # define gnutls_cipher_get_block_size fn_gnutls_cipher_get_block_size -# ifndef gnutls_cipher_get_tag_size +# ifdef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE # define gnutls_cipher_get_tag_size fn_gnutls_cipher_get_tag_size # endif # define gnutls_cipher_init fn_gnutls_cipher_init @@ -857,7 +844,20 @@ gnutls_make_error (int err) } check_memory_full (err); - return make_number (err); + return make_fixnum (err); +} + +static void +gnutls_deinit_certificates (struct Lisp_Process *p) +{ + if (! p->gnutls_certificates) + return; + + for (int i = 0; i < p->gnutls_certificates_length; i++) + gnutls_x509_crt_deinit (p->gnutls_certificates[i]); + + xfree (p->gnutls_certificates); + p->gnutls_certificates = NULL; } Lisp_Object @@ -894,6 +894,9 @@ emacs_gnutls_deinit (Lisp_Object proc) GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1; } + if (XPROCESS (proc)->gnutls_certificates) + gnutls_deinit_certificates (XPROCESS (proc)); + XPROCESS (proc)->gnutls_p = false; return Qt; } @@ -918,7 +921,7 @@ See also `gnutls-boot'. */) { CHECK_PROCESS (proc); - return make_number (GNUTLS_INITSTAGE (proc)); + return make_fixnum (GNUTLS_INITSTAGE (proc)); } DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0, @@ -958,10 +961,10 @@ Usage: (gnutls-error-fatalp ERROR) */) } } - if (! TYPE_RANGED_INTEGERP (int, err)) + if (! TYPE_RANGED_FIXNUMP (int, err)) error ("Not an error symbol or code"); - if (0 == gnutls_error_is_fatal (XINT (err))) + if (0 == gnutls_error_is_fatal (XFIXNUM (err))) return Qnil; return Qt; @@ -990,10 +993,10 @@ usage: (gnutls-error-string ERROR) */) } } - if (! TYPE_RANGED_INTEGERP (int, err)) + if (! TYPE_RANGED_FIXNUMP (int, err)) return build_string ("Not an error symbol or code"); - return build_string (emacs_gnutls_strerror (XINT (err))); + return build_string (emacs_gnutls_strerror (XFIXNUM (err))); } DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0, @@ -1037,7 +1040,7 @@ gnutls_certificate_details (gnutls_x509_crt_t cert) check_memory_full (version); if (version >= GNUTLS_E_SUCCESS) res = nconc2 (res, list2 (intern (":version"), - make_number (version))); + make_fixnum (version))); } /* Serial. */ @@ -1235,9 +1238,17 @@ DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_descri DEFUN ("gnutls-peer-status", Fgnutls_peer_status, Sgnutls_peer_status, 1, 1, 0, doc: /* Describe a GnuTLS PROC peer certificate and any warnings about it. + The return value is a property list with top-level keys :warnings and -:certificate. The :warnings entry is a list of symbols you can describe with -`gnutls-peer-status-warning-describe'. */) +:certificates. + +The :warnings entry is a list of symbols you can get a description of +with `gnutls-peer-status-warning-describe', and :certificates is the +certificate chain for the connection, with the host certificate +first, and intermediary certificates (if any) following it. + +In addition, for backwards compatibility, the host certificate is also +returned as the :certificate entry. */) (Lisp_Object proc) { Lisp_Object warnings = Qnil, result = Qnil; @@ -1279,9 +1290,9 @@ The return value is a property list with top-level keys :warnings and /* This could get called in the INIT stage, when the certificate is not yet set. */ - if (XPROCESS (proc)->gnutls_certificate != NULL && - gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificate, - XPROCESS (proc)->gnutls_certificate)) + if (XPROCESS (proc)->gnutls_certificates != NULL && + gnutls_x509_crt_check_issuer(XPROCESS (proc)->gnutls_certificates[0], + XPROCESS (proc)->gnutls_certificates[0])) warnings = Fcons (intern (":self-signed"), warnings); if (!NILP (warnings)) @@ -1289,10 +1300,21 @@ The return value is a property list with top-level keys :warnings and /* This could get called in the INIT stage, when the certificate is not yet set. */ - if (XPROCESS (proc)->gnutls_certificate != NULL) - result = nconc2 (result, list2 - (intern (":certificate"), - gnutls_certificate_details (XPROCESS (proc)->gnutls_certificate))); + if (XPROCESS (proc)->gnutls_certificates != NULL) + { + Lisp_Object certs = Qnil; + + /* Return all the certificates in a list. */ + for (int i = 0; i < XPROCESS (proc)->gnutls_certificates_length; i++) + certs = nconc2 (certs, list1 (gnutls_certificate_details + (XPROCESS (proc)->gnutls_certificates[i]))); + + result = nconc2 (result, list2 (intern (":certificates"), certs)); + + /* Return the host certificate in its own element for + compatibility reasons. */ + result = nconc2 (result, list2 (intern (":certificate"), Fcar (certs))); + } state = XPROCESS (proc)->gnutls_state; @@ -1302,7 +1324,7 @@ The return value is a property list with top-level keys :warnings and check_memory_full (bits); if (bits > 0) result = nconc2 (result, list2 (intern (":diffie-hellman-prime-bits"), - make_number (bits))); + make_fixnum (bits))); } /* Key exchange. */ @@ -1435,7 +1457,7 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) if (ret < GNUTLS_E_SUCCESS) return gnutls_make_error (ret); - XPROCESS (proc)->gnutls_peer_verification = peer_verification; + p->gnutls_peer_verification = peer_verification; warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings")); if (!NILP (warnings)) @@ -1472,49 +1494,60 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) 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; + const gnutls_datum_t *cert_list; + unsigned int cert_list_length; + int failed_import = 0; - ret = gnutls_x509_crt_init (&gnutls_verify_cert); - if (ret < GNUTLS_E_SUCCESS) - return gnutls_make_error (ret); + cert_list = gnutls_certificate_get_peers (state, &cert_list_length); - gnutls_verify_cert_list - = gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size); - - if (gnutls_verify_cert_list == NULL) + if (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); + /* Check only the first certificate in the given chain, but + store them all. */ + p->gnutls_certificates = + xmalloc (cert_list_length * sizeof (gnutls_x509_crt_t)); + p->gnutls_certificates_length = cert_list_length; - if (ret < GNUTLS_E_SUCCESS) + for (int i = cert_list_length - 1; i >= 0; i--) { - gnutls_x509_crt_deinit (gnutls_verify_cert); - return gnutls_make_error (ret); + gnutls_x509_crt_t cert; + + gnutls_x509_crt_init (&cert); + + if (ret < GNUTLS_E_SUCCESS) + failed_import = ret; + else + { + ret = gnutls_x509_crt_import (cert, &cert_list[i], + GNUTLS_X509_FMT_DER); + + if (ret < GNUTLS_E_SUCCESS) + failed_import = ret; + } + + p->gnutls_certificates[i] = cert; } - XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert; + if (failed_import != 0) + { + gnutls_deinit_certificates (p); + return gnutls_make_error (failed_import); + } - int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert, + int err = gnutls_x509_crt_check_hostname (p->gnutls_certificates[0], c_hostname); check_memory_full (err); if (!err) { - XPROCESS (proc)->gnutls_extra_peer_verification - |= CERTIFICATE_NOT_MATCHING; + p->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); @@ -1527,7 +1560,7 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist) } /* Set this flag only if the whole initialization succeeded. */ - XPROCESS (proc)->gnutls_p = true; + p->gnutls_p = true; return gnutls_make_error (ret); } @@ -1645,14 +1678,14 @@ one trustfile (usually a CA bundle). */) state = XPROCESS (proc)->gnutls_state; - if (TYPE_RANGED_INTEGERP (int, loglevel)) + if (TYPE_RANGED_FIXNUMP (int, loglevel)) { gnutls_global_set_log_function (gnutls_log_function); # ifdef HAVE_GNUTLS3 gnutls_global_set_audit_log_function (gnutls_audit_log_function); # endif - gnutls_global_set_log_level (XINT (loglevel)); - max_log_level = XINT (loglevel); + gnutls_global_set_log_level (XFIXNUM (loglevel)); + max_log_level = XFIXNUM (loglevel); XPROCESS (proc)->gnutls_log_level = max_log_level; } @@ -1685,9 +1718,9 @@ one trustfile (usually a CA bundle). */) XPROCESS (proc)->gnutls_x509_cred = x509_cred; verify_flags = Fplist_get (proplist, QCverify_flags); - if (TYPE_RANGED_INTEGERP (unsigned int, verify_flags)) + if (TYPE_RANGED_FIXNUMP (unsigned int, verify_flags)) { - gnutls_verify_flags = XFASTINT (verify_flags); + gnutls_verify_flags = XFIXNAT (verify_flags); GNUTLS_LOG (2, max_log_level, "setting verification flags"); } else if (NILP (verify_flags)) @@ -1846,8 +1879,8 @@ one trustfile (usually a CA bundle). */) GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY; - if (INTEGERP (prime_bits)) - gnutls_dh_set_prime_bits (state, XUINT (prime_bits)); + if (FIXNUMP (prime_bits)) + gnutls_dh_set_prime_bits (state, XUFIXNUM (prime_bits)); ret = EQ (type, Qgnutls_x509pki) ? gnutls_credentials_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred) @@ -1896,7 +1929,8 @@ This function may also return `gnutls-e-again', or state = XPROCESS (proc)->gnutls_state; - gnutls_x509_crt_deinit (XPROCESS (proc)->gnutls_certificate); + if (XPROCESS (proc)->gnutls_certificates) + gnutls_deinit_certificates (XPROCESS (proc)); ret = gnutls_bye (state, NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR); @@ -1907,6 +1941,24 @@ This function may also return `gnutls-e-again', or #ifdef HAVE_GNUTLS3 +# ifndef HAVE_GNUTLS_CIPHER_GET_IV_SIZE + /* Block size is equivalent. */ +# define gnutls_cipher_get_iv_size(cipher) gnutls_cipher_get_block_size (cipher) +# endif + +# ifndef HAVE_GNUTLS_CIPHER_GET_TAG_SIZE + /* Tag size is irrelevant. */ +# define gnutls_cipher_get_tag_size(cipher) 0 +# endif + +# ifndef HAVE_GNUTLS_DIGEST_LIST + /* The mac algorithms are equivalent. */ +# define gnutls_digest_list() \ + ((gnutls_digest_algorithm_t const *) gnutls_mac_list ()) +# define gnutls_digest_get_name(id) \ + gnutls_mac_get_name ((gnutls_mac_algorithm_t) (id)) +# endif + DEFUN ("gnutls-ciphers", Fgnutls_ciphers, Sgnutls_ciphers, 0, 0, 0, doc: /* Return alist of GnuTLS symmetric cipher descriptions as plists. The alist key is the cipher name. */) @@ -1931,19 +1983,19 @@ The alist key is the cipher name. */) Lisp_Object cp = listn (CONSTYPE_HEAP, 15, cipher_symbol, - QCcipher_id, make_number (gca), + QCcipher_id, make_fixnum (gca), QCtype, Qgnutls_type_cipher, QCcipher_aead_capable, cipher_tag_size == 0 ? Qnil : Qt, - QCcipher_tagsize, make_number (cipher_tag_size), + QCcipher_tagsize, make_fixnum (cipher_tag_size), QCcipher_blocksize, - make_number (gnutls_cipher_get_block_size (gca)), + make_fixnum (gnutls_cipher_get_block_size (gca)), QCcipher_keysize, - make_number (gnutls_cipher_get_key_size (gca)), + make_fixnum (gnutls_cipher_get_key_size (gca)), QCcipher_ivsize, - make_number (gnutls_cipher_get_iv_size (gca))); + make_fixnum (gnutls_cipher_get_iv_size (gca))); ciphers = Fcons (cp, ciphers); } @@ -2073,16 +2125,16 @@ gnutls_symmetric (bool encrypting, Lisp_Object cipher, cipher); info = XCDR (info); } - else if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t, cipher)) - gca = XINT (cipher); + else if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, cipher)) + gca = XFIXNUM (cipher); else info = cipher; if (!NILP (info) && CONSP (info)) { Lisp_Object v = Fplist_get (info, QCcipher_id); - if (TYPE_RANGED_INTEGERP (gnutls_cipher_algorithm_t, v)) - gca = XINT (v); + if (TYPE_RANGED_FIXNUMP (gnutls_cipher_algorithm_t, v)) + gca = XFIXNUM (v); } ptrdiff_t key_size = gnutls_cipher_get_key_size (gca); @@ -2258,21 +2310,21 @@ name. */) Lisp_Object gma_symbol = intern (gnutls_mac_get_name (gma)); size_t nonce_size = 0; -#ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE +# ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE nonce_size = gnutls_mac_get_nonce_size (gma); -#endif +# endif Lisp_Object mp = listn (CONSTYPE_HEAP, 11, gma_symbol, - QCmac_algorithm_id, make_number (gma), + QCmac_algorithm_id, make_fixnum (gma), QCtype, Qgnutls_type_mac_algorithm, QCmac_algorithm_length, - make_number (gnutls_hmac_get_len (gma)), + make_fixnum (gnutls_hmac_get_len (gma)), QCmac_algorithm_keysize, - make_number (gnutls_mac_get_key_size (gma)), + make_fixnum (gnutls_mac_get_key_size (gma)), QCmac_algorithm_noncesize, - make_number (nonce_size)); + make_fixnum (nonce_size)); mac_algorithms = Fcons (mp, mac_algorithms); } @@ -2297,11 +2349,11 @@ method name. */) Lisp_Object gda_symbol = intern (gnutls_digest_get_name (gda)); Lisp_Object mp = listn (CONSTYPE_HEAP, 7, gda_symbol, - QCdigest_algorithm_id, make_number (gda), + QCdigest_algorithm_id, make_fixnum (gda), QCtype, Qgnutls_type_digest_algorithm, QCdigest_algorithm_length, - make_number (gnutls_hash_get_len (gda))); + make_fixnum (gnutls_hash_get_len (gda))); digest_algorithms = Fcons (mp, digest_algorithms); } @@ -2352,16 +2404,16 @@ itself. */) hash_method); info = XCDR (info); } - else if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t, hash_method)) - gma = XINT (hash_method); + else if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, hash_method)) + gma = XFIXNUM (hash_method); else info = hash_method; if (!NILP (info) && CONSP (info)) { Lisp_Object v = Fplist_get (info, QCmac_algorithm_id); - if (TYPE_RANGED_INTEGERP (gnutls_mac_algorithm_t, v)) - gma = XINT (v); + if (TYPE_RANGED_FIXNUMP (gnutls_mac_algorithm_t, v)) + gma = XFIXNUM (v); } ptrdiff_t digest_length = gnutls_hmac_get_len (gma); @@ -2442,16 +2494,16 @@ the number itself. */) digest_method); info = XCDR (info); } - else if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t, digest_method)) - gda = XINT (digest_method); + else if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, digest_method)) + gda = XFIXNUM (digest_method); else info = digest_method; if (!NILP (info) && CONSP (info)) { Lisp_Object v = Fplist_get (info, QCdigest_algorithm_id); - if (TYPE_RANGED_INTEGERP (gnutls_digest_algorithm_t, v)) - gda = XINT (v); + if (TYPE_RANGED_FIXNUMP (gnutls_digest_algorithm_t, v)) + gda = XFIXNUM (v); } ptrdiff_t digest_length = gnutls_hash_get_len (gda); @@ -2565,11 +2617,11 @@ syms_of_gnutls (void) DEFSYM (Qlibgnutls_version, "libgnutls-version"); Fset (Qlibgnutls_version, #ifdef HAVE_GNUTLS - make_number (GNUTLS_VERSION_MAJOR * 10000 + make_fixnum (GNUTLS_VERSION_MAJOR * 10000 + GNUTLS_VERSION_MINOR * 100 + GNUTLS_VERSION_PATCH) #else - make_number (-1) + make_fixnum (-1) #endif ); #ifdef HAVE_GNUTLS @@ -2613,19 +2665,19 @@ syms_of_gnutls (void) DEFSYM (Qgnutls_e_interrupted, "gnutls-e-interrupted"); Fput (Qgnutls_e_interrupted, Qgnutls_code, - make_number (GNUTLS_E_INTERRUPTED)); + make_fixnum (GNUTLS_E_INTERRUPTED)); DEFSYM (Qgnutls_e_again, "gnutls-e-again"); Fput (Qgnutls_e_again, Qgnutls_code, - make_number (GNUTLS_E_AGAIN)); + make_fixnum (GNUTLS_E_AGAIN)); DEFSYM (Qgnutls_e_invalid_session, "gnutls-e-invalid-session"); Fput (Qgnutls_e_invalid_session, Qgnutls_code, - make_number (GNUTLS_E_INVALID_SESSION)); + make_fixnum (GNUTLS_E_INVALID_SESSION)); DEFSYM (Qgnutls_e_not_ready_for_handshake, "gnutls-e-not-ready-for-handshake"); Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code, - make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); + make_fixnum (GNUTLS_E_APPLICATION_ERROR_MIN)); defsubr (&Sgnutls_get_initstage); defsubr (&Sgnutls_asynchronous_parameters); diff --git a/src/gtkutil.c b/src/gtkutil.c index fe1680b21b5..2eac28798bc 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -260,8 +260,8 @@ xg_display_close (Display *dpy) } #if GTK_CHECK_VERSION (2, 0, 0) && ! GTK_CHECK_VERSION (2, 10, 0) - /* GTK 2.2-2.8 has a bug that makes gdk_display_close crash (bug - https://gitlab.gnome.org/GNOME/gtk/issues/221). This way we + /* GTK 2.2-2.8 has a bug that makes gdk_display_close crash + <https://gitlab.gnome.org/GNOME/gtk/issues/221>. This way we can continue running, but there will be memory leaks. */ g_object_run_dispose (G_OBJECT (gdpy)); #else @@ -689,6 +689,7 @@ qttip_cb (GtkWidget *widget, g_signal_connect (x->ttip_lbl, "hierarchy-changed", G_CALLBACK (hierarchy_ch_cb), f); } + return FALSE; } @@ -715,7 +716,8 @@ xg_prepare_tooltip (struct frame *f, GtkRequisition req; Lisp_Object encoded_string; - if (!x->ttip_lbl) return 0; + if (!x->ttip_lbl) + return FALSE; block_input (); encoded_string = ENCODE_UTF_8 (string); @@ -747,7 +749,7 @@ xg_prepare_tooltip (struct frame *f, unblock_input (); - return 1; + return TRUE; #endif /* USE_GTK_TOOLTIP */ } @@ -764,24 +766,24 @@ xg_show_tooltip (struct frame *f, int root_x, int root_y) block_input (); gtk_window_move (x->ttip_window, root_x / xg_get_scale (f), root_y / xg_get_scale (f)); - gtk_widget_show_all (GTK_WIDGET (x->ttip_window)); + gtk_widget_show (GTK_WIDGET (x->ttip_window)); unblock_input (); } #endif } + /* Hide tooltip if shown. Do nothing if not shown. Return true if tip was hidden, false if not (i.e. not using system tooltips). */ - bool xg_hide_tooltip (struct frame *f) { - bool ret = 0; #ifdef USE_GTK_TOOLTIP if (f->output_data.x->ttip_window) { GtkWindow *win = f->output_data.x->ttip_window; + block_input (); gtk_widget_hide (GTK_WIDGET (win)); @@ -794,10 +796,10 @@ xg_hide_tooltip (struct frame *f) } unblock_input (); - ret = 1; + return TRUE; } #endif - return ret; + return FALSE; } @@ -963,7 +965,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height) { frame_size_history_add (f, Qxg_frame_set_char_size_1, width, height, - list2 (make_number (gheight), make_number (totalheight))); + list2 (make_fixnum (gheight), make_fixnum (totalheight))); gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), gwidth, totalheight); @@ -972,7 +974,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height) { frame_size_history_add (f, Qxg_frame_set_char_size_2, width, height, - list2 (make_number (gwidth), make_number (totalwidth))); + list2 (make_fixnum (gwidth), make_fixnum (totalwidth))); gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), totalwidth, gheight); @@ -981,7 +983,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height) { frame_size_history_add (f, Qxg_frame_set_char_size_3, width, height, - list2 (make_number (totalwidth), make_number (totalheight))); + list2 (make_fixnum (totalwidth), make_fixnum (totalheight))); gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), totalwidth, totalheight); @@ -1066,16 +1068,23 @@ static void xg_set_widget_bg (struct frame *f, GtkWidget *w, unsigned long pixel) { #ifdef HAVE_GTK3 - GdkRGBA bg; XColor xbg; xbg.pixel = pixel; if (XQueryColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), &xbg)) { - bg.red = (double)xbg.red/65535.0; - bg.green = (double)xbg.green/65535.0; - bg.blue = (double)xbg.blue/65535.0; - bg.alpha = 1.0; - gtk_widget_override_background_color (w, GTK_STATE_FLAG_NORMAL, &bg); + const char format[] = "* { background-color: #%02x%02x%02x; }"; + /* The format is always longer than the resulting string. */ + char buffer[sizeof format]; + int n = snprintf(buffer, sizeof buffer, format, + xbg.red >> 8, xbg.green >> 8, xbg.blue >> 8); + eassert (n > 0); + eassert (n < sizeof buffer); + GtkCssProvider *provider = gtk_css_provider_new (); + gtk_css_provider_load_from_data (provider, buffer, -1, NULL); + gtk_style_context_add_provider (gtk_widget_get_style_context(w), + GTK_STYLE_PROVIDER (provider), + GTK_STYLE_PROVIDER_PRIORITY_APPLICATION); + g_clear_object (&provider); } #else GdkColor bg; @@ -1239,9 +1248,11 @@ xg_create_frame_widgets (struct frame *f) X and GTK+ drawing to a pure GTK+ build. */ gtk_widget_set_double_buffered (wfixed, FALSE); +#if ! GTK_CHECK_VERSION (3, 22, 0) gtk_window_set_wmclass (GTK_WINDOW (wtop), SSDATA (Vx_resource_name), SSDATA (Vx_resource_class)); +#endif /* Add callback to do nothing on WM_DELETE_WINDOW. The default in GTK is to destroy the widget. We want Emacs to do that instead. */ @@ -1859,7 +1870,7 @@ xg_maybe_add_timer (gpointer data) if (timespec_valid_p (next_time)) { time_t s = next_time.tv_sec; - int per_ms = TIMESPEC_RESOLUTION / 1000; + int per_ms = TIMESPEC_HZ / 1000; int ms = (next_time.tv_nsec + per_ms - 1) / per_ms; if (s <= ((guint) -1 - ms) / 1000) dd->timerid = g_timeout_add (s * 1000 + ms, xg_maybe_add_timer, dd); @@ -4111,8 +4122,10 @@ xg_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar, if (int_gtk_range_get_value (GTK_RANGE (wscroll)) != value) gtk_range_set_value (GTK_RANGE (wscroll), (gdouble)value); +#if ! GTK_CHECK_VERSION (3, 18, 0) else if (changed) gtk_adjustment_changed (adj); +#endif xg_ignore_gtk_scrollbar = 0; @@ -4149,7 +4162,9 @@ xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, gtk_adjustment_configure (adj, (gdouble) value, (gdouble) lower, (gdouble) upper, (gdouble) step_increment, (gdouble) page_increment, (gdouble) pagesize); +#if ! GTK_CHECK_VERSION (3, 18, 0) gtk_adjustment_changed (adj); +#endif unblock_input (); } } @@ -4267,7 +4282,7 @@ draw_page (GtkPrintOperation *operation, GtkPrintContext *context, gint page_nr, gpointer user_data) { Lisp_Object frames = *((Lisp_Object *) user_data); - struct frame *f = XFRAME (Fnth (make_number (page_nr), frames)); + struct frame *f = XFRAME (Fnth (make_fixnum (page_nr), frames)); cairo_t *cr = gtk_print_context_get_cairo_context (context); x_cr_draw_frame (cr, f); @@ -4284,7 +4299,7 @@ xg_print_frames_dialog (Lisp_Object frames) gtk_print_operation_set_print_settings (print, print_settings); if (page_setup != NULL) gtk_print_operation_set_default_page_setup (print, page_setup); - gtk_print_operation_set_n_pages (print, XINT (Flength (frames))); + gtk_print_operation_set_n_pages (print, XFIXNUM (Flength (frames))); g_signal_connect (print, "draw-page", G_CALLBACK (draw_page), &frames); res = gtk_print_operation_run (print, GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG, NULL, NULL); @@ -4877,18 +4892,18 @@ update_frame_tool_bar (struct frame *f) block_input (); - if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX)) + if (RANGED_FIXNUMP (1, Vtool_bar_button_margin, INT_MAX)) { - hmargin = XFASTINT (Vtool_bar_button_margin); - vmargin = XFASTINT (Vtool_bar_button_margin); + hmargin = XFIXNAT (Vtool_bar_button_margin); + vmargin = XFIXNAT (Vtool_bar_button_margin); } else if (CONSP (Vtool_bar_button_margin)) { - if (RANGED_INTEGERP (1, XCAR (Vtool_bar_button_margin), INT_MAX)) - hmargin = XFASTINT (XCAR (Vtool_bar_button_margin)); + if (RANGED_FIXNUMP (1, XCAR (Vtool_bar_button_margin), INT_MAX)) + hmargin = XFIXNAT (XCAR (Vtool_bar_button_margin)); - if (RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), INT_MAX)) - vmargin = XFASTINT (XCDR (Vtool_bar_button_margin)); + if (RANGED_FIXNUMP (1, XCDR (Vtool_bar_button_margin), INT_MAX)) + vmargin = XFIXNAT (XCDR (Vtool_bar_button_margin)); } /* The natural size (i.e. when GTK uses 0 as margin) looks best, diff --git a/src/image.c b/src/image.c index 2d5a882232f..87e0c071eef 100644 --- a/src/image.c +++ b/src/image.c @@ -77,6 +77,7 @@ typedef struct x_bitmap_record Bitmap_Record; /* We need (or want) w32.h only when we're _not_ compiling for Cygwin. */ #ifdef WINDOWSNT +# include "w32common.h" # include "w32.h" #endif @@ -322,7 +323,7 @@ x_create_bitmap_from_file (struct frame *f, Lisp_Object file) /* Search bitmap-file-path for the file, if appropriate. */ if (openp (Vx_bitmap_file_path, file, Qnil, &found, - make_number (R_OK), false) + make_fixnum (R_OK), false) < 0) return -1; @@ -524,6 +525,33 @@ x_create_bitmap_mask (struct frame *f, ptrdiff_t id) Image types ***********************************************************************/ +/* Each image format (JPEG, TIFF, ...) supported is described by + a structure of the type below. */ + +struct image_type +{ + /* Index of a symbol uniquely identifying the image type, e.g., 'jpeg'. */ + int type; + + /* Check that SPEC is a valid image specification for the given + image type. Value is true if SPEC is valid. */ + bool (*valid_p) (Lisp_Object spec); + + /* Load IMG which is used on frame F from information contained in + IMG->spec. Value is true if successful. */ + bool (*load) (struct frame *f, struct image *img); + + /* Free resources of image IMG which is used on frame F. */ + void (*free) (struct frame *f, struct image *img); + + /* Initialization function (used for dynamic loading of image + libraries on Windows), or NULL if none. */ + bool (*init) (void); + + /* Next in list of all supported image types. */ + struct image_type *next; +}; + /* List of supported image types. Use define_image_type to add new types. Use lookup_image_type to find a type for a given symbol. */ @@ -761,23 +789,23 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, break; case IMAGE_POSITIVE_INTEGER_VALUE: - if (! RANGED_INTEGERP (1, value, INT_MAX)) + if (! RANGED_FIXNUMP (1, value, INT_MAX)) return 0; break; case IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR: - if (RANGED_INTEGERP (0, value, INT_MAX)) + if (RANGED_FIXNUMP (0, value, INT_MAX)) break; if (CONSP (value) - && RANGED_INTEGERP (0, XCAR (value), INT_MAX) - && RANGED_INTEGERP (0, XCDR (value), INT_MAX)) + && RANGED_FIXNUMP (0, XCAR (value), INT_MAX) + && RANGED_FIXNUMP (0, XCDR (value), INT_MAX)) break; return 0; case IMAGE_ASCENT_VALUE: if (SYMBOLP (value) && EQ (value, Qcenter)) break; - else if (RANGED_INTEGERP (0, value, 100)) + else if (RANGED_FIXNUMP (0, value, 100)) break; return 0; @@ -785,7 +813,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, /* Unlike the other integer-related cases, this one does not verify that VALUE fits in 'int'. This is because callers want EMACS_INT. */ - if (!INTEGERP (value) || XINT (value) < 0) + if (!FIXNUMP (value) || XFIXNUM (value) < 0) return 0; break; @@ -804,7 +832,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, break; case IMAGE_INTEGER_VALUE: - if (! TYPE_RANGED_INTEGERP (int, value)) + if (! TYPE_RANGED_FIXNUMP (int, value)) return 0; break; @@ -883,7 +911,7 @@ or omitted means use the selected frame. */) size = Fcons (make_float ((double) width / FRAME_COLUMN_WIDTH (f)), make_float ((double) height / FRAME_LINE_HEIGHT (f))); else - size = Fcons (make_number (width), make_number (height)); + size = Fcons (make_fixnum (width), make_fixnum (height)); } else error ("Invalid image specification"); @@ -1004,9 +1032,9 @@ check_image_size (struct frame *f, int width, int height) if (width <= 0 || height <= 0) return 0; - if (INTEGERP (Vmax_image_size)) - return (width <= XINT (Vmax_image_size) - && height <= XINT (Vmax_image_size)); + if (FIXNUMP (Vmax_image_size)) + return (width <= XFIXNUM (Vmax_image_size) + && height <= XFIXNUM (Vmax_image_size)); else if (FLOATP (Vmax_image_size)) { if (f != NULL) @@ -1534,7 +1562,7 @@ clear_image_cache (struct frame *f, Lisp_Object filter) } } } - else if (INTEGERP (Vimage_cache_eviction_delay)) + else if (FIXNUMP (Vimage_cache_eviction_delay)) { /* Free cache based on timestamp. */ struct timespec old, t; @@ -1547,7 +1575,7 @@ clear_image_cache (struct frame *f, Lisp_Object filter) /* If the number of cached images has grown unusually large, decrease the cache eviction delay (Bug#6230). */ - delay = XINT (Vimage_cache_eviction_delay); + delay = XFIXNUM (Vimage_cache_eviction_delay); if (nimages > 40) delay = 1600 * delay / nimages / nimages; delay = max (delay, 1); @@ -1610,7 +1638,7 @@ Anything else, means only clear those images which refer to FILTER, which is then usually a filename. */) (Lisp_Object filter) { - if (!(EQ (filter, Qnil) || FRAMEP (filter))) + if (! (NILP (filter) || FRAMEP (filter))) clear_image_caches (filter); else clear_image_cache (decode_window_system_frame (filter), Qt); @@ -1761,11 +1789,11 @@ lookup_image (struct frame *f, Lisp_Object spec) Lisp_Object value; value = image_spec_value (spec, QCwidth, NULL); - img->width = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH); + img->width = (FIXNUMP (value) + ? XFIXNAT (value) : DEFAULT_IMAGE_WIDTH); value = image_spec_value (spec, QCheight, NULL); - img->height = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT); + img->height = (FIXNUMP (value) + ? XFIXNAT (value) : DEFAULT_IMAGE_HEIGHT); } else { @@ -1776,25 +1804,25 @@ lookup_image (struct frame *f, Lisp_Object spec) int relief_bound; ascent = image_spec_value (spec, QCascent, NULL); - if (INTEGERP (ascent)) - img->ascent = XFASTINT (ascent); + if (FIXNUMP (ascent)) + img->ascent = XFIXNAT (ascent); else if (EQ (ascent, Qcenter)) img->ascent = CENTERED_IMAGE_ASCENT; margin = image_spec_value (spec, QCmargin, NULL); - if (INTEGERP (margin)) - img->vmargin = img->hmargin = XFASTINT (margin); + if (FIXNUMP (margin)) + img->vmargin = img->hmargin = XFIXNAT (margin); else if (CONSP (margin)) { - img->hmargin = XFASTINT (XCAR (margin)); - img->vmargin = XFASTINT (XCDR (margin)); + img->hmargin = XFIXNAT (XCAR (margin)); + img->vmargin = XFIXNAT (XCDR (margin)); } relief = image_spec_value (spec, QCrelief, NULL); relief_bound = INT_MAX - max (img->hmargin, img->vmargin); - if (RANGED_INTEGERP (- relief_bound, relief, relief_bound)) + if (RANGED_FIXNUMP (- relief_bound, relief, relief_bound)) { - img->relief = XINT (relief); + img->relief = XFIXNUM (relief); img->hmargin += eabs (img->relief); img->vmargin += eabs (img->relief); } @@ -1973,7 +2001,7 @@ x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth, x_destroy_x_image (*ximg); *ximg = NULL; image_error ("Image too large (%dx%d)", - make_number (width), make_number (height)); + make_fixnum (width), make_fixnum (height)); return 0; } @@ -2306,16 +2334,16 @@ x_find_image_fd (Lisp_Object file, int *pfd) /* Try to find FILE in data-directory/images, then x-bitmap-file-path. */ fd = openp (search_path, file, Qnil, &file_found, - pfd ? Qt : make_number (R_OK), false); + pfd ? Qt : make_fixnum (R_OK), false); if (fd >= 0 || fd == -2) { file_found = ENCODE_FILE (file_found); if (fd == -2) { - /* The file exists locally, but has a file handler. (This - happens, e.g., under Auto Image File Mode.) 'openp' - didn't open the file, so we should, because the caller - expects that. */ + /* The file exists locally, but has a file name handler. + (This 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, 0); } } @@ -2512,8 +2540,8 @@ xbm_image_p (Lisp_Object object) return 0; data = kw[XBM_DATA].value; - width = XFASTINT (kw[XBM_WIDTH].value); - height = XFASTINT (kw[XBM_HEIGHT].value); + width = XFIXNAT (kw[XBM_WIDTH].value); + height = XFIXNAT (kw[XBM_HEIGHT].value); /* Check type of data, and width and height against contents of data. */ @@ -2875,7 +2903,7 @@ xbm_read_bitmap_data (struct frame *f, char *contents, char *end, { if (!inhibit_image_error) image_error ("Image too large (%dx%d)", - make_number (*width), make_number (*height)); + make_fixnum (*width), make_fixnum (*height)); goto failure; } bytes_per_line = (*width + 7) / 8 + padding_p; @@ -3061,8 +3089,8 @@ xbm_load (struct frame *f, struct image *img) /* Get specified width, and height. */ if (!in_memory_file_p) { - img->width = XFASTINT (fmt[XBM_WIDTH].value); - img->height = XFASTINT (fmt[XBM_HEIGHT].value); + img->width = XFIXNAT (fmt[XBM_WIDTH].value); + img->height = XFIXNAT (fmt[XBM_HEIGHT].value); eassert (img->width > 0 && img->height > 0); if (!check_image_size (f, img->width, img->height)) { @@ -4000,7 +4028,7 @@ xpm_make_color_table_v (void (**put_func) (Lisp_Object, const char *, int, { *put_func = xpm_put_color_table_v; *get_func = xpm_get_color_table_v; - return Fmake_vector (make_number (256), Qnil); + return make_nil_vector (256); } static void @@ -4168,7 +4196,7 @@ xpm_load_image (struct frame *f, if (!NILP (Fxw_display_color_p (frame))) best_key = XPM_COLOR_KEY_C; else if (!NILP (Fx_display_grayscale_p (frame))) - best_key = (XFASTINT (Fx_display_planes (frame)) > 2 + best_key = (XFIXNAT (Fx_display_planes (frame)) > 2 ? XPM_COLOR_KEY_G : XPM_COLOR_KEY_G4); else best_key = XPM_COLOR_KEY_M; @@ -4239,7 +4267,7 @@ xpm_load_image (struct frame *f, color_val = Qt; else if (x_defined_color (f, SSDATA (XCDR (specified_color)), &cdef, 0)) - color_val = make_number (cdef.pixel); + color_val = make_fixnum (cdef.pixel); } } if (NILP (color_val) && max_key > 0) @@ -4247,7 +4275,7 @@ xpm_load_image (struct frame *f, if (xstrcasecmp (max_color, "None") == 0) color_val = Qt; else if (x_defined_color (f, max_color, &cdef, 0)) - color_val = make_number (cdef.pixel); + color_val = make_fixnum (cdef.pixel); } if (!NILP (color_val)) (*put_color_table) (color_table, beg, chars_per_pixel, color_val); @@ -4267,7 +4295,7 @@ xpm_load_image (struct frame *f, (*get_color_table) (color_table, str, chars_per_pixel); XPutPixel (ximg, x, y, - (INTEGERP (color_val) ? XINT (color_val) + (FIXNUMP (color_val) ? XFIXNUM (color_val) : FRAME_FOREGROUND_PIXEL (f))); #ifndef HAVE_NS XPutPixel (mask_img, x, y, @@ -4939,7 +4967,7 @@ x_edge_detection (struct frame *f, struct image *img, Lisp_Object matrix, } if (NILP (color_adjust)) - color_adjust = make_number (0xffff / 2); + color_adjust = make_fixnum (0xffff / 2); if (i == 9 && NUMBERP (color_adjust)) x_detect_edges (f, img, trans, XFLOATINT (color_adjust)); @@ -5093,9 +5121,9 @@ x_build_heuristic_mask (struct frame *f, struct image *img, Lisp_Object how) { int rgb[3], i; - for (i = 0; i < 3 && CONSP (how) && NATNUMP (XCAR (how)); ++i) + for (i = 0; i < 3 && CONSP (how) && FIXNATP (XCAR (how)); ++i) { - rgb[i] = XFASTINT (XCAR (how)) & 0xffff; + rgb[i] = XFIXNAT (XCAR (how)) & 0xffff; how = XCDR (how); } @@ -5734,7 +5762,7 @@ DEF_DLL_FN (void, png_read_end, (png_structp, png_infop)); DEF_DLL_FN (void, png_error, (png_structp, png_const_charp)); # if (PNG_LIBPNG_VER >= 10500) -DEF_DLL_FN (void, png_longjmp, (png_structp, int)) PNG_NORETURN; +DEF_DLL_FN (void, png_longjmp, (png_structp, int) PNG_NORETURN); DEF_DLL_FN (jmp_buf *, png_set_longjmp_fn, (png_structp, png_longjmp_ptr, size_t)); # endif /* libpng version >= 1.5 */ @@ -7280,9 +7308,9 @@ tiff_load (struct frame *f, struct image *img) } image = image_spec_value (img->spec, QCindex, NULL); - if (INTEGERP (image)) + if (FIXNUMP (image)) { - EMACS_INT ino = XFASTINT (image); + EMACS_INT ino = XFIXNAT (image); if (! (TYPE_MINIMUM (tdir_t) <= ino && ino <= TYPE_MAXIMUM (tdir_t) && TIFFSetDirectory (tiff, ino))) { @@ -7324,7 +7352,7 @@ tiff_load (struct frame *f, struct image *img) if (count > 1) img->lisp_data = Fcons (Qcount, - Fcons (make_number (count), + Fcons (make_fixnum (count), img->lisp_data)); TIFFClose (tiff); @@ -7746,7 +7774,7 @@ gif_load (struct frame *f, struct image *img) /* Which sub-image are we to display? */ { Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL); - idx = INTEGERP (image_number) ? XFASTINT (image_number) : 0; + idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0; if (idx < 0 || idx >= gif->ImageCount) { image_error ("Invalid image number `%s' in image `%s'", @@ -8000,7 +8028,7 @@ gif_load (struct frame *f, struct image *img) /* Append (... FUNCTION "BYTES") */ { img->lisp_data - = Fcons (make_number (ext->Function), + = Fcons (make_fixnum (ext->Function), Fcons (make_unibyte_string ((char *) ext->Bytes, ext->ByteCount), img->lisp_data)); @@ -8021,7 +8049,7 @@ gif_load (struct frame *f, struct image *img) if (gif->ImageCount > 1) img->lisp_data = Fcons (Qcount, - Fcons (make_number (gif->ImageCount), + Fcons (make_fixnum (gif->ImageCount), img->lisp_data)); if (gif_close (gif, &gif_err) == GIF_ERROR) @@ -8106,29 +8134,29 @@ compute_image_size (size_t width, size_t height, scale = XFLOATINT (value); value = image_spec_value (spec, QCmax_width, NULL); - if (NATNUMP (value)) - max_width = min (XFASTINT (value), INT_MAX); + if (FIXNATP (value)) + max_width = min (XFIXNAT (value), INT_MAX); value = image_spec_value (spec, QCmax_height, NULL); - if (NATNUMP (value)) - max_height = min (XFASTINT (value), INT_MAX); + if (FIXNATP (value)) + max_height = min (XFIXNAT (value), INT_MAX); /* 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); - if (NATNUMP (value)) + if (FIXNATP (value)) { - desired_width = min (XFASTINT (value) * scale, INT_MAX); + desired_width = min (XFIXNAT (value) * scale, INT_MAX); /* :width overrides :max-width. */ max_width = -1; } value = image_spec_value (spec, QCheight, NULL); - if (NATNUMP (value)) + if (FIXNATP (value)) { - desired_height = min (XFASTINT (value) * scale, INT_MAX); + desired_height = min (XFIXNAT (value) * scale, INT_MAX); /* :height overrides :max-height. */ max_height = -1; } @@ -8272,11 +8300,20 @@ imagemagick_image_p (Lisp_Object object) /* The GIF library also defines DrawRectangle, but its never used in Emacs. Therefore rename the function so it doesn't collide with ImageMagick. */ #define DrawRectangle DrawRectangleGif -#include <wand/MagickWand.h> + +#ifdef HAVE_IMAGEMAGICK7 +# include <MagickWand/MagickWand.h> +# include <MagickCore/version.h> +/* ImageMagick 7 compatibility definitions. */ +# define PixelSetMagickColor PixelSetPixelColor +typedef PixelInfo MagickPixelPacket; +#else +# include <wand/MagickWand.h> +# include <magick/version.h> +#endif /* ImageMagick 6.5.3 through 6.6.5 hid PixelGetMagickColor for some reason. Emacs seems to work fine with the hidden version, so unhide it. */ -#include <magick/version.h> #if 0x653 <= MagickLibVersion && MagickLibVersion <= 0x665 extern WandExport void PixelGetMagickColor (const PixelWand *, MagickPixelPacket *); @@ -8573,7 +8610,7 @@ imagemagick_load_image (struct frame *f, struct image *img, find out things about it. */ image = image_spec_value (img->spec, QCindex, NULL); - ino = INTEGERP (image) ? XFASTINT (image) : 0; + ino = FIXNUMP (image) ? XFIXNAT (image) : 0; image_wand = NewMagickWand (); if (filename) @@ -8583,9 +8620,9 @@ imagemagick_load_image (struct frame *f, struct image *img, 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)) + if (FIXNATP (lwidth) && FIXNATP (lheight)) { - MagickSetSize (image_wand, XFASTINT (lwidth), XFASTINT (lheight)); + MagickSetSize (image_wand, XFIXNAT (lwidth), XFIXNAT (lheight)); MagickSetDepth (image_wand, 8); } filename_hint = imagemagick_filename_hint (img->spec, hint_buffer); @@ -8628,7 +8665,7 @@ imagemagick_load_image (struct frame *f, struct image *img, if (MagickGetNumberImages (image_wand) > 1) img->lisp_data = Fcons (Qcount, - Fcons (make_number (MagickGetNumberImages (image_wand)), + Fcons (make_fixnum (MagickGetNumberImages (image_wand)), img->lisp_data)); /* If we have an animated image, get the new wand based on the @@ -8678,26 +8715,26 @@ imagemagick_load_image (struct frame *f, struct image *img, efficient. */ crop = image_spec_value (img->spec, QCcrop, NULL); - if (CONSP (crop) && TYPE_RANGED_INTEGERP (size_t, XCAR (crop))) + if (CONSP (crop) && TYPE_RANGED_FIXNUMP (size_t, XCAR (crop))) { /* After some testing, it seems MagickCropImage is the fastest crop function in ImageMagick. This crop function seems to do less copying than the alternatives, but it still reads the entire image into memory before cropping, which is apparently difficult to avoid when using imagemagick. */ - size_t crop_width = XINT (XCAR (crop)); + size_t crop_width = XFIXNUM (XCAR (crop)); crop = XCDR (crop); - if (CONSP (crop) && TYPE_RANGED_INTEGERP (size_t, XCAR (crop))) + if (CONSP (crop) && TYPE_RANGED_FIXNUMP (size_t, XCAR (crop))) { - size_t crop_height = XINT (XCAR (crop)); + size_t crop_height = XFIXNUM (XCAR (crop)); crop = XCDR (crop); - if (CONSP (crop) && TYPE_RANGED_INTEGERP (ssize_t, XCAR (crop))) + if (CONSP (crop) && TYPE_RANGED_FIXNUMP (ssize_t, XCAR (crop))) { - ssize_t crop_x = XINT (XCAR (crop)); + ssize_t crop_x = XFIXNUM (XCAR (crop)); crop = XCDR (crop); - if (CONSP (crop) && TYPE_RANGED_INTEGERP (ssize_t, XCAR (crop))) + if (CONSP (crop) && TYPE_RANGED_FIXNUMP (ssize_t, XCAR (crop))) { - ssize_t crop_y = XINT (XCAR (crop)); + ssize_t crop_y = XFIXNUM (XCAR (crop)); MagickCropImage (image_wand, crop_width, crop_height, crop_x, crop_y); } @@ -8814,7 +8851,8 @@ imagemagick_load_image (struct frame *f, struct image *img, #endif /* HAVE_MAGICKEXPORTIMAGEPIXELS */ { size_t image_height; - MagickRealType color_scale = 65535.0 / QuantumRange; + double quantum_range = QuantumRange; + MagickRealType color_scale = 65535.0 / quantum_range; #ifdef USE_CAIRO data = xmalloc (width * height * 4); color_scale /= 256; @@ -9302,7 +9340,7 @@ svg_load_image (struct frame *f, struct image *img, char *contents, /* Set base_uri for properly handling referenced images (via 'href'). See rsvg bug 596114 - "image refs are relative to curdir, not .svg file" - (https://gitlab.gnome.org/GNOME/librsvg/issues/33). */ + <https://gitlab.gnome.org/GNOME/librsvg/issues/33>. */ if (filename) rsvg_handle_set_base_uri(rsvg_handle, filename); @@ -9551,7 +9589,7 @@ gs_image_p (Lisp_Object object) if (CONSP (tem)) { for (i = 0; i < 4; ++i, tem = XCDR (tem)) - if (!CONSP (tem) || !INTEGERP (XCAR (tem))) + if (!CONSP (tem) || !FIXNUMP (XCAR (tem))) return 0; if (!NILP (tem)) return 0; @@ -9561,7 +9599,7 @@ gs_image_p (Lisp_Object object) if (ASIZE (tem) != 4) return 0; for (i = 0; i < 4; ++i) - if (!INTEGERP (AREF (tem, i))) + if (!FIXNUMP (AREF (tem, i))) return 0; } else @@ -9589,10 +9627,10 @@ gs_load (struct frame *f, struct image *img) = 1/72 in, xdpi and ydpi are stored in the frame's X display info. */ pt_width = image_spec_value (img->spec, QCpt_width, NULL); - in_width = INTEGERP (pt_width) ? XFASTINT (pt_width) / 72.0 : 0; + in_width = FIXNUMP (pt_width) ? XFIXNAT (pt_width) / 72.0 : 0; in_width *= FRAME_RES_X (f); pt_height = image_spec_value (img->spec, QCpt_height, NULL); - in_height = INTEGERP (pt_height) ? XFASTINT (pt_height) / 72.0 : 0; + in_height = FIXNUMP (pt_height) ? XFIXNAT (pt_height) / 72.0 : 0; in_height *= FRAME_RES_Y (f); if (! (in_width <= INT_MAX && in_height <= INT_MAX @@ -9643,8 +9681,8 @@ gs_load (struct frame *f, struct image *img) loader = intern ("gs-load-image"); img->lisp_data = call6 (loader, frame, img->spec, - make_number (img->width), - make_number (img->height), + make_fixnum (img->width), + make_fixnum (img->height), window_and_pixmap_id, pixel_colors); return PROCESSP (img->lisp_data); @@ -9768,7 +9806,7 @@ DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, id = lookup_image (SELECTED_FRAME (), spec); debug_print (spec); - return make_number (id); + return make_fixnum (id); } #endif /* GLYPH_DEBUG */ @@ -9933,27 +9971,27 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (Qlibpng_version, "libpng-version"); Fset (Qlibpng_version, #if HAVE_PNG - make_number (PNG_LIBPNG_VER) + make_fixnum (PNG_LIBPNG_VER) #else - make_number (-1) + make_fixnum (-1) #endif ); DEFSYM (Qlibgif_version, "libgif-version"); Fset (Qlibgif_version, #ifdef HAVE_GIF - make_number (GIFLIB_MAJOR * 10000 + make_fixnum (GIFLIB_MAJOR * 10000 + GIFLIB_MINOR * 100 + GIFLIB_RELEASE) #else - make_number (-1) + make_fixnum (-1) #endif ); DEFSYM (Qlibjpeg_version, "libjpeg-version"); Fset (Qlibjpeg_version, #if HAVE_JPEG - make_number (JPEG_LIB_VERSION) + make_fixnum (JPEG_LIB_VERSION) #else - make_number (-1) + make_fixnum (-1) #endif ); #endif @@ -10038,7 +10076,7 @@ a large number of images, the actual eviction time may be shorter. The value can also be nil, meaning the cache is never cleared. The function `clear-image-cache' disregards this variable. */); - Vimage_cache_eviction_delay = make_number (300); + Vimage_cache_eviction_delay = make_fixnum (300); #ifdef HAVE_IMAGEMAGICK DEFVAR_INT ("imagemagick-render-type", imagemagick_render_type, doc: /* Integer indicating which ImageMagick rendering method to use. diff --git a/src/indent.c b/src/indent.c index 5e3a7e05923..0970532f30d 100644 --- a/src/indent.c +++ b/src/indent.c @@ -116,7 +116,7 @@ disptab_matches_widthtab (struct Lisp_Char_Table *disptab, struct Lisp_Vector *w for (i = 0; i < 256; i++) if (character_width (i, disptab) - != XFASTINT (widthtab->contents[i])) + != XFIXNAT (widthtab->contents[i])) return 0; return 1; @@ -235,24 +235,24 @@ skip_invisible (ptrdiff_t pos, ptrdiff_t *next_boundary_p, ptrdiff_t to, Lisp_Ob /* As for text properties, this gives a lower bound for where the invisible text property could change. */ proplimit = Fnext_property_change (position, buffer, Qt); - if (XFASTINT (overlay_limit) < XFASTINT (proplimit)) + if (XFIXNAT (overlay_limit) < XFIXNAT (proplimit)) proplimit = overlay_limit; /* PROPLIMIT is now a lower bound for the next change in invisible status. If that is plenty far away, use that lower bound. */ - if (XFASTINT (proplimit) > pos + 100 || XFASTINT (proplimit) >= to) - *next_boundary_p = XFASTINT (proplimit); + if (XFIXNAT (proplimit) > pos + 100 || XFIXNAT (proplimit) >= to) + *next_boundary_p = XFIXNAT (proplimit); /* Otherwise, scan for the next `invisible' property change. */ else { /* Don't scan terribly far. */ XSETFASTINT (proplimit, min (pos + 100, to)); /* No matter what, don't go past next overlay change. */ - if (XFASTINT (overlay_limit) < XFASTINT (proplimit)) + if (XFIXNAT (overlay_limit) < XFIXNAT (proplimit)) proplimit = overlay_limit; tmp = Fnext_single_property_change (position, Qinvisible, buffer, proplimit); - end = XFASTINT (tmp); + end = XFIXNAT (tmp); #if 0 /* Don't put the boundary in the middle of multibyte form if there is no actual property change. */ @@ -472,7 +472,7 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos) Lisp_Object val, overlay; if (CONSP (val = get_char_property_and_overlay - (make_number (pos), Qdisplay, Qnil, &overlay)) + (make_fixnum (pos), Qdisplay, Qnil, &overlay)) && EQ (Qspace, XCAR (val))) { /* FIXME: Use calc_pixel_width_or_height. */ Lisp_Object plist = XCDR (val), prop; @@ -483,16 +483,16 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos) : MOST_POSITIVE_FIXNUM); if ((prop = Fplist_get (plist, QCwidth), - RANGED_INTEGERP (0, prop, INT_MAX)) + RANGED_FIXNUMP (0, prop, INT_MAX)) || (prop = Fplist_get (plist, QCrelative_width), - RANGED_INTEGERP (0, prop, INT_MAX))) - width = XINT (prop); + RANGED_FIXNUMP (0, prop, INT_MAX))) + width = XFIXNUM (prop); else if (FLOATP (prop) && 0 <= XFLOAT_DATA (prop) && XFLOAT_DATA (prop) <= INT_MAX) width = (int)(XFLOAT_DATA (prop) + 0.5); else if ((prop = Fplist_get (plist, QCalign_to), - RANGED_INTEGERP (col, prop, align_to_max))) - width = XINT (prop) - col; + RANGED_FIXNUMP (col, prop, align_to_max))) + width = XFIXNUM (prop) - col; else if (FLOATP (prop) && col <= XFLOAT_DATA (prop) && (XFLOAT_DATA (prop) <= align_to_max)) width = (int)(XFLOAT_DATA (prop) + 0.5) - col; @@ -751,16 +751,16 @@ string_display_width (Lisp_Object string, Lisp_Object beg, Lisp_Object end) e = SCHARS (string); else { - CHECK_NUMBER (end); - e = XINT (end); + CHECK_FIXNUM (end); + e = XFIXNUM (end); } if (NILP (beg)) b = 0; else { - CHECK_NUMBER (beg); - b = XINT (beg); + CHECK_FIXNUM (beg); + b = XFIXNUM (beg); } /* Make a pointer for decrementing through the chars before point. */ @@ -820,32 +820,32 @@ The return value is the column where the insertion ends. */) register ptrdiff_t fromcol; int tab_width = SANE_TAB_WIDTH (current_buffer); - CHECK_NUMBER (column); + CHECK_FIXNUM (column); if (NILP (minimum)) XSETFASTINT (minimum, 0); - CHECK_NUMBER (minimum); + CHECK_FIXNUM (minimum); fromcol = current_column (); - mincol = fromcol + XINT (minimum); - if (mincol < XINT (column)) mincol = XINT (column); + mincol = fromcol + XFIXNUM (minimum); + if (mincol < XFIXNUM (column)) mincol = XFIXNUM (column); if (fromcol == mincol) - return make_number (mincol); + return make_fixnum (mincol); if (indent_tabs_mode) { Lisp_Object n; XSETFASTINT (n, mincol / tab_width - fromcol / tab_width); - if (XFASTINT (n) != 0) + if (XFIXNAT (n) != 0) { - Finsert_char (make_number ('\t'), n, Qt); + Finsert_char (make_fixnum ('\t'), n, Qt); fromcol = (mincol / tab_width) * tab_width; } } XSETFASTINT (column, mincol - fromcol); - Finsert_char (make_number (' '), column, Qt); + Finsert_char (make_fixnum (' '), column, Qt); last_known_column = mincol; last_known_column_point = PT; @@ -866,7 +866,7 @@ following any initial whitespace. */) ptrdiff_t posbyte; find_newline (PT, PT_BYTE, BEGV, BEGV_BYTE, -1, NULL, &posbyte, 1); - return make_number (position_indentation (posbyte)); + return make_fixnum (position_indentation (posbyte)); } static ptrdiff_t @@ -994,8 +994,8 @@ The return value is the current column. */) EMACS_INT col; EMACS_INT goal; - CHECK_NATNUM (column); - goal = XINT (column); + CHECK_FIXNAT (column); + goal = XFIXNUM (column); col = goal; pos = ZV; @@ -1020,13 +1020,13 @@ The return value is the current column. */) first so that a marker at the end of the tab gets adjusted. */ SET_PT_BOTH (PT - 1, PT_BYTE - 1); - Finsert_char (make_number (' '), make_number (goal - prev_col), Qt); + Finsert_char (make_fixnum (' '), make_fixnum (goal - prev_col), Qt); /* Now delete the tab, and indent to COL. */ del_range (PT, PT + 1); goal_pt = PT; goal_pt_byte = PT_BYTE; - Findent_to (make_number (col), Qnil); + Findent_to (make_fixnum (col), Qnil); SET_PT_BOTH (goal_pt, goal_pt_byte); /* Set the last_known... vars consistently. */ @@ -1036,13 +1036,13 @@ The return value is the current column. */) /* If line ends prematurely, add space to the end. */ if (col < goal && EQ (force, Qt)) - Findent_to (make_number (col = goal), Qnil); + Findent_to (make_fixnum (col = goal), Qnil); last_known_column = col; last_known_column_point = PT; last_known_column_modified = MODIFF; - return make_number (col); + return make_fixnum (col); } /* compute_motion: compute buffer posn given screen posn and vice versa */ @@ -1128,8 +1128,8 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, bool ctl_arrow = !NILP (BVAR (current_buffer, ctl_arrow)); struct Lisp_Char_Table *dp = window_display_table (win); EMACS_INT selective - = (INTEGERP (BVAR (current_buffer, selective_display)) - ? XINT (BVAR (current_buffer, selective_display)) + = (FIXNUMP (BVAR (current_buffer, selective_display)) + ? XFIXNUM (BVAR (current_buffer, selective_display)) : !NILP (BVAR (current_buffer, selective_display)) ? -1 : 0); ptrdiff_t selective_rlen = (selective && dp && VECTORP (DISP_INVIS_VECTOR (dp)) @@ -1338,9 +1338,9 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, if (!NILP (Vtruncate_partial_width_windows) && (total_width < FRAME_COLS (XFRAME (WINDOW_FRAME (win))))) { - if (INTEGERP (Vtruncate_partial_width_windows)) + if (FIXNUMP (Vtruncate_partial_width_windows)) truncate - = total_width < XFASTINT (Vtruncate_partial_width_windows); + = total_width < XFIXNAT (Vtruncate_partial_width_windows); else truncate = 1; } @@ -1533,7 +1533,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, /* Is this character part of the current run? If so, extend the run. */ if (pos - 1 == width_run_end - && XFASTINT (width_table[c]) == width_run_width) + && XFIXNAT (width_table[c]) == width_run_width) width_run_end = pos; /* The previous run is over, since this is a character at a @@ -1548,7 +1548,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, width_run_start, width_run_end); /* Start recording a new width run. */ - width_run_width = XFASTINT (width_table[c]); + width_run_width = XFIXNAT (width_table[c]); width_run_start = pos - 1; width_run_end = pos; } @@ -1754,48 +1754,48 @@ visible section of the buffer, and pass LINE and COL as TOPOS. */) ptrdiff_t hscroll; int tab_offset; - CHECK_NUMBER_COERCE_MARKER (from); + CHECK_FIXNUM_COERCE_MARKER (from); CHECK_CONS (frompos); - CHECK_NUMBER_CAR (frompos); - CHECK_NUMBER_CDR (frompos); - CHECK_NUMBER_COERCE_MARKER (to); + CHECK_FIXNUM (XCAR (frompos)); + CHECK_FIXNUM (XCDR (frompos)); + CHECK_FIXNUM_COERCE_MARKER (to); if (!NILP (topos)) { CHECK_CONS (topos); - CHECK_NUMBER_CAR (topos); - CHECK_NUMBER_CDR (topos); + CHECK_FIXNUM (XCAR (topos)); + CHECK_FIXNUM (XCDR (topos)); } if (!NILP (width)) - CHECK_NUMBER (width); + CHECK_FIXNUM (width); if (!NILP (offsets)) { CHECK_CONS (offsets); - CHECK_NUMBER_CAR (offsets); - CHECK_NUMBER_CDR (offsets); - if (! (0 <= XINT (XCAR (offsets)) && XINT (XCAR (offsets)) <= PTRDIFF_MAX - && 0 <= XINT (XCDR (offsets)) && XINT (XCDR (offsets)) <= INT_MAX)) + CHECK_FIXNUM (XCAR (offsets)); + CHECK_FIXNUM (XCDR (offsets)); + if (! (0 <= XFIXNUM (XCAR (offsets)) && XFIXNUM (XCAR (offsets)) <= PTRDIFF_MAX + && 0 <= XFIXNUM (XCDR (offsets)) && XFIXNUM (XCDR (offsets)) <= INT_MAX)) args_out_of_range (XCAR (offsets), XCDR (offsets)); - hscroll = XINT (XCAR (offsets)); - tab_offset = XINT (XCDR (offsets)); + hscroll = XFIXNUM (XCAR (offsets)); + tab_offset = XFIXNUM (XCDR (offsets)); } else hscroll = tab_offset = 0; w = decode_live_window (window); - if (XINT (from) < BEGV || XINT (from) > ZV) - args_out_of_range_3 (from, make_number (BEGV), make_number (ZV)); - if (XINT (to) < BEGV || XINT (to) > ZV) - args_out_of_range_3 (to, make_number (BEGV), make_number (ZV)); + if (XFIXNUM (from) < BEGV || XFIXNUM (from) > ZV) + args_out_of_range_3 (from, make_fixnum (BEGV), make_fixnum (ZV)); + if (XFIXNUM (to) < BEGV || XFIXNUM (to) > ZV) + args_out_of_range_3 (to, make_fixnum (BEGV), make_fixnum (ZV)); - pos = compute_motion (XINT (from), CHAR_TO_BYTE (XINT (from)), - XINT (XCDR (frompos)), - XINT (XCAR (frompos)), 0, - XINT (to), + pos = compute_motion (XFIXNUM (from), CHAR_TO_BYTE (XFIXNUM (from)), + XFIXNUM (XCDR (frompos)), + XFIXNUM (XCAR (frompos)), 0, + XFIXNUM (to), (NILP (topos) ? window_internal_height (w) - : XINT (XCDR (topos))), + : XFIXNUM (XCDR (topos))), (NILP (topos) ? (window_body_width (w, 0) - ( @@ -1803,8 +1803,8 @@ visible section of the buffer, and pass LINE and COL as TOPOS. */) FRAME_WINDOW_P (XFRAME (w->frame)) ? 0 : #endif 1)) - : XINT (XCAR (topos))), - (NILP (width) ? -1 : XINT (width)), + : XFIXNUM (XCAR (topos))), + (NILP (width) ? -1 : XFIXNUM (width)), hscroll, tab_offset, w); XSETFASTINT (bufpos, pos->bufpos); @@ -1831,8 +1831,8 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, register ptrdiff_t first; ptrdiff_t lmargin = hscroll > 0 ? 1 - hscroll : 0; ptrdiff_t selective - = (INTEGERP (BVAR (current_buffer, selective_display)) - ? clip_to_bounds (-1, XINT (BVAR (current_buffer, selective_display)), + = (FIXNUMP (BVAR (current_buffer, selective_display)) + ? clip_to_bounds (-1, XFIXNUM (BVAR (current_buffer, selective_display)), PTRDIFF_MAX) : !NILP (BVAR (current_buffer, selective_display)) ? -1 : 0); Lisp_Object window; @@ -1870,7 +1870,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, && indented_beyond_p (prevline, bytepos, selective)) /* Watch out for newlines with `invisible' property. When moving upward, check the newline before. */ - || (propval = Fget_char_property (make_number (prevline - 1), + || (propval = Fget_char_property (make_fixnum (prevline - 1), Qinvisible, text_prop_object), TEXT_PROP_MEANS_INVISIBLE (propval)))) @@ -1920,7 +1920,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, && indented_beyond_p (prevline, bytepos, selective)) /* Watch out for newlines with `invisible' property. When moving downward, check the newline after. */ - || (propval = Fget_char_property (make_number (prevline), + || (propval = Fget_char_property (make_fixnum (prevline), Qinvisible, text_prop_object), TEXT_PROP_MEANS_INVISIBLE (propval)))) @@ -2016,8 +2016,8 @@ numbers on display. */) return make_float ((double) pixel_width / FRAME_COLUMN_WIDTH (f)); } else if (!NILP (pixelwise)) - return make_number (pixel_width); - return make_number (width); + return make_fixnum (pixel_width); + return make_fixnum (width); } /* In window W (derived from WINDOW), return x coordinate for column @@ -2045,8 +2045,8 @@ restore_window_buffer (Lisp_Object list) wset_buffer (w, XCAR (list)); list = XCDR (list); set_marker_both (w->pointm, w->contents, - XFASTINT (XCAR (list)), - XFASTINT (XCAR (XCDR (list)))); + XFIXNAT (XCAR (list)), + XFIXNAT (XCAR (XCDR (list)))); } DEFUN ("vertical-motion", Fvertical_motion, Svertical_motion, 1, 3, 0, @@ -2100,15 +2100,15 @@ whether or not it is currently displayed in some window. */) lines = XCDR (lines); } - CHECK_NUMBER (lines); + CHECK_FIXNUM (lines); w = decode_live_window (window); if (XBUFFER (w->contents) != current_buffer) { /* Set the window's buffer temporarily to the current buffer. */ Lisp_Object old = list4 (window, w->contents, - make_number (marker_position (w->pointm)), - make_number (marker_byte_position (w->pointm))); + make_fixnum (marker_position (w->pointm)), + make_fixnum (marker_byte_position (w->pointm))); record_unwind_protect (restore_window_buffer, old); wset_buffer (w, Fcurrent_buffer ()); set_marker_both (w->pointm, w->contents, @@ -2118,7 +2118,7 @@ whether or not it is currently displayed in some window. */) if (noninteractive) { struct position pos; - pos = *vmotion (PT, PT_BYTE, XINT (lines), w); + pos = *vmotion (PT, PT_BYTE, XFIXNUM (lines), w); SET_PT_BOTH (pos.bufpos, pos.bytepos); it.vpos = pos.vpos; } @@ -2128,7 +2128,7 @@ whether or not it is currently displayed in some window. */) int first_x; bool overshoot_handled = 0; bool disp_string_at_start_p = 0; - ptrdiff_t nlines = XINT (lines); + ptrdiff_t nlines = XFIXNUM (lines); int vpos_init = 0; double start_col UNINIT; int start_x UNINIT; @@ -2356,9 +2356,7 @@ whether or not it is currently displayed in some window. */) bidi_unshelve_cache (itdata, 0); } - unbind_to (count, Qnil); - - return make_number (it.vpos); + return unbind_to (count, make_fixnum (it.vpos)); } diff --git a/src/inotify.c b/src/inotify.c index a11d1d954e9..ecbe31c1682 100644 --- a/src/inotify.c +++ b/src/inotify.c @@ -176,7 +176,7 @@ inotifyevent_to_event (Lisp_Object watch, struct inotify_event const *ev) { Lisp_Object name; uint32_t mask; - CONS_TO_INTEGER (Fnth (make_number (3), watch), uint32_t, mask); + CONS_TO_INTEGER (Fnth (make_fixnum (3), watch), uint32_t, mask); if (! (mask & ev->mask)) return Qnil; @@ -190,11 +190,11 @@ inotifyevent_to_event (Lisp_Object watch, struct inotify_event const *ev) else name = XCAR (XCDR (watch)); - return list2 (list4 (Fcons (INTEGER_TO_CONS (ev->wd), XCAR (watch)), + return list2 (list4 (Fcons (INT_TO_INTEGER (ev->wd), XCAR (watch)), mask_to_aspects (ev->mask), name, - INTEGER_TO_CONS (ev->cookie)), - Fnth (make_number (2), watch)); + INT_TO_INTEGER (ev->cookie)), + Fnth (make_fixnum (2), watch)); } /* Add a new watch to watch-descriptor WD watching FILENAME and using @@ -204,10 +204,10 @@ static Lisp_Object add_watch (int wd, Lisp_Object filename, uint32_t imask, Lisp_Object callback) { - Lisp_Object descriptor = INTEGER_TO_CONS (wd); + Lisp_Object descriptor = INT_TO_INTEGER (wd); Lisp_Object tail = assoc_no_quit (descriptor, watch_list); Lisp_Object watch, watch_id; - Lisp_Object mask = INTEGER_TO_CONS (imask); + Lisp_Object mask = INT_TO_INTEGER (imask); EMACS_INT id = 0; if (NILP (tail)) @@ -220,7 +220,7 @@ add_watch (int wd, Lisp_Object filename, /* Assign a watch ID that is not already in use, by looking for a gap in the existing sorted list. */ for (; ! NILP (XCDR (tail)); tail = XCDR (tail), id++) - if (!EQ (XCAR (XCAR (XCDR (tail))), make_number (id))) + if (!EQ (XCAR (XCAR (XCDR (tail))), make_fixnum (id))) break; if (MOST_POSITIVE_FIXNUM < id) emacs_abort (); @@ -229,7 +229,7 @@ add_watch (int wd, Lisp_Object filename, /* Insert the newly-assigned ID into the previously-discovered gap, which is possibly at the end of the list. Inserting it there keeps the list sorted. */ - watch_id = make_number (id); + watch_id = make_fixnum (id); watch = list4 (watch_id, filename, callback, mask); XSETCDR (tail, Fcons (watch, XCDR (tail))); @@ -332,7 +332,7 @@ inotify_callback (int fd, void *_) for (ssize_t i = 0; i < n; ) { struct inotify_event *ev = (struct inotify_event *) &buffer[i]; - Lisp_Object descriptor = INTEGER_TO_CONS (ev->wd); + Lisp_Object descriptor = INT_TO_INTEGER (ev->wd); Lisp_Object prevtail = find_descriptor (descriptor); if (! NILP (prevtail)) @@ -446,12 +446,12 @@ static bool valid_watch_descriptor (Lisp_Object wd) { return (CONSP (wd) - && (RANGED_INTEGERP (0, XCAR (wd), INT_MAX) + && (RANGED_FIXNUMP (0, XCAR (wd), INT_MAX) || (CONSP (XCAR (wd)) - && RANGED_INTEGERP ((MOST_POSITIVE_FIXNUM >> 16) + 1, + && RANGED_FIXNUMP ((MOST_POSITIVE_FIXNUM >> 16) + 1, XCAR (XCAR (wd)), INT_MAX >> 16) - && RANGED_INTEGERP (0, XCDR (XCAR (wd)), (1 << 16) - 1))) - && NATNUMP (XCDR (wd))); + && RANGED_FIXNUMP (0, XCDR (XCAR (wd)), (1 << 16) - 1))) + && FIXNATP (XCDR (wd))); } DEFUN ("inotify-rm-watch", Finotify_rm_watch, Sinotify_rm_watch, 1, 1, 0, diff --git a/src/insdel.c b/src/insdel.c index 550d1a0e8f6..08f04d3ddca 100644 --- a/src/insdel.c +++ b/src/insdel.c @@ -930,7 +930,7 @@ insert_1_both (const char *string, offset_intervals (current_buffer, PT, nchars); if (!inherit && buffer_intervals (current_buffer)) - set_text_properties (make_number (PT), make_number (PT + nchars), + set_text_properties (make_fixnum (PT), make_fixnum (PT + nchars), Qnil, Qnil, Qnil); adjust_point (nchars, nbytes); @@ -1936,7 +1936,7 @@ prepare_to_modify_buffer_1 (ptrdiff_t start, ptrdiff_t end, if (preserve_ptr) { Lisp_Object preserve_marker; - preserve_marker = Fcopy_marker (make_number (*preserve_ptr), Qnil); + preserve_marker = Fcopy_marker (make_fixnum (*preserve_ptr), Qnil); verify_interval_modification (current_buffer, start, end); *preserve_ptr = marker_position (preserve_marker); unchain_marker (XMARKER (preserve_marker)); @@ -2046,7 +2046,7 @@ invalidate_buffer_caches (struct buffer *buf, ptrdiff_t start, ptrdiff_t end) #define PRESERVE_VALUE \ if (preserve_ptr && NILP (preserve_marker)) \ - preserve_marker = Fcopy_marker (make_number (*preserve_ptr), Qnil) + preserve_marker = Fcopy_marker (make_fixnum (*preserve_ptr), Qnil) #define RESTORE_VALUE \ if (! NILP (preserve_marker)) \ @@ -2103,8 +2103,8 @@ signal_before_change (ptrdiff_t start_int, ptrdiff_t end_int, ptrdiff_t count = SPECPDL_INDEX (); struct rvoe_arg rvoe_arg; - start = make_number (start_int); - end = make_number (end_int); + start = make_fixnum (start_int); + end = make_fixnum (end_int); preserve_marker = Qnil; start_marker = Qnil; end_marker = Qnil; @@ -2210,26 +2210,26 @@ signal_after_change (ptrdiff_t charpos, ptrdiff_t lendel, ptrdiff_t lenins) /* Actually run the hook functions. */ CALLN (Frun_hook_with_args, Qafter_change_functions, - make_number (charpos), make_number (charpos + lenins), - make_number (lendel)); + make_fixnum (charpos), make_fixnum (charpos + lenins), + make_fixnum (lendel)); /* There was no error: unarm the reset_on_error. */ rvoe_arg.errorp = 0; } if (buffer_has_overlays ()) - report_overlay_modification (make_number (charpos), - make_number (charpos + lenins), + report_overlay_modification (make_fixnum (charpos), + make_fixnum (charpos + lenins), 1, - make_number (charpos), - make_number (charpos + lenins), - make_number (lendel)); + make_fixnum (charpos), + make_fixnum (charpos + lenins), + make_fixnum (lendel)); /* After an insertion, call the text properties insert-behind-hooks or insert-in-front-hooks. */ if (lendel == 0) - report_interval_modification (make_number (charpos), - make_number (charpos + lenins)); + report_interval_modification (make_fixnum (charpos), + make_fixnum (charpos + lenins)); unbind_to (count, Qnil); } @@ -2255,7 +2255,7 @@ DEFUN ("combine-after-change-execute", Fcombine_after_change_execute, /* It is rare for combine_after_change_buffer to be invalid, but possible. It can happen when combine-after-change-calls is - non-nil, and insertion calls a file handler (e.g. through + non-nil, and insertion calls a file name handler (e.g. through lock_file) which scribbles into a temp file -- cyd */ if (!BUFFERP (combine_after_change_buffer) || !BUFFER_LIVE_P (XBUFFER (combine_after_change_buffer))) @@ -2287,17 +2287,17 @@ DEFUN ("combine-after-change-execute", Fcombine_after_change_execute, elt = XCAR (tail); if (! CONSP (elt)) continue; - thisbeg = XINT (XCAR (elt)); + thisbeg = XFIXNUM (XCAR (elt)); elt = XCDR (elt); if (! CONSP (elt)) continue; - thisend = XINT (XCAR (elt)); + thisend = XFIXNUM (XCAR (elt)); elt = XCDR (elt); if (! CONSP (elt)) continue; - thischange = XINT (XCAR (elt)); + thischange = XFIXNUM (XCAR (elt)); /* Merge this range into the accumulated range. */ change += thischange; diff --git a/src/intervals.c b/src/intervals.c index e7595b23b3a..524bb944e51 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -197,7 +197,7 @@ intervals_equal (INTERVAL i0, INTERVAL i1) } /* i0 has something i1 doesn't. */ - if (EQ (i1_val, Qnil)) + if (NILP (i1_val)) return false; /* i0 and i1 both have sym, but it has different values in each. */ @@ -1557,8 +1557,8 @@ graft_intervals_into_buffer (INTERVAL source, ptrdiff_t position, if (!inherit && tree && length > 0) { XSETBUFFER (buf, buffer); - set_text_properties_1 (make_number (position), - make_number (position + length), + set_text_properties_1 (make_fixnum (position), + make_fixnum (position + length), Qnil, buf, find_interval (tree, position)); } @@ -1793,7 +1793,7 @@ adjust_for_invis_intang (ptrdiff_t pos, ptrdiff_t test_offs, ptrdiff_t adj, /* POS + ADJ would be beyond the buffer bounds, so do no adjustment. */ return pos; - test_pos = make_number (pos + test_offs); + test_pos = make_fixnum (pos + test_offs); invis_propval = get_char_property_and_overlay (test_pos, Qinvisible, Qnil, @@ -1806,7 +1806,7 @@ adjust_for_invis_intang (ptrdiff_t pos, ptrdiff_t test_offs, ptrdiff_t adj, such that an insertion at POS would inherit it. */ && (NILP (invis_overlay) /* Invisible property is from a text-property. */ - ? (text_property_stickiness (Qinvisible, make_number (pos), Qnil) + ? (text_property_stickiness (Qinvisible, make_fixnum (pos), Qnil) == (test_offs == 0 ? 1 : -1)) /* Invisible property is from an overlay. */ : (test_offs == 0 @@ -1926,8 +1926,8 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos) if (! NILP (intangible_propval)) { - while (XINT (pos) > BEGV - && EQ (Fget_char_property (make_number (XINT (pos) - 1), + while (XFIXNUM (pos) > BEGV + && EQ (Fget_char_property (make_fixnum (XFIXNUM (pos) - 1), Qintangible, Qnil), intangible_propval)) pos = Fprevious_char_property_change (pos, Qnil); @@ -1937,7 +1937,7 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos) property is `front-sticky', perturb it to be one character earlier -- this ensures that point can never move to the beginning of an invisible/intangible/front-sticky region. */ - charpos = adjust_for_invis_intang (XINT (pos), 0, -1, 0); + charpos = adjust_for_invis_intang (XFIXNUM (pos), 0, -1, 0); } } else @@ -1954,12 +1954,12 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos) /* If preceding char is intangible, skip forward over all chars with matching intangible property. */ - intangible_propval = Fget_char_property (make_number (charpos - 1), + intangible_propval = Fget_char_property (make_fixnum (charpos - 1), Qintangible, Qnil); if (! NILP (intangible_propval)) { - while (XINT (pos) < ZV + while (XFIXNUM (pos) < ZV && EQ (Fget_char_property (pos, Qintangible, Qnil), intangible_propval)) pos = Fnext_char_property_change (pos, Qnil); @@ -1969,7 +1969,7 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos) property is `rear-sticky', perturb it to be one character later -- this ensures that point can never move to the end of an invisible/intangible/rear-sticky region. */ - charpos = adjust_for_invis_intang (XINT (pos), -1, 1, 0); + charpos = adjust_for_invis_intang (XFIXNUM (pos), -1, 1, 0); } } @@ -2026,18 +2026,18 @@ set_point_both (ptrdiff_t charpos, ptrdiff_t bytepos) enter_after = Qnil; if (! EQ (leave_before, enter_before) && !NILP (leave_before)) - call2 (leave_before, make_number (old_position), - make_number (charpos)); + call2 (leave_before, make_fixnum (old_position), + make_fixnum (charpos)); if (! EQ (leave_after, enter_after) && !NILP (leave_after)) - call2 (leave_after, make_number (old_position), - make_number (charpos)); + call2 (leave_after, make_fixnum (old_position), + make_fixnum (charpos)); if (! EQ (enter_before, leave_before) && !NILP (enter_before)) - call2 (enter_before, make_number (old_position), - make_number (charpos)); + call2 (enter_before, make_fixnum (old_position), + make_fixnum (charpos)); if (! EQ (enter_after, leave_after) && !NILP (enter_after)) - call2 (enter_after, make_number (old_position), - make_number (charpos)); + call2 (enter_after, make_fixnum (old_position), + make_fixnum (charpos)); } } @@ -2055,7 +2055,7 @@ move_if_not_intangible (ptrdiff_t position) if (! NILP (Vinhibit_point_motion_hooks)) /* If intangible is inhibited, always move point to POSITION. */ ; - else if (PT < position && XINT (pos) < ZV) + else if (PT < position && XFIXNUM (pos) < ZV) { /* We want to move forward, so check the text before POSITION. */ @@ -2065,23 +2065,23 @@ move_if_not_intangible (ptrdiff_t position) /* If following char is intangible, skip back over all chars with matching intangible property. */ if (! NILP (intangible_propval)) - while (XINT (pos) > BEGV - && EQ (Fget_char_property (make_number (XINT (pos) - 1), + while (XFIXNUM (pos) > BEGV + && EQ (Fget_char_property (make_fixnum (XFIXNUM (pos) - 1), Qintangible, Qnil), intangible_propval)) pos = Fprevious_char_property_change (pos, Qnil); } - else if (XINT (pos) > BEGV) + else if (XFIXNUM (pos) > BEGV) { /* We want to move backward, so check the text after POSITION. */ - intangible_propval = Fget_char_property (make_number (XINT (pos) - 1), + intangible_propval = Fget_char_property (make_fixnum (XFIXNUM (pos) - 1), Qintangible, Qnil); /* If following char is intangible, skip forward over all chars with matching intangible property. */ if (! NILP (intangible_propval)) - while (XINT (pos) < ZV + while (XFIXNUM (pos) < ZV && EQ (Fget_char_property (pos, Qintangible, Qnil), intangible_propval)) pos = Fnext_char_property_change (pos, Qnil); @@ -2096,7 +2096,7 @@ move_if_not_intangible (ptrdiff_t position) try moving to POSITION (which means we actually move farther if POSITION is inside of intangible text). */ - if (XINT (pos) != PT) + if (XFIXNUM (pos) != PT) SET_PT (position); } diff --git a/src/intervals.h b/src/intervals.h index 311ef79466f..3cee7889414 100644 --- a/src/intervals.h +++ b/src/intervals.h @@ -116,7 +116,7 @@ struct interval /* True if this is a default interval, which is the same as being null or having no properties. */ -#define DEFAULT_INTERVAL_P(i) (!i || EQ ((i)->plist, Qnil)) +#define DEFAULT_INTERVAL_P(i) (!i || NILP ((i)->plist)) /* Test what type of parent we have. Three possibilities: another interval, a buffer or string object, or NULL. */ diff --git a/src/json.c b/src/json.c new file mode 100644 index 00000000000..770b63c1da2 --- /dev/null +++ b/src/json.c @@ -0,0 +1,1107 @@ +/* JSON parsing and serialization. + +Copyright (C) 2017-2018 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <errno.h> +#include <stddef.h> +#include <stdint.h> +#include <stdlib.h> + +#include <jansson.h> + +#include "lisp.h" +#include "buffer.h" +#include "coding.h" + +#define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00) + +#ifdef WINDOWSNT +# include <windows.h> +# include "w32common.h" +# include "w32.h" + +DEF_DLL_FN (void, json_set_alloc_funcs, + (json_malloc_t malloc_fn, json_free_t free_fn)); +DEF_DLL_FN (void, json_delete, (json_t *json)); +DEF_DLL_FN (json_t *, json_array, (void)); +DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value)); +DEF_DLL_FN (size_t, json_array_size, (const json_t *array)); +DEF_DLL_FN (json_t *, json_object, (void)); +DEF_DLL_FN (int, json_object_set_new, + (json_t *object, const char *key, json_t *value)); +DEF_DLL_FN (json_t *, json_null, (void)); +DEF_DLL_FN (json_t *, json_true, (void)); +DEF_DLL_FN (json_t *, json_false, (void)); +DEF_DLL_FN (json_t *, json_integer, (json_int_t value)); +DEF_DLL_FN (json_t *, json_real, (double value)); +DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len)); +DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags)); +DEF_DLL_FN (int, json_dump_callback, + (const json_t *json, json_dump_callback_t callback, void *data, + size_t flags)); +DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer)); +DEF_DLL_FN (double, json_real_value, (const json_t *real)); +DEF_DLL_FN (const char *, json_string_value, (const json_t *string)); +DEF_DLL_FN (size_t, json_string_length, (const json_t *string)); +DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index)); +DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key)); +DEF_DLL_FN (size_t, json_object_size, (const json_t *object)); +DEF_DLL_FN (const char *, json_object_iter_key, (void *iter)); +DEF_DLL_FN (void *, json_object_iter, (json_t *object)); +DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter)); +DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key)); +DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter)); +DEF_DLL_FN (json_t *, json_loads, + (const char *input, size_t flags, json_error_t *error)); +DEF_DLL_FN (json_t *, json_load_callback, + (json_load_callback_t callback, void *data, size_t flags, + json_error_t *error)); + +/* This is called by json_decref, which is an inline function. */ +void json_delete(json_t *json) +{ + fn_json_delete (json); +} + +static bool json_initialized; + +static bool +init_json_functions (void) +{ + HMODULE library = w32_delayed_load (Qjson); + + if (!library) + return false; + + LOAD_DLL_FN (library, json_set_alloc_funcs); + LOAD_DLL_FN (library, json_delete); + LOAD_DLL_FN (library, json_array); + LOAD_DLL_FN (library, json_array_append_new); + LOAD_DLL_FN (library, json_array_size); + LOAD_DLL_FN (library, json_object); + LOAD_DLL_FN (library, json_object_set_new); + LOAD_DLL_FN (library, json_null); + LOAD_DLL_FN (library, json_true); + LOAD_DLL_FN (library, json_false); + LOAD_DLL_FN (library, json_integer); + LOAD_DLL_FN (library, json_real); + LOAD_DLL_FN (library, json_stringn); + LOAD_DLL_FN (library, json_dumps); + LOAD_DLL_FN (library, json_dump_callback); + LOAD_DLL_FN (library, json_integer_value); + LOAD_DLL_FN (library, json_real_value); + LOAD_DLL_FN (library, json_string_value); + LOAD_DLL_FN (library, json_string_length); + LOAD_DLL_FN (library, json_array_get); + LOAD_DLL_FN (library, json_object_get); + LOAD_DLL_FN (library, json_object_size); + LOAD_DLL_FN (library, json_object_iter_key); + LOAD_DLL_FN (library, json_object_iter); + LOAD_DLL_FN (library, json_object_iter_value); + LOAD_DLL_FN (library, json_object_key_to_iter); + LOAD_DLL_FN (library, json_object_iter_next); + LOAD_DLL_FN (library, json_loads); + LOAD_DLL_FN (library, json_load_callback); + + init_json (); + + return true; +} + +#define json_set_alloc_funcs fn_json_set_alloc_funcs +#define json_array fn_json_array +#define json_array_append_new fn_json_array_append_new +#define json_array_size fn_json_array_size +#define json_object fn_json_object +#define json_object_set_new fn_json_object_set_new +#define json_null fn_json_null +#define json_true fn_json_true +#define json_false fn_json_false +#define json_integer fn_json_integer +#define json_real fn_json_real +#define json_stringn fn_json_stringn +#define json_dumps fn_json_dumps +#define json_dump_callback fn_json_dump_callback +#define json_integer_value fn_json_integer_value +#define json_real_value fn_json_real_value +#define json_string_value fn_json_string_value +#define json_string_length fn_json_string_length +#define json_array_get fn_json_array_get +#define json_object_get fn_json_object_get +#define json_object_size fn_json_object_size +#define json_object_iter_key fn_json_object_iter_key +#define json_object_iter fn_json_object_iter +#define json_object_iter_value fn_json_object_iter_value +#define json_object_key_to_iter fn_json_object_key_to_iter +#define json_object_iter_next fn_json_object_iter_next +#define json_loads fn_json_loads +#define json_load_callback fn_json_load_callback + +#endif /* WINDOWSNT */ + +/* We install a custom allocator so that we can avoid objects larger + than PTRDIFF_MAX. Such objects wouldn't play well with the rest of + Emacs's codebase, which generally uses ptrdiff_t for sizes and + indices. The other functions in this file also generally assume + that size_t values never exceed PTRDIFF_MAX. + + In addition, we need to use a custom allocator because on + MS-Windows we replace malloc/free with our own functions, see + w32heap.c, so we must force the library to use our allocator, or + else we won't be able to free storage allocated by the library. */ + +static void * +json_malloc (size_t size) +{ + if (size > PTRDIFF_MAX) + { + errno = ENOMEM; + return NULL; + } + return malloc (size); +} + +static void +json_free (void *ptr) +{ + free (ptr); +} + +void +init_json (void) +{ + json_set_alloc_funcs (json_malloc, json_free); +} + +#if !JSON_HAS_ERROR_CODE + +/* Return whether STRING starts with PREFIX. */ + +static bool +json_has_prefix (const char *string, const char *prefix) +{ + size_t string_len = strlen (string); + size_t prefix_len = strlen (prefix); + return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0; +} + +/* Return whether STRING ends with SUFFIX. */ + +static bool +json_has_suffix (const char *string, const char *suffix) +{ + size_t string_len = strlen (string); + size_t suffix_len = strlen (suffix); + return string_len >= suffix_len + && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0; +} + +#endif + +/* Create a multibyte Lisp string from the UTF-8 string in + [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not + contain a valid UTF-8 string, an unspecified string is returned. + Note that all callers below either pass only value UTF-8 strings or + use this function for formatting error messages; in the latter case + correctness isn't critical. */ + +static Lisp_Object +json_make_string (const char *data, ptrdiff_t size) +{ + return code_convert_string (make_specified_string (data, -1, size, false), + Qutf_8_unix, Qt, false, true, true); +} + +/* Create a multibyte Lisp string from the null-terminated UTF-8 + string beginning at DATA. If the string is not a valid UTF-8 + string, an unspecified string is returned. Note that all callers + below either pass only value UTF-8 strings or use this function for + formatting error messages; in the latter case correctness isn't + critical. */ + +static Lisp_Object +json_build_string (const char *data) +{ + return json_make_string (data, strlen (data)); +} + +/* Return a unibyte string containing the sequence of UTF-8 encoding + units of the UTF-8 representation of STRING. If STRING does not + represent a sequence of Unicode scalar values, return a string with + unspecified contents. */ + +static Lisp_Object +json_encode (Lisp_Object string) +{ + /* FIXME: Raise an error if STRING is not a scalar value + sequence. */ + return code_convert_string (string, Qutf_8_unix, Qt, true, true, true); +} + +static _Noreturn void +json_out_of_memory (void) +{ + xsignal0 (Qjson_out_of_memory); +} + +/* Signal a Lisp error corresponding to the JSON ERROR. */ + +static _Noreturn void +json_parse_error (const json_error_t *error) +{ + Lisp_Object symbol; +#if JSON_HAS_ERROR_CODE + switch (json_error_code (error)) + { + case json_error_premature_end_of_input: + symbol = Qjson_end_of_file; + break; + case json_error_end_of_input_expected: + symbol = Qjson_trailing_content; + break; + default: + symbol = Qjson_parse_error; + break; + } +#else + if (json_has_suffix (error->text, "expected near end of file")) + symbol = Qjson_end_of_file; + else if (json_has_prefix (error->text, "end of file expected")) + symbol = Qjson_trailing_content; + else + symbol = Qjson_parse_error; +#endif + xsignal (symbol, + list5 (json_build_string (error->text), + json_build_string (error->source), make_fixed_natnum (error->line), + make_fixed_natnum (error->column), make_fixed_natnum (error->position))); +} + +static void +json_release_object (void *object) +{ + json_decref (object); +} + +/* Signal an error if OBJECT is not a string, or if OBJECT contains + embedded null characters. */ + +static void +check_string_without_embedded_nulls (Lisp_Object object) +{ + CHECK_STRING (object); + CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, + Qstring_without_embedded_nulls_p, object); +} + +/* Signal an error of type `json-out-of-memory' if OBJECT is + NULL. */ + +static json_t * +json_check (json_t *object) +{ + if (object == NULL) + json_out_of_memory (); + return object; +} + +/* If STRING is not a valid UTF-8 string, signal an error of type + `wrong-type-argument'. STRING must be a unibyte string. */ + +static void +json_check_utf8 (Lisp_Object string) +{ + CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string); +} + +enum json_object_type { + json_object_hashtable, + json_object_alist, + json_object_plist +}; + +struct json_configuration { + enum json_object_type object_type; + Lisp_Object null_object; + Lisp_Object false_object; +}; + +static json_t *lisp_to_json (Lisp_Object, struct json_configuration *conf); + +/* Convert a Lisp object to a toplevel JSON object (array or object). */ + +static json_t * +lisp_to_json_toplevel_1 (Lisp_Object lisp, + struct json_configuration *conf) +{ + json_t *json; + ptrdiff_t count; + + if (VECTORP (lisp)) + { + ptrdiff_t size = ASIZE (lisp); + json = json_check (json_array ()); + count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, json); + for (ptrdiff_t i = 0; i < size; ++i) + { + int status + = json_array_append_new (json, lisp_to_json (AREF (lisp, i), + conf)); + if (status == -1) + json_out_of_memory (); + } + eassert (json_array_size (json) == size); + } + else if (HASH_TABLE_P (lisp)) + { + struct Lisp_Hash_Table *h = XHASH_TABLE (lisp); + json = json_check (json_object ()); + count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, json); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object key = json_encode (HASH_KEY (h, i)); + /* We can't specify the length, so the string must be + null-terminated. */ + check_string_without_embedded_nulls (key); + const char *key_str = SSDATA (key); + /* Reject duplicate keys. These are possible if the hash + table test is not `equal'. */ + if (json_object_get (json, key_str) != NULL) + wrong_type_argument (Qjson_value_p, lisp); + int status = json_object_set_new (json, key_str, + lisp_to_json (HASH_VALUE (h, i), + conf)); + if (status == -1) + { + /* A failure can be caused either by an invalid key or + by low memory. */ + json_check_utf8 (key); + json_out_of_memory (); + } + } + } + else if (NILP (lisp)) + return json_check (json_object ()); + else if (CONSP (lisp)) + { + Lisp_Object tail = lisp; + json = json_check (json_object ()); + count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, json); + bool is_plist = !CONSP (XCAR (tail)); + FOR_EACH_TAIL (tail) + { + const char *key_str; + Lisp_Object value; + Lisp_Object key_symbol; + if (is_plist) + { + key_symbol = XCAR (tail); + tail = XCDR (tail); + CHECK_CONS (tail); + value = XCAR (tail); + if (EQ (tail, li.tortoise)) circular_list (lisp); + } + else + { + Lisp_Object pair = XCAR (tail); + CHECK_CONS (pair); + key_symbol = XCAR (pair); + value = XCDR (pair); + } + CHECK_SYMBOL (key_symbol); + Lisp_Object key = SYMBOL_NAME (key_symbol); + /* We can't specify the length, so the string must be + null-terminated. */ + check_string_without_embedded_nulls (key); + key_str = SSDATA (key); + /* In plists, ensure leading ":" in keys is stripped. It + will be reconstructed later in `json_to_lisp'.*/ + if (is_plist && ':' == key_str[0] && key_str[1]) + { + key_str = &key_str[1]; + } + /* Only add element if key is not already present. */ + if (json_object_get (json, key_str) == NULL) + { + int status + = json_object_set_new (json, key_str, lisp_to_json (value, + conf)); + if (status == -1) + json_out_of_memory (); + } + } + CHECK_LIST_END (tail, lisp); + } + else + wrong_type_argument (Qjson_value_p, lisp); + + clear_unwind_protect (count); + unbind_to (count, Qnil); + return json; +} + +/* Convert LISP to a toplevel JSON object (array or object). Signal + an error of type `wrong-type-argument' if LISP is not a vector, + hashtable, alist, or plist. */ + +static json_t * +lisp_to_json_toplevel (Lisp_Object lisp, struct json_configuration *conf) +{ + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + json_t *json = lisp_to_json_toplevel_1 (lisp, conf); + --lisp_eval_depth; + return json; +} + +/* Convert LISP to any JSON object. Signal an error of type + `wrong-type-argument' if the type of LISP can't be converted to a + JSON object. */ + +static json_t * +lisp_to_json (Lisp_Object lisp, struct json_configuration *conf) +{ + if (EQ (lisp, conf->null_object)) + return json_check (json_null ()); + else if (EQ (lisp, conf->false_object)) + return json_check (json_false ()); + else if (EQ (lisp, Qt)) + return json_check (json_true ()); + else if (INTEGERP (lisp)) + { + intmax_t low = TYPE_MINIMUM (json_int_t); + intmax_t high = TYPE_MAXIMUM (json_int_t); + intmax_t value; + if (! integer_to_intmax (lisp, &value) || value < low || high < value) + args_out_of_range_3 (lisp, make_int (low), make_int (high)); + return json_check (json_integer (value)); + } + else if (FLOATP (lisp)) + return json_check (json_real (XFLOAT_DATA (lisp))); + else if (STRINGP (lisp)) + { + Lisp_Object encoded = json_encode (lisp); + json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded)); + if (json == NULL) + { + /* A failure can be caused either by an invalid string or by + low memory. */ + json_check_utf8 (encoded); + json_out_of_memory (); + } + return json; + } + + /* LISP now must be a vector, hashtable, alist, or plist. */ + return lisp_to_json_toplevel (lisp, conf); +} + +static void +json_parse_args (ptrdiff_t nargs, + Lisp_Object *args, + struct json_configuration *conf, + bool configure_object_type) +{ + if ((nargs % 2) != 0) + wrong_type_argument (Qplistp, Flist (nargs, args)); + + /* Start from the back so keyword values appearing + first take precedence. */ + for (ptrdiff_t i = nargs; i > 0; i -= 2) { + Lisp_Object key = args[i - 2]; + Lisp_Object value = args[i - 1]; + if (configure_object_type && EQ (key, QCobject_type)) + { + if (EQ (value, Qhash_table)) + conf->object_type = json_object_hashtable; + else if (EQ (value, Qalist)) + conf->object_type = json_object_alist; + else if (EQ (value, Qplist)) + conf->object_type = json_object_plist; + else + wrong_choice (list3 (Qhash_table, Qalist, Qplist), value); + } + else if (EQ (key, QCnull_object)) + conf->null_object = value; + else if (EQ (key, QCfalse_object)) + conf->false_object = value; + else if (configure_object_type) + wrong_choice (list3 (QCobject_type, + QCnull_object, + QCfalse_object), + value); + else + wrong_choice (list2 (QCnull_object, + QCfalse_object), + value); + } +} + +DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY, + NULL, + doc: /* Return the JSON representation of OBJECT as a string. + +OBJECT must be a vector, hashtable, alist, or plist and its elements +can recursively contain the Lisp equivalents to the JSON null and +false values, t, numbers, strings, or other vectors hashtables, alists +or plists. t will be converted to the JSON true value. Vectors will +be converted to JSON arrays, whereas hashtables, alists and plists are +converted to JSON objects. Hashtable keys must be strings without +embedded null characters and must be unique within each object. Alist +and plist keys must be symbols; if a key is duplicate, the first +instance is used. + +The Lisp equivalents to the JSON null and false values are +configurable in the arguments ARGS, a list of keyword/argument pairs: + +The keyword argument `:null-object' specifies which object to use +to represent a JSON null value. It defaults to `:null'. + +The keyword argument `:false-object' specifies which object to use to +represent a JSON false value. It defaults to `:false'. + +In you specify the same value for `:null-object' and `:false-object', +a potentially ambiguous situation, the JSON output will not contain +any JSON false values. +usage: (json-serialize OBJECT &rest ARGS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + json_parse_args (nargs - 1, args + 1, &conf, false); + + json_t *json = lisp_to_json_toplevel (args[0], &conf); + record_unwind_protect_ptr (json_release_object, json); + + /* If desired, we might want to add the following flags: + JSON_DECODE_ANY, JSON_ALLOW_NUL. */ + char *string = json_dumps (json, JSON_COMPACT); + if (string == NULL) + json_out_of_memory (); + record_unwind_protect_ptr (json_free, string); + + return unbind_to (count, json_build_string (string)); +} + +struct json_buffer_and_size +{ + const char *buffer; + ptrdiff_t size; + /* This tracks how many bytes were inserted by the callback since + json_dump_callback was called. */ + ptrdiff_t inserted_bytes; +}; + +static Lisp_Object +json_insert (void *data) +{ + struct json_buffer_and_size *buffer_and_size = data; + ptrdiff_t len = buffer_and_size->size; + ptrdiff_t inserted_bytes = buffer_and_size->inserted_bytes; + ptrdiff_t gap_size = GAP_SIZE - inserted_bytes; + + /* Enlarge the gap if necessary. */ + if (gap_size < len) + make_gap (len - gap_size); + + /* Copy this chunk of data into the gap. */ + memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + inserted_bytes, + buffer_and_size->buffer, len); + buffer_and_size->inserted_bytes += len; + return Qnil; +} + +struct json_insert_data +{ + /* This tracks how many bytes were inserted by the callback since + json_dump_callback was called. */ + ptrdiff_t inserted_bytes; + /* nil if json_insert succeeded, otherwise the symbol + Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */ + Lisp_Object error; +}; + +/* Callback for json_dump_callback that inserts a JSON representation + as a unibyte string into the gap. DATA must point to a structure + of type json_insert_data. This function may not exit nonlocally. + It catches all nonlocal exits and stores them in data->error for + reraising. */ + +static int +json_insert_callback (const char *buffer, size_t size, void *data) +{ + struct json_insert_data *d = data; + struct json_buffer_and_size buffer_and_size + = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes}; + d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity); + d->inserted_bytes = buffer_and_size.inserted_bytes; + return NILP (d->error) ? 0 : -1; +} + +DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY, + NULL, + doc: /* Insert the JSON representation of OBJECT before point. +This is the same as (insert (json-serialize OBJECT)), but potentially +faster. See the function `json-serialize' for allowed values of +OBJECT. +usage: (json-insert OBJECT &rest ARGS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + json_parse_args (nargs - 1, args + 1, &conf, false); + + json_t *json = lisp_to_json (args[0], &conf); + record_unwind_protect_ptr (json_release_object, json); + + prepare_to_modify_buffer (PT, PT, NULL); + move_gap_both (PT, PT_BYTE); + struct json_insert_data data; + data.inserted_bytes = 0; + /* If desired, we might want to add the following flags: + JSON_DECODE_ANY, JSON_ALLOW_NUL. */ + int status + /* Could have used json_dumpb, but that became available only in + Jansson 2.10, whereas we want to support 2.7 and upward. */ + = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT); + if (status == -1) + { + if (CONSP (data.error)) + xsignal (XCAR (data.error), XCDR (data.error)); + else + json_out_of_memory (); + } + + ptrdiff_t inserted = 0; + ptrdiff_t inserted_bytes = data.inserted_bytes; + if (inserted_bytes > 0) + { + /* Make the inserted text part of the buffer, as unibyte text. */ + GAP_SIZE -= inserted_bytes; + GPT += inserted_bytes; + GPT_BYTE += inserted_bytes; + ZV += inserted_bytes; + ZV_BYTE += inserted_bytes; + Z += inserted_bytes; + Z_BYTE += inserted_bytes; + + if (GAP_SIZE > 0) + /* Put an anchor to ensure multi-byte form ends at gap. */ + *GPT_ADDR = 0; + + /* If required, decode the stuff we've read into the gap. */ + struct coding_system coding; + /* JSON strings are UTF-8 encoded strings. If for some reason + the text returned by the Jansson library includes invalid + byte sequences, they will be represented by raw bytes in the + buffer text. */ + setup_coding_system (Qutf_8_unix, &coding); + coding.dst_multibyte = + !NILP (BVAR (current_buffer, enable_multibyte_characters)); + if (CODING_MAY_REQUIRE_DECODING (&coding)) + { + move_gap_both (PT, PT_BYTE); + GAP_SIZE += inserted_bytes; + ZV_BYTE -= inserted_bytes; + Z_BYTE -= inserted_bytes; + ZV -= inserted_bytes; + Z -= inserted_bytes; + decode_coding_gap (&coding, inserted_bytes, inserted_bytes); + inserted = coding.produced_char; + } + else + { + /* The target buffer is unibyte, so we don't need to decode. */ + invalidate_buffer_caches (current_buffer, + PT, PT + inserted_bytes); + adjust_after_insert (PT, PT_BYTE, + PT + inserted_bytes, + PT_BYTE + inserted_bytes, + inserted_bytes); + inserted = inserted_bytes; + } + } + + /* Call after-change hooks. */ + signal_after_change (PT, 0, inserted); + if (inserted > 0) + { + update_compositions (PT, PT, CHECK_BORDER); + /* Move point to after the inserted text. */ + SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes); + } + + return unbind_to (count, Qnil); +} + +/* Convert a JSON object to a Lisp object. */ + +static Lisp_Object ARG_NONNULL ((1)) +json_to_lisp (json_t *json, struct json_configuration *conf) +{ + switch (json_typeof (json)) + { + case JSON_NULL: + return conf->null_object; + case JSON_FALSE: + return conf->false_object; + case JSON_TRUE: + return Qt; + case JSON_INTEGER: + { + json_int_t i = json_integer_value (json); + return INT_TO_INTEGER (i); + } + case JSON_REAL: + return make_float (json_real_value (json)); + case JSON_STRING: + return json_make_string (json_string_value (json), + json_string_length (json)); + case JSON_ARRAY: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size = json_array_size (json); + if (FIXNUM_OVERFLOW_P (size)) + overflow_error (); + Lisp_Object result = make_vector (size, Qunbound); + for (ptrdiff_t i = 0; i < size; ++i) + ASET (result, i, + json_to_lisp (json_array_get (json, i), conf)); + --lisp_eval_depth; + return result; + } + case JSON_OBJECT: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + Lisp_Object result; + switch (conf->object_type) + { + case json_object_hashtable: + { + size_t size = json_object_size (json); + if (FIXNUM_OVERFLOW_P (size)) + overflow_error (); + result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize, + make_fixed_natnum (size)); + struct Lisp_Hash_Table *h = XHASH_TABLE (result); + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key = json_build_string (key_str); + EMACS_UINT hash; + ptrdiff_t i = hash_lookup (h, key, &hash); + /* Keys in JSON objects are unique, so the key can't + be present yet. */ + eassert (i < 0); + hash_put (h, key, json_to_lisp (value, conf), hash); + } + break; + } + case json_object_alist: + { + result = Qnil; + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key = Fintern (json_build_string (key_str), Qnil); + result + = Fcons (Fcons (key, json_to_lisp (value, conf)), + result); + } + result = Fnreverse (result); + break; + } + case json_object_plist: + { + result = Qnil; + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + USE_SAFE_ALLOCA; + ptrdiff_t key_str_len = strlen (key_str); + char *keyword_key_str = SAFE_ALLOCA (1 + key_str_len + 1); + keyword_key_str[0] = ':'; + strcpy (&keyword_key_str[1], key_str); + Lisp_Object key = intern_1 (keyword_key_str, key_str_len + 1); + /* Build the plist as value-key since we're going to + reverse it in the end.*/ + result = Fcons (key, result); + result = Fcons (json_to_lisp (value, conf), result); + SAFE_FREE (); + } + result = Fnreverse (result); + break; + } + default: + /* Can't get here. */ + emacs_abort (); + } + --lisp_eval_depth; + return result; + } + } + /* Can't get here. */ + emacs_abort (); +} + +DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY, + NULL, + doc: /* Parse the JSON STRING into a Lisp object. + +This is essentially the reverse operation of `json-serialize', which +see. The returned object will be a vector, hashtable, alist, or +plist. Its elements will be the JSON null value, the JSON false +value, t, numbers, strings, or further vectors, hashtables, alists, or +plists. If there are duplicate keys in an object, all but the last +one are ignored. If STRING doesn't contain a valid JSON object, an +error of type `json-parse-error' is signaled. The arguments ARGS are +a list of keyword/argument pairs: + +The keyword argument `:object-type' specifies which Lisp type is used +to represent objects; it can be `hash-table', `alist' or `plist'. + +The keyword argument `:null-object' specifies which object to use +to represent a JSON null value. It defaults to `:null'. + +The keyword argument `:false-object' specifies which object to use to +represent a JSON false value. It defaults to `:false'. +usage: (json-parse-string STRING &rest ARGS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + Lisp_Object string = args[0]; + Lisp_Object encoded = json_encode (string); + check_string_without_embedded_nulls (encoded); + struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + json_parse_args (nargs - 1, args + 1, &conf, true); + + json_error_t error; + json_t *object = json_loads (SSDATA (encoded), 0, &error); + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + if (object != NULL) + record_unwind_protect_ptr (json_release_object, object); + + return unbind_to (count, json_to_lisp (object, &conf)); +} + +struct json_read_buffer_data +{ + /* Byte position of position to read the next chunk from. */ + ptrdiff_t point; +}; + +/* Callback for json_load_callback that reads from the current buffer. + DATA must point to a structure of type json_read_buffer_data. + data->point must point to the byte position to read from; after + reading, data->point is advanced accordingly. The buffer point + itself is ignored. This function may not exit nonlocally. */ + +static size_t +json_read_buffer_callback (void *buffer, size_t buflen, void *data) +{ + struct json_read_buffer_data *d = data; + + /* First, parse from point to the gap or the end of the accessible + portion, whatever is closer. */ + ptrdiff_t point = d->point; + ptrdiff_t end = BUFFER_CEILING_OF (point) + 1; + ptrdiff_t count = end - point; + if (buflen < count) + count = buflen; + memcpy (buffer, BYTE_POS_ADDR (point), count); + d->point += count; + return count; +} + +DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, + 0, MANY, NULL, + doc: /* Read JSON object from current buffer starting at point. +This is similar to `json-parse-string', which see. Move point after +the end of the object if parsing was successful. On error, point is +not moved. +usage: (json-parse-buffer &rest args) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + json_parse_args (nargs, args, &conf, true); + + ptrdiff_t point = PT_BYTE; + struct json_read_buffer_data data = {.point = point}; + json_error_t error; + json_t *object = json_load_callback (json_read_buffer_callback, &data, + JSON_DISABLE_EOF_CHECK, &error); + + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + record_unwind_protect_ptr (json_release_object, object); + + /* Convert and then move point only if everything succeeded. */ + Lisp_Object lisp = json_to_lisp (object, &conf); + + /* Adjust point by how much we just read. */ + point += error.position; + SET_PT_BOTH (BYTE_TO_CHAR (point), point); + + return unbind_to (count, lisp); +} + +/* Simplified version of 'define-error' that works with pure + objects. */ + +static void +define_error (Lisp_Object name, const char *message, Lisp_Object parent) +{ + eassert (SYMBOLP (name)); + eassert (SYMBOLP (parent)); + Lisp_Object parent_conditions = Fget (parent, Qerror_conditions); + eassert (CONSP (parent_conditions)); + eassert (!NILP (Fmemq (parent, parent_conditions))); + eassert (NILP (Fmemq (name, parent_conditions))); + Fput (name, Qerror_conditions, pure_cons (name, parent_conditions)); + Fput (name, Qerror_message, build_pure_c_string (message)); +} + +void +syms_of_json (void) +{ + DEFSYM (QCnull, ":null"); + DEFSYM (QCfalse, ":false"); + + DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p"); + DEFSYM (Qjson_value_p, "json-value-p"); + DEFSYM (Qutf_8_string_p, "utf-8-string-p"); + + DEFSYM (Qjson_error, "json-error"); + DEFSYM (Qjson_out_of_memory, "json-out-of-memory"); + DEFSYM (Qjson_parse_error, "json-parse-error"); + DEFSYM (Qjson_end_of_file, "json-end-of-file"); + DEFSYM (Qjson_trailing_content, "json-trailing-content"); + DEFSYM (Qjson_object_too_deep, "json-object-too-deep"); + define_error (Qjson_error, "generic JSON error", Qerror); + define_error (Qjson_out_of_memory, + "not enough memory for creating JSON object", Qjson_error); + define_error (Qjson_parse_error, "could not parse JSON stream", + Qjson_error); + define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error); + define_error (Qjson_trailing_content, "trailing content after JSON stream", + Qjson_parse_error); + define_error (Qjson_object_too_deep, + "object cyclic or Lisp evaluation too deep", Qjson_error); + + DEFSYM (Qpure, "pure"); + DEFSYM (Qside_effect_free, "side-effect-free"); + + DEFSYM (Qjson_serialize, "json-serialize"); + DEFSYM (Qjson_parse_string, "json-parse-string"); + Fput (Qjson_serialize, Qpure, Qt); + Fput (Qjson_serialize, Qside_effect_free, Qt); + Fput (Qjson_parse_string, Qpure, Qt); + Fput (Qjson_parse_string, Qside_effect_free, Qt); + + DEFSYM (QCobject_type, ":object-type"); + DEFSYM (QCnull_object, ":null-object"); + DEFSYM (QCfalse_object, ":false-object"); + DEFSYM (Qalist, "alist"); + DEFSYM (Qplist, "plist"); + + defsubr (&Sjson_serialize); + defsubr (&Sjson_insert); + defsubr (&Sjson_parse_string); + defsubr (&Sjson_parse_buffer); +} diff --git a/src/keyboard.c b/src/keyboard.c index 49c687f69a8..9e38bb21f6e 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -43,6 +43,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "systime.h" #include "atimer.h" #include "process.h" +#include "menu.h" #include <errno.h> #ifdef HAVE_PTHREAD @@ -91,7 +92,7 @@ volatile int interrupt_input_blocked; The maybe_quit function checks this. */ volatile bool pending_signals; -#define KBD_BUFFER_SIZE 4096 +enum { KBD_BUFFER_SIZE = 4096 }; KBOARD *initial_kboard; KBOARD *current_kboard; @@ -285,15 +286,11 @@ static bool input_was_pending; static union buffered_input_event kbd_buffer[KBD_BUFFER_SIZE]; /* Pointer to next available character in kbd_buffer. - If kbd_fetch_ptr == kbd_store_ptr, the buffer is empty. - This may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the - next available char is in kbd_buffer[0]. */ + If kbd_fetch_ptr == kbd_store_ptr, the buffer is empty. */ static union buffered_input_event *kbd_fetch_ptr; -/* Pointer to next place to store character in kbd_buffer. This - may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the next - character should go in kbd_buffer[0]. */ -static union buffered_input_event *volatile kbd_store_ptr; +/* Pointer to next place to store character in kbd_buffer. */ +static union buffered_input_event *kbd_store_ptr; /* The above pair of variables forms a "queue empty" flag. When we enqueue a non-hook event, we increment kbd_store_ptr. When we @@ -301,8 +298,7 @@ static union buffered_input_event *volatile kbd_store_ptr; there is input available if the two pointers are not equal. Why not just have a flag set and cleared by the enqueuing and - dequeuing functions? Such a flag could be screwed up by interrupts - at inopportune times. */ + dequeuing functions? The code is a bit simpler this way. */ static void recursive_edit_unwind (Lisp_Object buffer); static Lisp_Object command_loop (void); @@ -359,9 +355,7 @@ static Lisp_Object modify_event_symbol (ptrdiff_t, int, Lisp_Object, Lisp_Object *, ptrdiff_t); static Lisp_Object make_lispy_switch_frame (Lisp_Object); static Lisp_Object make_lispy_focus_in (Lisp_Object); -#ifdef HAVE_WINDOW_SYSTEM static Lisp_Object make_lispy_focus_out (Lisp_Object); -#endif /* HAVE_WINDOW_SYSTEM */ static bool help_char_p (Lisp_Object); static void save_getcjmp (sys_jmp_buf); static void restore_getcjmp (sys_jmp_buf); @@ -376,6 +370,29 @@ static void deliver_user_signal (int); static char *find_user_signal_name (int); static void store_user_signal_events (void); +/* Advance or retreat a buffered input event pointer. */ + +static union buffered_input_event * +next_kbd_event (union buffered_input_event *ptr) +{ + return ptr == kbd_buffer + KBD_BUFFER_SIZE - 1 ? kbd_buffer : ptr + 1; +} + +static union buffered_input_event * +prev_kbd_event (union buffered_input_event *ptr) +{ + return ptr == kbd_buffer ? kbd_buffer + KBD_BUFFER_SIZE - 1 : ptr - 1; +} + +/* Like EVENT_START, but assume EVENT is an event. + This pacifies gcc -Wnull-dereference, which might otherwise + complain about earlier checks that EVENT is indeed an event. */ +static Lisp_Object +xevent_start (Lisp_Object event) +{ + return XCAR (XCDR (event)); +} + /* These setters are used only in this file, so they can be private. */ static void kset_echo_string (struct kboard *kb, Lisp_Object val) @@ -433,7 +450,7 @@ static bool echo_keystrokes_p (void) { return (FLOATP (Vecho_keystrokes) ? XFLOAT_DATA (Vecho_keystrokes) > 0.0 - : INTEGERP (Vecho_keystrokes) ? XINT (Vecho_keystrokes) > 0 + : FIXNUMP (Vecho_keystrokes) ? XFIXNUM (Vecho_keystrokes) > 0 : false); } @@ -458,8 +475,8 @@ echo_add_key (Lisp_Object c) /* If someone has passed us a composite event, use its head symbol. */ c = EVENT_HEAD (c); - if (INTEGERP (c)) - ptr = push_key_description (XINT (c), ptr); + if (FIXNUMP (c)) + ptr = push_key_description (XFIXNUM (c), ptr); else if (SYMBOLP (c)) { Lisp_Object name = SYMBOL_NAME (c); @@ -527,13 +544,13 @@ echo_dash (void) { Lisp_Object last_char, prev_char, idx; - idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 2); + idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 2); prev_char = Faref (KVAR (current_kboard, echo_string), idx); - idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 1); + idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 1); last_char = Faref (KVAR (current_kboard, echo_string), idx); - if (XINT (last_char) == '-' && XINT (prev_char) != ' ') + if (XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ') return; } @@ -635,7 +652,7 @@ echo_truncate (ptrdiff_t nchars) if (STRINGP (es) && SCHARS (es) > nchars) kset_echo_string (current_kboard, Fsubstring (KVAR (current_kboard, echo_string), - make_number (0), make_number (nchars))); + make_fixnum (0), make_fixnum (nchars))); truncate_echo_area (nchars); } @@ -778,35 +795,6 @@ recursive_edit_unwind (Lisp_Object buffer) } -#if 0 /* These two functions are now replaced with - temporarily_switch_to_single_kboard. */ -static void -any_kboard_state () -{ -#if 0 /* Theory: if there's anything in Vunread_command_events, - it will right away be read by read_key_sequence, - and then if we do switch KBOARDS, it will go into the side - queue then. So we don't need to do anything special here -- rms. */ - if (CONSP (Vunread_command_events)) - { - current_kboard->kbd_queue - = nconc2 (Vunread_command_events, current_kboard->kbd_queue); - current_kboard->kbd_queue_has_data = true; - } - Vunread_command_events = Qnil; -#endif - single_kboard = false; -} - -/* Switch to the single-kboard state, making current_kboard - the only KBOARD from which further input is accepted. */ - -void -single_kboard_state () -{ - single_kboard = true; -} -#endif /* If we're in single_kboard state for kboard KBOARD, get out of it. */ @@ -905,16 +893,6 @@ temporarily_switch_to_single_kboard (struct frame *f) record_unwind_protect_int (restore_kboard_configuration, was_locked); } -#if 0 /* This function is not needed anymore. */ -void -record_single_kboard_state () -{ - if (single_kboard) - push_kboard (current_kboard); - record_unwind_protect_int (restore_kboard_configuration, single_kboard); -} -#endif - static void restore_kboard_configuration (int was_locked) { @@ -976,7 +954,7 @@ cmd_error (Lisp_Object data) Vquit_flag = Qnil; Vinhibit_quit = Qnil; - return make_number (0); + return make_fixnum (0); } /* Take actions on handling an error. DATA is the data that describes @@ -1036,7 +1014,7 @@ Default value of `command-error-function'. */) print_error_message (data, Qexternal_debugging_output, SSDATA (context), signal); Fterpri (Qexternal_debugging_output, Qnil); - Fkill_emacs (make_number (-1)); + Fkill_emacs (make_fixnum (-1)); } else { @@ -1250,7 +1228,8 @@ some_mouse_moved (void) /* This is the actual command reading loop, sans error-handling encapsulation. */ -static int read_key_sequence (Lisp_Object *, int, Lisp_Object, +enum { READ_KEY_ELTS = 30 }; +static int read_key_sequence (Lisp_Object *, Lisp_Object, bool, bool, bool, bool); static void adjust_point_for_property (ptrdiff_t, bool); @@ -1298,11 +1277,9 @@ command_loop_1 (void) if (!CONSP (last_command_event)) kset_last_repeatable_command (current_kboard, Vreal_this_command); - while (1) + while (true) { Lisp_Object cmd; - Lisp_Object keybuf[30]; - int i; if (! FRAME_LIVE_P (XFRAME (selected_frame))) Fkill_emacs (Qnil); @@ -1349,7 +1326,7 @@ command_loop_1 (void) if (!NILP (Vquit_flag)) { Vquit_flag = Qnil; - Vunread_command_events = list1 (make_number (quit_char)); + Vunread_command_events = list1 (make_fixnum (quit_char)); } } @@ -1365,8 +1342,9 @@ command_loop_1 (void) Vthis_command_keys_shift_translated = Qnil; /* Read next key sequence; i gets its length. */ - i = read_key_sequence (keybuf, ARRAYELTS (keybuf), - Qnil, 0, 1, 1, 0); + raw_keybuf_count = 0; + Lisp_Object keybuf[READ_KEY_ELTS]; + int i = read_key_sequence (keybuf, Qnil, false, true, true, false); /* A filter may have run while we were reading the input. */ if (! FRAME_LIVE_P (XFRAME (selected_frame))) @@ -1556,7 +1534,7 @@ command_loop_1 (void) { Lisp_Object txt = call1 (Fsymbol_value (Qregion_extract_function), Qnil); - if (XINT (Flength (txt)) > 0) + if (XFIXNUM (Flength (txt)) > 0) /* Don't set empty selections. */ call2 (Qgui_set_selection, QPRIMARY, txt); } @@ -1602,16 +1580,14 @@ command_loop_1 (void) Lisp_Object read_menu_command (void) { - Lisp_Object keybuf[30]; ptrdiff_t count = SPECPDL_INDEX (); - int i; /* We don't want to echo the keystrokes while navigating the menus. */ - specbind (Qecho_keystrokes, make_number (0)); + specbind (Qecho_keystrokes, make_fixnum (0)); - i = read_key_sequence (keybuf, ARRAYELTS (keybuf), - Qnil, 0, 1, 1, 1); + Lisp_Object keybuf[READ_KEY_ELTS]; + int i = read_key_sequence (keybuf, Qnil, false, true, true, true); unbind_to (count, Qnil); @@ -1659,7 +1635,7 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) if (check_display && PT > BEGV && PT < ZV && !NILP (val = get_char_property_and_overlay - (make_number (PT), Qdisplay, selected_window, + (make_fixnum (PT), Qdisplay, selected_window, &overlay)) && display_prop_intangible_p (val, overlay, PT, PT_BYTE) && (!OVERLAYP (overlay) @@ -1696,12 +1672,12 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) than skip both boundaries. However, this code also stops anywhere in a non-sticky text-property, which breaks (e.g.) Org mode. */ - && (val = Fget_pos_property (make_number (end), + && (val = Fget_pos_property (make_fixnum (end), Qinvisible, Qnil), TEXT_PROP_MEANS_INVISIBLE (val)) #endif && !NILP (val = get_char_property_and_overlay - (make_number (end), Qinvisible, Qnil, &overlay)) + (make_fixnum (end), Qinvisible, Qnil, &overlay)) && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) { ellipsis = ellipsis || inv > 1 @@ -1709,17 +1685,17 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) && (!NILP (Foverlay_get (overlay, Qafter_string)) || !NILP (Foverlay_get (overlay, Qbefore_string)))); tmp = Fnext_single_char_property_change - (make_number (end), Qinvisible, Qnil, Qnil); - end = NATNUMP (tmp) ? XFASTINT (tmp) : ZV; + (make_fixnum (end), Qinvisible, Qnil, Qnil); + end = FIXNATP (tmp) ? XFIXNAT (tmp) : ZV; } while (beg > BEGV #if 0 - && (val = Fget_pos_property (make_number (beg), + && (val = Fget_pos_property (make_fixnum (beg), Qinvisible, Qnil), TEXT_PROP_MEANS_INVISIBLE (val)) #endif && !NILP (val = get_char_property_and_overlay - (make_number (beg - 1), Qinvisible, Qnil, &overlay)) + (make_fixnum (beg - 1), Qinvisible, Qnil, &overlay)) && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) { ellipsis = ellipsis || inv > 1 @@ -1727,8 +1703,8 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) && (!NILP (Foverlay_get (overlay, Qafter_string)) || !NILP (Foverlay_get (overlay, Qbefore_string)))); tmp = Fprevious_single_char_property_change - (make_number (beg), Qinvisible, Qnil, Qnil); - beg = NATNUMP (tmp) ? XFASTINT (tmp) : BEGV; + (make_fixnum (beg), Qinvisible, Qnil, Qnil); + beg = FIXNATP (tmp) ? XFIXNAT (tmp) : BEGV; } /* Move away from the inside area. */ @@ -1768,11 +1744,11 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) to the other end would mean moving backwards and thus could lead to an infinite loop. */ ; - else if (val = Fget_pos_property (make_number (PT), + else if (val = Fget_pos_property (make_fixnum (PT), Qinvisible, Qnil), TEXT_PROP_MEANS_INVISIBLE (val) && (val = (Fget_pos_property - (make_number (PT == beg ? end : beg), + (make_fixnum (PT == beg ? end : beg), Qinvisible, Qnil)), !TEXT_PROP_MEANS_INVISIBLE (val))) (check_composition = check_display = true, @@ -1869,6 +1845,7 @@ int poll_suppress_count; static struct atimer *poll_timer; +#if defined CYGWIN || defined DOS_NT /* Poll for input, so that we catch a C-g if it comes in. */ void poll_for_input_1 (void) @@ -1877,6 +1854,7 @@ poll_for_input_1 (void) && !waiting_for_input) gobble_input (); } +#endif /* Timer callback function for poll_timer. TIMER is equal to poll_timer. */ @@ -1928,20 +1906,22 @@ start_polling (void) #endif } +#if defined CYGWIN || defined DOS_NT /* True if we are using polling to handle input asynchronously. */ bool input_polling_used (void) { -#ifdef POLL_FOR_INPUT +# ifdef POLL_FOR_INPUT /* XXX This condition was (read_socket_hook && !interrupt_input), but read_socket_hook is not global anymore. Let's pretend that it's always set. */ return !interrupt_input; -#else - return 0; -#endif +# else + return false; +# endif } +#endif /* Turn off polling. */ @@ -1991,7 +1971,7 @@ bind_polling_period (int n) stop_other_atimers (poll_timer); stop_polling (); - specbind (Qpolling_period, make_number (new)); + specbind (Qpolling_period, make_fixnum (new)); /* Start a new alarm with the new period. */ start_polling (); #endif @@ -2170,25 +2150,25 @@ read_event_from_main_queue (struct timespec *end_time, if (single_kboard) goto start; current_kboard = kb; - return make_number (-2); + return make_fixnum (-2); } /* Terminate Emacs in batch mode if at eof. */ - if (noninteractive && INTEGERP (c) && XINT (c) < 0) - Fkill_emacs (make_number (1)); + if (noninteractive && FIXNUMP (c) && XFIXNUM (c) < 0) + Fkill_emacs (make_fixnum (1)); - if (INTEGERP (c)) + if (FIXNUMP (c)) { /* Add in any extra modifiers, where appropriate. */ if ((extra_keyboard_modifiers & CHAR_CTL) || ((extra_keyboard_modifiers & 0177) < ' ' && (extra_keyboard_modifiers & 0177) != 0)) - XSETINT (c, make_ctrl_char (XINT (c))); + XSETINT (c, make_ctrl_char (XFIXNUM (c))); /* Transfer any other modifier bits directly from extra_keyboard_modifiers to c. Ignore the actual character code in the low 16 bits of extra_keyboard_modifiers. */ - XSETINT (c, XINT (c) | (extra_keyboard_modifiers & ~0xff7f & ~CHAR_CTL)); + XSETINT (c, XFIXNUM (c) | (extra_keyboard_modifiers & ~0xff7f & ~CHAR_CTL)); } return c; @@ -2236,8 +2216,8 @@ read_decoded_event_from_main_queue (struct timespec *end_time, int meta_key = terminal->display_info.tty->meta_key; eassert (n < MAX_ENCODED_BYTES); events[n++] = nextevt; - if (NATNUMP (nextevt) - && XINT (nextevt) < (meta_key == 1 ? 0x80 : 0x100)) + if (FIXNATP (nextevt) + && XFIXNUM (nextevt) < (meta_key == 1 ? 0x80 : 0x100)) { /* An encoded byte sequence, let's try to decode it. */ struct coding_system *coding = TERMINAL_KEYBOARD_CODING (terminal); @@ -2247,7 +2227,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time, int i; if (meta_key != 2) for (i = 0; i < n; i++) - events[i] = make_number (XINT (events[i]) & ~0x80); + events[i] = make_fixnum (XFIXNUM (events[i]) & ~0x80); } else { @@ -2255,7 +2235,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time, unsigned char dest[MAX_ENCODED_BYTES * MAX_MULTIBYTE_LENGTH]; int i; for (i = 0; i < n; i++) - src[i] = XINT (events[i]); + src[i] = XFIXNUM (events[i]); if (meta_key != 2) for (i = 0; i < n; i++) src[i] &= ~0x80; @@ -2274,7 +2254,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time, eassert (coding->carryover_bytes == 0); n = 0; while (n < coding->produced_char) - events[n++] = make_number (STRING_CHAR_ADVANCE (p)); + events[n++] = make_fixnum (STRING_CHAR_ADVANCE (p)); } } } @@ -2352,7 +2332,7 @@ read_char (int commandflag, Lisp_Object map, /* Undo what read_char_x_menu_prompt did when it unread additional keys returned by Fx_popup_menu. */ if (CONSP (c) - && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))) + && (SYMBOLP (XCAR (c)) || FIXNUMP (XCAR (c))) && NILP (XCDR (c))) c = XCAR (c); @@ -2382,7 +2362,7 @@ read_char (int commandflag, Lisp_Object map, additional keys returned by Fx_popup_menu. */ if (CONSP (c) && EQ (XCDR (c), Qdisabled) - && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c)))) + && (SYMBOLP (XCAR (c)) || FIXNUMP (XCAR (c)))) { was_disabled = true; c = XCAR (c); @@ -2407,7 +2387,7 @@ read_char (int commandflag, Lisp_Object map, /* Undo what read_char_x_menu_prompt did when it unread additional keys returned by Fx_popup_menu. */ if (CONSP (c) - && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))) + && (SYMBOLP (XCAR (c)) || FIXNUMP (XCAR (c))) && NILP (XCDR (c))) c = XCAR (c); reread = true; @@ -2432,16 +2412,16 @@ read_char (int commandflag, Lisp_Object map, Also, some things replace the macro with t to force an early exit. */ if (EQ (Vexecuting_kbd_macro, Qt) - || executing_kbd_macro_index >= XFASTINT (Flength (Vexecuting_kbd_macro))) + || executing_kbd_macro_index >= XFIXNAT (Flength (Vexecuting_kbd_macro))) { XSETINT (c, -1); goto exit; } - c = Faref (Vexecuting_kbd_macro, make_number (executing_kbd_macro_index)); + c = Faref (Vexecuting_kbd_macro, make_fixnum (executing_kbd_macro_index)); if (STRINGP (Vexecuting_kbd_macro) - && (XFASTINT (c) & 0x80) && (XFASTINT (c) <= 0xff)) - XSETFASTINT (c, CHAR_META | (XFASTINT (c) & ~0x80)); + && (XFIXNAT (c) & 0x80) && (XFIXNAT (c) <= 0xff)) + XSETFASTINT (c, CHAR_META | (XFIXNAT (c) & ~0x80)); executing_kbd_macro_index++; @@ -2545,7 +2525,7 @@ read_char (int commandflag, Lisp_Object map, { c = read_char_minibuf_menu_prompt (commandflag, map); - if (INTEGERP (c) && XINT (c) == -2) + if (FIXNUMP (c) && XFIXNUM (c) == -2) return c; /* wrong_kboard_jmpbuf */ if (! NILP (c)) @@ -2596,7 +2576,7 @@ read_char (int commandflag, Lisp_Object map, XSETCDR (last, list1 (c)); kb->kbd_queue_has_data = true; current_kboard = kb; - return make_number (-2); /* wrong_kboard_jmpbuf */ + return make_fixnum (-2); /* wrong_kboard_jmpbuf */ } } goto non_reread; @@ -2655,7 +2635,7 @@ read_char (int commandflag, Lisp_Object map, && num_nonmacro_input_events - last_auto_save > max (auto_save_interval, 20) && !detect_input_pending_run_timers (0)) { - Fdo_auto_save (Qnil, Qnil); + Fdo_auto_save (auto_save_no_message ? Qt : Qnil, Qnil); /* Hooks can actually change some buffers in auto save. */ redisplay (); } @@ -2704,23 +2684,23 @@ read_char (int commandflag, Lisp_Object map, /* Auto save if enough time goes by without input. */ if (commandflag != 0 && commandflag != -2 && num_nonmacro_input_events > last_auto_save - && INTEGERP (Vauto_save_timeout) - && XINT (Vauto_save_timeout) > 0) + && FIXNUMP (Vauto_save_timeout) + && XFIXNUM (Vauto_save_timeout) > 0) { Lisp_Object tem0; - EMACS_INT timeout = XFASTINT (Vauto_save_timeout); + EMACS_INT timeout = XFIXNAT (Vauto_save_timeout); timeout = min (timeout, MOST_POSITIVE_FIXNUM / delay_level * 4); timeout = delay_level * timeout / 4; save_getcjmp (save_jump); restore_getcjmp (local_getcjmp); - tem0 = sit_for (make_number (timeout), 1, 1); + tem0 = sit_for (make_fixnum (timeout), 1, 1); restore_getcjmp (save_jump); if (EQ (tem0, Qt) && ! CONSP (Vunread_command_events)) { - Fdo_auto_save (Qnil, Qnil); + Fdo_auto_save (auto_save_no_message ? Qt : Qnil, Qnil); redisplay (); } } @@ -2738,7 +2718,7 @@ read_char (int commandflag, Lisp_Object map, interpret the next key sequence using the wrong translation tables and function keymaps. */ if (NILP (c) && current_kboard != orig_kboard) - return make_number (-2); /* wrong_kboard_jmpbuf */ + return make_fixnum (-2); /* wrong_kboard_jmpbuf */ /* If this has become non-nil here, it has been set by a timer or sentinel or filter. */ @@ -2789,7 +2769,7 @@ read_char (int commandflag, Lisp_Object map, if (kb->kbd_queue_has_data) { current_kboard = kb; - return make_number (-2); /* wrong_kboard_jmpbuf */ + return make_fixnum (-2); /* wrong_kboard_jmpbuf */ } } @@ -2807,7 +2787,7 @@ read_char (int commandflag, Lisp_Object map, goto exit; } - if (EQ (c, make_number (-2))) + if (EQ (c, make_fixnum (-2))) return c; if (CONSP (c) && EQ (XCAR (c), Qt)) @@ -2850,12 +2830,16 @@ read_char (int commandflag, Lisp_Object map, if (CONSP (c) && (EQ (XCAR (c), Qselect_window) + || EQ (XCAR (c), Qfocus_out) #ifdef HAVE_DBUS || EQ (XCAR (c), Qdbus_event) #endif #ifdef USE_FILE_NOTIFY || EQ (XCAR (c), Qfile_notify) #endif +#ifdef THREADS_ENABLED + || EQ (XCAR (c), Qthread_event) +#endif || EQ (XCAR (c), Qconfig_changed_event)) && !end_time) /* We stopped being idle for this event; undo that. This @@ -2869,7 +2853,7 @@ read_char (int commandflag, Lisp_Object map, /* The command may have changed the keymaps. Pretend there is input in another keyboard and return. This will recalculate keymaps. */ - c = make_number (-2); + c = make_fixnum (-2); goto exit; } else @@ -2877,18 +2861,18 @@ read_char (int commandflag, Lisp_Object map, } /* Handle things that only apply to characters. */ - if (INTEGERP (c)) + if (FIXNUMP (c)) { /* If kbd_buffer_get_event gave us an EOF, return that. */ - if (XINT (c) == -1) + if (XFIXNUM (c) == -1) goto exit; if ((STRINGP (KVAR (current_kboard, Vkeyboard_translate_table)) - && UNSIGNED_CMP (XFASTINT (c), <, + && UNSIGNED_CMP (XFIXNAT (c), <, SCHARS (KVAR (current_kboard, Vkeyboard_translate_table)))) || (VECTORP (KVAR (current_kboard, Vkeyboard_translate_table)) - && UNSIGNED_CMP (XFASTINT (c), <, + && UNSIGNED_CMP (XFIXNAT (c), <, ASIZE (KVAR (current_kboard, Vkeyboard_translate_table)))) || (CHAR_TABLE_P (KVAR (current_kboard, Vkeyboard_translate_table)) @@ -2907,18 +2891,18 @@ read_char (int commandflag, Lisp_Object map, so we won't do this twice, then queue it up. */ if (EVENT_HAS_PARAMETERS (c) && CONSP (XCDR (c)) - && CONSP (EVENT_START (c)) - && CONSP (XCDR (EVENT_START (c)))) + && CONSP (xevent_start (c)) + && CONSP (XCDR (xevent_start (c)))) { Lisp_Object posn; - posn = POSN_POSN (EVENT_START (c)); + posn = POSN_POSN (xevent_start (c)); /* Handle menu-bar events: insert the dummy prefix event `menu-bar'. */ if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar)) { /* Change menu-bar to (menu-bar) as the event "position". */ - POSN_SET_POSN (EVENT_START (c), list1 (posn)); + POSN_SET_POSN (xevent_start (c), list1 (posn)); also_record = c; Vunread_command_events = Fcons (c, Vunread_command_events); @@ -2936,9 +2920,9 @@ read_char (int commandflag, Lisp_Object map, /* Wipe the echo area. But first, if we are about to use an input method, save the echo area contents for it to refer to. */ - if (INTEGERP (c) + if (FIXNUMP (c) && ! NILP (Vinput_method_function) - && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127) + && ' ' <= XFIXNUM (c) && XFIXNUM (c) < 256 && XFIXNUM (c) != 127) { previous_echo_area_message = Fcurrent_message (); Vinput_method_previous_message = previous_echo_area_message; @@ -2963,12 +2947,12 @@ read_char (int commandflag, Lisp_Object map, reread_for_input_method: from_macro: /* Pass this to the input method, if appropriate. */ - if (INTEGERP (c) + if (FIXNUMP (c) && ! NILP (Vinput_method_function) /* Don't run the input method within a key sequence, after the first event of the key sequence. */ && NILP (prev_event) - && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127) + && ' ' <= XFIXNUM (c) && XFIXNUM (c) < 256 && XFIXNUM (c) != 127) { Lisp_Object keys; ptrdiff_t key_count; @@ -3119,7 +3103,7 @@ read_char (int commandflag, Lisp_Object map, unbind_to (count, Qnil); redisplay (); - if (EQ (c, make_number (040))) + if (EQ (c, make_fixnum (040))) { cancel_echoing (); do @@ -3178,6 +3162,10 @@ help_char_p (Lisp_Object c) static void record_char (Lisp_Object c) { + /* quail.el binds this to avoid recording keys twice. */ + if (inhibit_record_char) + return; + int recorded = 0; if (CONSP (c) && (EQ (XCAR (c), Qhelp_echo) || EQ (XCAR (c), Qmouse_movement))) @@ -3252,7 +3240,10 @@ record_char (Lisp_Object c) if (!recorded) { total_keys += total_keys < NUM_RECENT_KEYS; - ASET (recent_keys, recent_keys_index, c); + ASET (recent_keys, recent_keys_index, + /* Copy the event, in case it gets modified by side-effect + by some remapping function (bug#30955). */ + CONSP (c) ? Fcopy_sequence (c) : c); if (++recent_keys_index >= NUM_RECENT_KEYS) recent_keys_index = 0; } @@ -3281,15 +3272,15 @@ record_char (Lisp_Object c) /* Write c to the dribble file. If c is a lispy event, write the event's symbol to the dribble file, in <brackets>. Bleaugh. If you, dear reader, have a better idea, you've got the source. :-) */ - if (dribble) + if (dribble && NILP (Vexecuting_kbd_macro)) { block_input (); - if (INTEGERP (c)) + if (FIXNUMP (c)) { - if (XUINT (c) < 0x100) - putc_unlocked (XUINT (c), dribble); + if (XUFIXNUM (c) < 0x100) + putc_unlocked (XUFIXNUM (c), dribble); else - fprintf (dribble, " 0x%"pI"x", XUINT (c)); + fprintf (dribble, " 0x%"pI"x", XUFIXNUM (c)); } else { @@ -3342,7 +3333,7 @@ readable_events (int flags) if (flags & READABLE_EVENTS_DO_TIMERS_NOW) timer_check (); - /* If the buffer contains only FOCUS_IN_EVENT events, and + /* If the buffer contains only FOCUS_IN/OUT_EVENT events, and READABLE_EVENTS_FILTER_EVENTS is set, report it as empty. */ if (kbd_fetch_ptr != kbd_store_ptr) { @@ -3356,13 +3347,12 @@ readable_events (int flags) do { - if (event == kbd_buffer + KBD_BUFFER_SIZE) - event = kbd_buffer; if (!( #ifdef USE_TOOLKIT_SCROLL_BARS (flags & READABLE_EVENTS_FILTER_EVENTS) && #endif - event->kind == FOCUS_IN_EVENT) + (event->kind == FOCUS_IN_EVENT + || event->kind == FOCUS_OUT_EVENT)) #ifdef USE_TOOLKIT_SCROLL_BARS && !((flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) && (event->kind == SCROLL_BAR_CLICK_EVENT @@ -3373,7 +3363,7 @@ readable_events (int flags) && !((flags & READABLE_EVENTS_FILTER_EVENTS) && event->kind == BUFFER_SWITCH_EVENT)) return 1; - event++; + event = next_kbd_event (event); } while (event != kbd_store_ptr); } @@ -3427,12 +3417,8 @@ event_to_kboard (struct input_event *event) static int kbd_buffer_nr_stored (void) { - return kbd_fetch_ptr == kbd_store_ptr - ? 0 - : (kbd_fetch_ptr < kbd_store_ptr - ? kbd_store_ptr - kbd_fetch_ptr - : ((kbd_buffer + KBD_BUFFER_SIZE) - kbd_fetch_ptr - + (kbd_store_ptr - kbd_buffer))); + int n = kbd_store_ptr - kbd_fetch_ptr; + return n + (n < 0 ? KBD_BUFFER_SIZE : 0); } #endif /* Store an event obtained at interrupt level into kbd_buffer, fifo */ @@ -3481,14 +3467,12 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, { kset_kbd_queue (kb, list2 (make_lispy_switch_frame (event->ie.frame_or_window), - make_number (c))); + make_fixnum (c))); kb->kbd_queue_has_data = true; - union buffered_input_event *sp; - for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++) - { - if (sp == kbd_buffer + KBD_BUFFER_SIZE) - sp = kbd_buffer; + for (union buffered_input_event *sp = kbd_fetch_ptr; + sp != kbd_store_ptr; sp = next_kbd_event (sp)) + { if (event_to_kboard (&sp->ie) == kb) { sp->ie.kind = NO_EVENT; @@ -3533,22 +3517,18 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, Just ignore the second one. */ else if (event->kind == BUFFER_SWITCH_EVENT && kbd_fetch_ptr != kbd_store_ptr - && ((kbd_store_ptr == kbd_buffer - ? kbd_buffer + KBD_BUFFER_SIZE - 1 - : kbd_store_ptr - 1)->kind) == BUFFER_SWITCH_EVENT) + && prev_kbd_event (kbd_store_ptr)->kind == BUFFER_SWITCH_EVENT) return; - if (kbd_store_ptr - kbd_buffer == KBD_BUFFER_SIZE) - kbd_store_ptr = kbd_buffer; - /* Don't let the very last slot in the buffer become full, since that would make the two pointers equal, and that is indistinguishable from an empty buffer. Discard the event if it would fill the last slot. */ - if (kbd_fetch_ptr - 1 != kbd_store_ptr) + union buffered_input_event *next_slot = next_kbd_event (kbd_store_ptr); + if (kbd_fetch_ptr != next_slot) { *kbd_store_ptr = *event; - ++kbd_store_ptr; + kbd_store_ptr = next_slot; #ifdef subprocesses if (kbd_buffer_nr_stored () > KBD_BUFFER_SIZE / 2 && ! kbd_on_hold_p ()) @@ -3591,11 +3571,8 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, void kbd_buffer_unget_event (struct selection_input_event *event) { - if (kbd_fetch_ptr == kbd_buffer) - kbd_fetch_ptr = kbd_buffer + KBD_BUFFER_SIZE; - /* Don't let the very last slot in the buffer become full, */ - union buffered_input_event *kp = kbd_fetch_ptr - 1; + union buffered_input_event *kp = prev_kbd_event (kbd_fetch_ptr); if (kp != kbd_store_ptr) { kp->sie = *event; @@ -3683,12 +3660,9 @@ kbd_buffer_store_help_event (Lisp_Object frame, Lisp_Object help) void discard_mouse_events (void) { - union buffered_input_event *sp; - for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++) + for (union buffered_input_event *sp = kbd_fetch_ptr; + sp != kbd_store_ptr; sp = next_kbd_event (sp)) { - if (sp == kbd_buffer + KBD_BUFFER_SIZE) - sp = kbd_buffer; - if (sp->kind == MOUSE_CLICK_EVENT || sp->kind == WHEEL_EVENT || sp->kind == HORIZ_WHEEL_EVENT @@ -3713,25 +3687,20 @@ discard_mouse_events (void) bool kbd_buffer_events_waiting (void) { - union buffered_input_event *sp; - - for (sp = kbd_fetch_ptr; - sp != kbd_store_ptr && sp->kind == NO_EVENT; - ++sp) - { - if (sp == kbd_buffer + KBD_BUFFER_SIZE) - sp = kbd_buffer; - } - - kbd_fetch_ptr = sp; - return sp != kbd_store_ptr && sp->kind != NO_EVENT; + for (union buffered_input_event *sp = kbd_fetch_ptr; + ; sp = next_kbd_event (sp)) + if (sp == kbd_store_ptr || sp->kind != NO_EVENT) + { + kbd_fetch_ptr = sp; + return sp != kbd_store_ptr && sp->kind != NO_EVENT; + } } /* Clear input event EVENT. */ static void -clear_event (union buffered_input_event *event) +clear_event (struct input_event *event) { event->kind = NO_EVENT; } @@ -3761,7 +3730,7 @@ kbd_buffer_get_event (KBOARD **kbp, } #endif /* subprocesses */ -#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY +#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY && !defined THREADS_ENABLED if (noninteractive /* In case we are running as a daemon, only do this before detaching from the terminal. */ @@ -3772,7 +3741,7 @@ kbd_buffer_get_event (KBOARD **kbp, *kbp = current_kboard; return obj; } -#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY */ +#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY && !defined THREADS_ENABLED */ /* Wait until there is input available. */ for (;;) @@ -3853,11 +3822,7 @@ kbd_buffer_get_event (KBOARD **kbp, mouse movement enabled and available. */ if (kbd_fetch_ptr != kbd_store_ptr) { - union buffered_input_event *event; - - event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE) - ? kbd_fetch_ptr - : kbd_buffer); + union buffered_input_event *event = kbd_fetch_ptr; *kbp = event_to_kboard (&event->ie); if (*kbp == 0) @@ -3868,15 +3833,17 @@ kbd_buffer_get_event (KBOARD **kbp, /* These two kinds of events get special handling and don't actually appear to the command loop. We return nil for them. */ - if (event->kind == SELECTION_REQUEST_EVENT - || event->kind == SELECTION_CLEAR_EVENT) + switch (event->kind) + { + case SELECTION_REQUEST_EVENT: + case SELECTION_CLEAR_EVENT: { #ifdef HAVE_X11 /* Remove it from the buffer before processing it, since otherwise swallow_events will see it and process it again. */ struct selection_input_event copy = event->sie; - kbd_fetch_ptr = event + 1; + kbd_fetch_ptr = next_kbd_event (event); input_pending = readable_events (0); x_handle_selection_event (©); #else @@ -3885,202 +3852,61 @@ kbd_buffer_get_event (KBOARD **kbp, emacs_abort (); #endif } + break; -#if defined (HAVE_NS) - else if (event->kind == NS_TEXT_EVENT) - { - if (event->ie.code == KEY_NS_PUT_WORKING_TEXT) - obj = list1 (intern ("ns-put-working-text")); - else - obj = list1 (intern ("ns-unput-working-text")); - kbd_fetch_ptr = event + 1; - if (used_mouse_menu) - *used_mouse_menu = true; - } -#endif - -#if defined (HAVE_X11) || defined (HAVE_NTGUI) \ - || defined (HAVE_NS) - else if (event->kind == DELETE_WINDOW_EVENT) - { - /* Make an event (delete-frame (FRAME)). */ - obj = list2 (Qdelete_frame, list1 (event->ie.frame_or_window)); - 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) - { - /* Make an event (iconify-frame (FRAME)). */ - obj = list2 (Qiconify_frame, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } - else if (event->kind == DEICONIFY_EVENT) - { - /* Make an event (make-frame-visible (FRAME)). */ - obj = list2 (Qmake_frame_visible, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } -#endif - else if (event->kind == BUFFER_SWITCH_EVENT) - { - /* The value doesn't matter here; only the type is tested. */ - XSETBUFFER (obj, current_buffer); - kbd_fetch_ptr = event + 1; - } #if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ || defined (HAVE_NS) || defined (USE_GTK) - else if (event->kind == MENU_BAR_ACTIVATE_EVENT) + case MENU_BAR_ACTIVATE_EVENT: { - kbd_fetch_ptr = event + 1; + kbd_fetch_ptr = next_kbd_event (event); input_pending = readable_events (0); if (FRAME_LIVE_P (XFRAME (event->ie.frame_or_window))) x_activate_menubar (XFRAME (event->ie.frame_or_window)); } + break; +#endif +#if defined (HAVE_NS) + case NS_TEXT_EVENT: + if (used_mouse_menu) + *used_mouse_menu = true; + FALLTHROUGH; #endif #ifdef HAVE_NTGUI - else if (event->kind == LANGUAGE_CHANGE_EVENT) - { - /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */ - obj = list4 (Qlanguage_change, - event->ie.frame_or_window, - make_number (event->ie.code), - make_number (event->ie.modifiers)); - kbd_fetch_ptr = event + 1; - } + case END_SESSION_EVENT: + case LANGUAGE_CHANGE_EVENT: #endif -#ifdef USE_FILE_NOTIFY - else if (event->kind == FILE_NOTIFY_EVENT) - { -#ifdef HAVE_W32NOTIFY - /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */ - obj = list3 (Qfile_notify, event->ie.arg, event->ie.frame_or_window); -#else - obj = make_lispy_event (&event->ie); +#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS) + case DELETE_WINDOW_EVENT: + case ICONIFY_EVENT: + case DEICONIFY_EVENT: + case MOVE_FRAME_EVENT: #endif - kbd_fetch_ptr = event + 1; - } -#endif /* USE_FILE_NOTIFY */ - else if (event->kind == SAVE_SESSION_EVENT) - { - obj = list2 (Qsave_session, event->ie.arg); - kbd_fetch_ptr = event + 1; - } - /* Just discard these, by returning nil. - With MULTI_KBOARD, these events are used as placeholders - when we need to randomly delete events from the queue. - (They shouldn't otherwise be found in the buffer, - but on some machines it appears they do show up - even without MULTI_KBOARD.) */ - /* On Windows NT/9X, NO_EVENT is used to delete extraneous - mouse events during a popup-menu call. */ - else if (event->kind == NO_EVENT) - kbd_fetch_ptr = event + 1; - else if (event->kind == HELP_EVENT) - { - Lisp_Object object, position, help, frame, window; - - frame = event->ie.frame_or_window; - object = event->ie.arg; - position = make_number (Time_to_position (event->ie.timestamp)); - window = event->ie.x; - help = event->ie.y; - clear_event (event); - - kbd_fetch_ptr = event + 1; - if (!WINDOWP (window)) - window = Qnil; - obj = Fcons (Qhelp_echo, - list5 (frame, help, window, object, position)); - } - else if (event->kind == FOCUS_IN_EVENT) - { - /* Notification of a FocusIn event. The frame receiving the - focus is in event->frame_or_window. Generate a - switch-frame event if necessary. */ - Lisp_Object frame, focus; - - frame = event->ie.frame_or_window; - focus = FRAME_FOCUS_FRAME (XFRAME (frame)); - if (FRAMEP (focus)) - frame = focus; - - if ( -#ifdef HAVE_X11 - ! NILP (event->ie.arg) - && +#ifdef USE_FILE_NOTIFY + case FILE_NOTIFY_EVENT: #endif - !EQ (frame, internal_last_event_frame) - && !EQ (frame, selected_frame)) - obj = make_lispy_switch_frame (frame); - else - obj = make_lispy_focus_in (frame); - - internal_last_event_frame = frame; - kbd_fetch_ptr = event + 1; - } - else if (event->kind == FOCUS_OUT_EVENT) - { -#ifdef HAVE_WINDOW_SYSTEM - - Display_Info *di; - Lisp_Object frame = event->ie.frame_or_window; - bool focused = false; - - for (di = x_display_list; di && ! focused; di = di->next) - focused = di->x_highlight_frame != 0; - - if (!focused) - obj = make_lispy_focus_out (frame); - -#endif /* HAVE_WINDOW_SYSTEM */ - - kbd_fetch_ptr = event + 1; - } #ifdef HAVE_DBUS - else if (event->kind == DBUS_EVENT) - { - obj = make_lispy_event (&event->ie); - kbd_fetch_ptr = event + 1; - } + case DBUS_EVENT: #endif -#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS) - else if (event->kind == MOVE_FRAME_EVENT) - { - /* Make an event (move-frame (FRAME)). */ - obj = list2 (Qmove_frame, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } +#ifdef THREADS_ENABLED + case THREAD_EVENT: #endif #ifdef HAVE_XWIDGETS - else if (event->kind == XWIDGET_EVENT) - { - obj = make_lispy_event (&event->ie); - kbd_fetch_ptr = event + 1; - } + case XWIDGET_EVENT: #endif - else if (event->kind == CONFIG_CHANGED_EVENT) - { - obj = make_lispy_event (&event->ie); - kbd_fetch_ptr = event + 1; - } - else if (event->kind == SELECT_WINDOW_EVENT) - { - obj = list2 (Qselect_window, list1 (event->ie.frame_or_window)); - kbd_fetch_ptr = event + 1; - } - else + case BUFFER_SWITCH_EVENT: + case SAVE_SESSION_EVENT: + case NO_EVENT: + case HELP_EVENT: + case FOCUS_IN_EVENT: + case CONFIG_CHANGED_EVENT: + case FOCUS_OUT_EVENT: + case SELECT_WINDOW_EVENT: + { + obj = make_lispy_event (&event->ie); + kbd_fetch_ptr = next_kbd_event (event); + } + break; + default: { /* If this event is on a different frame, return a switch-frame this time, and leave the event in the queue for next time. */ @@ -4130,10 +3956,11 @@ kbd_buffer_get_event (KBOARD **kbp, #endif /* Wipe out this event, to catch bugs. */ - clear_event (event); - kbd_fetch_ptr = event + 1; + clear_event (&event->ie); + kbd_fetch_ptr = next_kbd_event (event); } } + } } /* Try generating a mouse motion event. */ else if (!NILP (do_mouse_tracking) && some_mouse_moved ()) @@ -4197,17 +4024,9 @@ kbd_buffer_get_event (KBOARD **kbp, static void process_special_events (void) { - union buffered_input_event *event; - - for (event = kbd_fetch_ptr; event != kbd_store_ptr; ++event) + for (union buffered_input_event *event = kbd_fetch_ptr; + event != kbd_store_ptr; event = next_kbd_event (event)) { - if (event == kbd_buffer + KBD_BUFFER_SIZE) - { - event = kbd_buffer; - if (event == kbd_store_ptr) - break; - } - /* If we find a stored X selection request, handle it now. */ if (event->kind == SELECTION_REQUEST_EVENT || event->kind == SELECTION_CLEAR_EVENT) @@ -4221,28 +4040,21 @@ process_special_events (void) cyclically. */ struct selection_input_event copy = event->sie; - union buffered_input_event *beg - = (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) - ? kbd_buffer : kbd_fetch_ptr; + int moved_events; - if (event > beg) - memmove (beg + 1, beg, (event - beg) * sizeof *beg); - else if (event < beg) + if (event < kbd_fetch_ptr) { - if (event > kbd_buffer) - memmove (kbd_buffer + 1, kbd_buffer, - (event - kbd_buffer) * sizeof *kbd_buffer); - *kbd_buffer = *(kbd_buffer + KBD_BUFFER_SIZE - 1); - if (beg < kbd_buffer + KBD_BUFFER_SIZE - 1) - memmove (beg + 1, beg, - (kbd_buffer + KBD_BUFFER_SIZE - 1 - beg) * sizeof *beg); + memmove (kbd_buffer + 1, kbd_buffer, + (event - kbd_buffer) * sizeof *kbd_buffer); + kbd_buffer[0] = kbd_buffer[KBD_BUFFER_SIZE - 1]; + moved_events = kbd_buffer + KBD_BUFFER_SIZE - 1 - kbd_fetch_ptr; } - - if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) - kbd_fetch_ptr = kbd_buffer + 1; else - kbd_fetch_ptr++; + moved_events = event - kbd_fetch_ptr; + memmove (kbd_fetch_ptr + 1, kbd_fetch_ptr, + moved_events * sizeof *kbd_fetch_ptr); + kbd_fetch_ptr = next_kbd_event (kbd_fetch_ptr); input_pending = readable_events (0); x_handle_selection_event (©); #else @@ -4319,18 +4131,13 @@ decode_timer (Lisp_Object timer, struct timespec *result) Lisp_Object *vec; if (! (VECTORP (timer) && ASIZE (timer) == 9)) - return 0; + return false; vec = XVECTOR (timer)->contents; if (! NILP (vec[0])) - return 0; - if (! INTEGERP (vec[2])) return false; - - struct lisp_time t; - if (decode_time_components (vec[1], vec[2], vec[3], vec[8], &t, 0) <= 0) + if (! FIXNUMP (vec[2])) return false; - *result = lisp_to_timespec (t); - return timespec_valid_p (*result); + return list4_to_timespec (vec[1], vec[2], vec[3], vec[8], result); } @@ -4534,8 +4341,8 @@ timer_check (void) DEFUN ("current-idle-time", Fcurrent_idle_time, Scurrent_idle_time, 0, 0, 0, doc: /* Return the current length of Emacs idleness, or nil. -The value when Emacs is idle is a list of four integers (HIGH LOW USEC PSEC) -in the same style as (current-time). +The value when Emacs is idle is a Lisp timestamp in the style of +`current-time'. The value when Emacs is not idle is nil. @@ -5176,7 +4983,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, int xret = 0, yret = 0; /* The window or frame under frame pixel coordinates (x,y) */ Lisp_Object window_or_frame = f - ? window_from_coordinates (f, XINT (x), XINT (y), &part, 0) + ? window_from_coordinates (f, XFIXNUM (x), XFIXNUM (y), &part, 0) : Qnil; if (WINDOWP (window_or_frame)) @@ -5191,15 +4998,15 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, Lisp_Object object = Qnil; /* Pixel coordinates relative to the window corner. */ - int wx = XINT (x) - WINDOW_LEFT_EDGE_X (w); - int wy = XINT (y) - WINDOW_TOP_EDGE_Y (w); + int wx = XFIXNUM (x) - WINDOW_LEFT_EDGE_X (w); + int wy = XFIXNUM (y) - WINDOW_TOP_EDGE_Y (w); /* For text area clicks, return X, Y relative to the corner of this text area. Note that dX, dY etc are set below, by buffer_posn_from_coords. */ if (part == ON_TEXT) { - xret = XINT (x) - window_box_left (w, TEXT_AREA); + xret = XFIXNUM (x) - window_box_left (w, TEXT_AREA); yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); } /* For mode line and header line clicks, return X, Y relative to @@ -5218,7 +5025,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, string = mode_line_string (w, part, &col, &row, &charpos, &object, &dx, &dy, &width, &height); if (STRINGP (string)) - string_info = Fcons (string, make_number (charpos)); + string_info = Fcons (string, make_fixnum (charpos)); textpos = -1; xret = wx; @@ -5237,7 +5044,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, string = marginal_area_string (w, part, &col, &row, &charpos, &object, &dx, &dy, &width, &height); if (STRINGP (string)) - string_info = Fcons (string, make_number (charpos)); + string_info = Fcons (string, make_fixnum (charpos)); xret = wx; yret = wy - WINDOW_HEADER_LINE_HEIGHT (w); } @@ -5319,7 +5126,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, : (part == ON_RIGHT_FRINGE || part == ON_RIGHT_MARGIN || (part == ON_VERTICAL_SCROLL_BAR && WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_RIGHT (w))) - ? (XINT (x) - window_box_left (w, TEXT_AREA)) + ? (XFIXNUM (x) - window_box_left (w, TEXT_AREA)) : 0; int y2 = wy; @@ -5336,10 +5143,10 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, if (NILP (posn)) { - posn = make_number (textpos); + posn = make_fixnum (textpos); if (STRINGP (string2)) string_info = Fcons (string2, - make_number (CHARPOS (p.string_pos))); + make_fixnum (CHARPOS (p.string_pos))); } if (NILP (object)) object = object2; @@ -5361,14 +5168,14 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, /* Object info. */ extra_info = list3 (object, - Fcons (make_number (dx), make_number (dy)), - Fcons (make_number (width), make_number (height))); + Fcons (make_fixnum (dx), make_fixnum (dy)), + Fcons (make_fixnum (width), make_fixnum (height))); /* String info. */ extra_info = Fcons (string_info, - Fcons (textpos < 0 ? Qnil : make_number (textpos), - Fcons (Fcons (make_number (col), - make_number (row)), + Fcons (textpos < 0 ? Qnil : make_fixnum (textpos), + Fcons (Fcons (make_fixnum (col), + make_fixnum (row)), extra_info))); } @@ -5377,8 +5184,8 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, { /* Return mouse pixel coordinates here. */ XSETFRAME (window_or_frame, f); - xret = XINT (x); - yret = XINT (y); + xret = XFIXNUM (x); + yret = XFIXNUM (y); if (FRAME_LIVE_P (f) && FRAME_INTERNAL_BORDER_WIDTH (f) > 0 @@ -5397,9 +5204,9 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, return Fcons (window_or_frame, Fcons (posn, - Fcons (Fcons (make_number (xret), - make_number (yret)), - Fcons (make_number (t), + Fcons (Fcons (make_fixnum (xret), + make_fixnum (yret)), + Fcons (make_fixnum (t), extra_info)))); } @@ -5424,7 +5231,7 @@ static Lisp_Object make_scroll_bar_position (struct input_event *ev, Lisp_Object type) { return list5 (ev->frame_or_window, type, Fcons (ev->x, ev->y), - make_number (ev->timestamp), + make_fixnum (ev->timestamp), builtin_lisp_symbol (scroll_bar_parts[ev->part])); } @@ -5443,7 +5250,66 @@ make_lispy_event (struct input_event *event) switch (event->kind) { - /* A simple keystroke. */ +#if defined (HAVE_X11) || defined (HAVE_NTGUI) || defined (HAVE_NS) + case DELETE_WINDOW_EVENT: + /* Make an event (delete-frame (FRAME)). */ + return list2 (Qdelete_frame, list1 (event->frame_or_window)); + + case ICONIFY_EVENT: + /* Make an event (iconify-frame (FRAME)). */ + return list2 (Qiconify_frame, list1 (event->frame_or_window)); + + case DEICONIFY_EVENT: + /* Make an event (make-frame-visible (FRAME)). */ + return list2 (Qmake_frame_visible, list1 (event->frame_or_window)); + + case MOVE_FRAME_EVENT: + /* Make an event (move-frame (FRAME)). */ + return list2 (Qmove_frame, list1 (event->frame_or_window)); +#endif + + case BUFFER_SWITCH_EVENT: + { + /* The value doesn't matter here; only the type is tested. */ + Lisp_Object obj; + XSETBUFFER (obj, current_buffer); + return obj; + } + + /* Just discard these, by returning nil. + With MULTI_KBOARD, these events are used as placeholders + when we need to randomly delete events from the queue. + (They shouldn't otherwise be found in the buffer, + but on some machines it appears they do show up + even without MULTI_KBOARD.) */ + /* On Windows NT/9X, NO_EVENT is used to delete extraneous + mouse events during a popup-menu call. */ + case NO_EVENT: + return Qnil; + + case HELP_EVENT: + { + Lisp_Object frame = event->frame_or_window; + Lisp_Object object = event->arg; + Lisp_Object position + = make_fixnum (Time_to_position (event->timestamp)); + Lisp_Object window = event->x; + Lisp_Object help = event->y; + clear_event (event); + + if (!WINDOWP (window)) + window = Qnil; + return Fcons (Qhelp_echo, + list5 (frame, help, window, object, position)); + } + + case FOCUS_IN_EVENT: + return make_lispy_focus_in (event->frame_or_window); + + case FOCUS_OUT_EVENT: + return make_lispy_focus_out (event->frame_or_window); + + /* A simple keystroke. */ case ASCII_KEYSTROKE_EVENT: case MULTIBYTE_CHAR_KEYSTROKE_EVENT: { @@ -5507,6 +5373,11 @@ make_lispy_event (struct input_event *event) } #ifdef HAVE_NS + case NS_TEXT_EVENT: + return list1 (intern (event->code == KEY_NS_PUT_WORKING_TEXT + ? "ns-put-working-text" + : "ns-unput-working-text")); + /* NS_NONKEY_EVENTs are just like NON_ASCII_KEYSTROKE_EVENTs, except that they are non-key events (last-nonmenu-event is nil). */ case NS_NONKEY_EVENT: @@ -5569,6 +5440,17 @@ make_lispy_event (struct input_event *event) PTRDIFF_MAX); #ifdef HAVE_NTGUI + case END_SESSION_EVENT: + /* Make an event (end-session). */ + return list1 (Qend_session); + + case LANGUAGE_CHANGE_EVENT: + /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID). */ + return list4 (Qlanguage_change, + event->frame_or_window, + make_fixnum (event->code), + make_fixnum (event->modifiers)); + case MULTIMEDIA_KEY_EVENT: if (event->code < ARRAYELTS (lispy_multimedia_keys) && event->code > 0 && lispy_multimedia_keys[event->code]) @@ -5622,7 +5504,7 @@ make_lispy_event (struct input_event *event) in a menu (non-toolkit version). */ if (!toolkit_menubar_in_use (f)) { - pixel_to_glyph_coords (f, XINT (event->x), XINT (event->y), + pixel_to_glyph_coords (f, XFIXNUM (event->x), XFIXNUM (event->y), &column, &row, NULL, 1); /* In the non-toolkit version, clicks on the menu bar @@ -5647,8 +5529,8 @@ make_lispy_event (struct input_event *event) pos = AREF (items, i + 3); if (NILP (string)) break; - if (column >= XINT (pos) - && column < XINT (pos) + SCHARS (string)) + if (column >= XFIXNUM (pos) + && column < XFIXNUM (pos) + SCHARS (string)) { item = AREF (items, i); break; @@ -5661,7 +5543,7 @@ make_lispy_event (struct input_event *event) position = list4 (event->frame_or_window, Qmenu_bar, Fcons (event->x, event->y), - make_number (event->timestamp)); + make_fixnum (event->timestamp)); return list2 (item, position); } @@ -5708,18 +5590,18 @@ make_lispy_event (struct input_event *event) fuzz = double_click_fuzz / 8; is_double = (button == last_mouse_button - && (eabs (XINT (event->x) - last_mouse_x) <= fuzz) - && (eabs (XINT (event->y) - last_mouse_y) <= fuzz) + && (eabs (XFIXNUM (event->x) - last_mouse_x) <= fuzz) + && (eabs (XFIXNUM (event->y) - last_mouse_y) <= fuzz) && button_down_time != 0 && (EQ (Vdouble_click_time, Qt) - || (NATNUMP (Vdouble_click_time) + || (FIXNATP (Vdouble_click_time) && (event->timestamp - button_down_time - < XFASTINT (Vdouble_click_time))))); + < XFIXNAT (Vdouble_click_time))))); } last_mouse_button = button; - last_mouse_x = XINT (event->x); - last_mouse_y = XINT (event->y); + last_mouse_x = XFIXNUM (event->x); + last_mouse_y = XFIXNUM (event->y); /* If this is a button press, squirrel away the location, so we can decide later whether it was a click or a drag. */ @@ -5764,10 +5646,10 @@ make_lispy_event (struct input_event *event) new_down = Fcar (Fcdr (Fcdr (position))); if (CONSP (down) - && INTEGERP (XCAR (down)) && INTEGERP (XCDR (down))) + && FIXNUMP (XCAR (down)) && FIXNUMP (XCDR (down))) { - xdiff = XINT (XCAR (new_down)) - XINT (XCAR (down)); - ydiff = XINT (XCDR (new_down)) - XINT (XCDR (down)); + xdiff = XFIXNUM (XCAR (new_down)) - XFIXNUM (XCAR (down)); + ydiff = XFIXNUM (XCDR (new_down)) - XFIXNUM (XCDR (down)); } if (ignore_mouse_drag_p) @@ -5822,7 +5704,7 @@ make_lispy_event (struct input_event *event) if (event->modifiers & drag_modifier) return list3 (head, start_pos, position); else if (event->modifiers & (double_modifier | triple_modifier)) - return list3 (head, position, make_number (double_click_count)); + return list3 (head, position, make_fixnum (double_click_count)); else return list2 (head, position); } @@ -5886,13 +5768,13 @@ make_lispy_event (struct input_event *event) symbol_num += 2; is_double = (last_mouse_button == - (1 + symbol_num) - && (eabs (XINT (event->x) - last_mouse_x) <= fuzz) - && (eabs (XINT (event->y) - last_mouse_y) <= fuzz) + && (eabs (XFIXNUM (event->x) - last_mouse_x) <= fuzz) + && (eabs (XFIXNUM (event->y) - last_mouse_y) <= fuzz) && button_down_time != 0 && (EQ (Vdouble_click_time, Qt) - || (NATNUMP (Vdouble_click_time) + || (FIXNATP (Vdouble_click_time) && (event->timestamp - button_down_time - < XFASTINT (Vdouble_click_time))))); + < XFIXNAT (Vdouble_click_time))))); if (is_double) { double_click_count++; @@ -5909,8 +5791,8 @@ make_lispy_event (struct input_event *event) button_down_time = event->timestamp; /* Use a negative value to distinguish wheel from mouse button. */ last_mouse_button = - (1 + symbol_num); - last_mouse_x = XINT (event->x); - last_mouse_y = XINT (event->y); + last_mouse_x = XFIXNUM (event->x); + last_mouse_y = XFIXNUM (event->y); /* Get the symbol we should use for the wheel event. */ head = modify_event_symbol (symbol_num, @@ -5923,10 +5805,10 @@ make_lispy_event (struct input_event *event) } if (NUMBERP (event->arg)) - return list4 (head, position, make_number (double_click_count), + return list4 (head, position, make_fixnum (double_click_count), event->arg); else if (event->modifiers & (double_modifier | triple_modifier)) - return list3 (head, position, make_number (double_click_count)); + return list3 (head, position, make_fixnum (double_click_count)); else return list2 (head, position); } @@ -6062,7 +5944,7 @@ make_lispy_event (struct input_event *event) } case SAVE_SESSION_EVENT: - return Qsave_session; + return list2 (Qsave_session, event->arg); #ifdef HAVE_DBUS case DBUS_EVENT: @@ -6071,6 +5953,13 @@ make_lispy_event (struct input_event *event) } #endif /* HAVE_DBUS */ +#ifdef THREADS_ENABLED + case THREAD_EVENT: + { + return Fcons (Qthread_event, event->arg); + } +#endif /* THREADS_ENABLED */ + #ifdef HAVE_XWIDGETS case XWIDGET_EVENT: { @@ -6078,12 +5967,15 @@ make_lispy_event (struct input_event *event) } #endif -#if defined HAVE_INOTIFY || defined HAVE_KQUEUE || defined HAVE_GFILENOTIFY +#ifdef USE_FILE_NOTIFY case FILE_NOTIFY_EVENT: - { - return Fcons (Qfile_notify, event->arg); - } -#endif /* HAVE_INOTIFY || HAVE_KQUEUE || HAVE_GFILENOTIFY */ +#ifdef HAVE_W32NOTIFY + /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK). */ + return list3 (Qfile_notify, event->arg, event->frame_or_window); +#else + return Fcons (Qfile_notify, event->arg); +#endif +#endif /* USE_FILE_NOTIFY */ case CONFIG_CHANGED_EVENT: return list3 (Qconfig_changed_event, @@ -6109,7 +6001,7 @@ make_lispy_movement (struct frame *frame, Lisp_Object bar_window, enum scroll_ba list5 (bar_window, Qvertical_scroll_bar, Fcons (x, y), - make_number (t), + make_fixnum (t), part_sym)); } /* Or is it an ordinary mouse movement? */ @@ -6134,16 +6026,12 @@ make_lispy_focus_in (Lisp_Object frame) return list2 (Qfocus_in, frame); } -#ifdef HAVE_WINDOW_SYSTEM - static Lisp_Object make_lispy_focus_out (Lisp_Object frame) { return list2 (Qfocus_out, frame); } -#endif /* HAVE_WINDOW_SYSTEM */ - /* Manipulating modifiers. */ /* Parse the name of SYMBOL, and return the set of modifiers it contains. @@ -6353,15 +6241,15 @@ lispy_modifier_list (int modifiers) SYMBOL's Qevent_symbol_element_mask property, and maintains the Qevent_symbol_elements property. */ -#define KEY_TO_CHAR(k) (XINT (k) & ((1 << CHARACTERBITS) - 1)) +#define KEY_TO_CHAR(k) (XFIXNUM (k) & ((1 << CHARACTERBITS) - 1)) Lisp_Object parse_modifiers (Lisp_Object symbol) { Lisp_Object elements; - if (INTEGERP (symbol)) - return list2i (KEY_TO_CHAR (symbol), XINT (symbol) & CHAR_MODIFIER_MASK); + if (FIXNUMP (symbol)) + return list2i (KEY_TO_CHAR (symbol), XFIXNUM (symbol) & CHAR_MODIFIER_MASK); else if (!SYMBOLP (symbol)) return Qnil; @@ -6428,8 +6316,8 @@ apply_modifiers (int modifiers, Lisp_Object base) /* Mask out upper bits. We don't know where this value's been. */ modifiers &= INTMASK; - if (INTEGERP (base)) - return make_number (XINT (base) | modifiers); + if (FIXNUMP (base)) + return make_fixnum (XFIXNUM (base) | modifiers); /* The click modifier never figures into cache indices. */ cache = Fget (base, Qmodifier_cache); @@ -6497,7 +6385,7 @@ reorder_modifiers (Lisp_Object symbol) Lisp_Object parsed; parsed = parse_modifiers (symbol); - return apply_modifiers (XFASTINT (XCAR (XCDR (parsed))), + return apply_modifiers (XFIXNAT (XCAR (XCDR (parsed))), XCAR (parsed)); } @@ -6560,12 +6448,7 @@ modify_event_symbol (ptrdiff_t symbol_num, int modifiers, Lisp_Object symbol_kin { if (! VECTORP (*symbol_table) || ASIZE (*symbol_table) != table_size) - { - Lisp_Object size; - - XSETFASTINT (size, table_size); - *symbol_table = Fmake_vector (size, Qnil); - } + *symbol_table = make_nil_vector (table_size); value = AREF (*symbol_table, symbol_num); } @@ -6584,7 +6467,7 @@ modify_event_symbol (ptrdiff_t symbol_num, int modifiers, Lisp_Object symbol_kin USE_SAFE_ALLOCA; buf = SAFE_ALLOCA (len); esprintf (buf, "%s-%"pI"d", SDATA (name_alist_or_stem), - XINT (symbol_int) + 1); + XFIXNUM (symbol_int) + 1); value = intern (buf); SAFE_FREE (); } @@ -6667,22 +6550,22 @@ has the same base event type and all the specified modifiers. */) if (SYMBOLP (base) && SCHARS (SYMBOL_NAME (base)) == 1) XSETINT (base, SREF (SYMBOL_NAME (base), 0)); - if (INTEGERP (base)) + if (FIXNUMP (base)) { /* Turn (shift a) into A. */ if ((modifiers & shift_modifier) != 0 - && (XINT (base) >= 'a' && XINT (base) <= 'z')) + && (XFIXNUM (base) >= 'a' && XFIXNUM (base) <= 'z')) { - XSETINT (base, XINT (base) - ('a' - 'A')); + XSETINT (base, XFIXNUM (base) - ('a' - 'A')); modifiers &= ~shift_modifier; } /* Turn (control a) into C-a. */ if (modifiers & ctrl_modifier) - return make_number ((modifiers & ~ctrl_modifier) - | make_ctrl_char (XINT (base))); + return make_fixnum ((modifiers & ~ctrl_modifier) + | make_ctrl_char (XFIXNUM (base))); else - return make_number (modifiers | XINT (base)); + return make_fixnum (modifiers | XFIXNUM (base)); } else if (SYMBOLP (base)) return apply_modifiers (modifiers, base); @@ -6690,6 +6573,31 @@ has the same base event type and all the specified modifiers. */) error ("Invalid base event"); } +DEFUN ("internal-handle-focus-in", Finternal_handle_focus_in, + Sinternal_handle_focus_in, 1, 1, 0, + doc: /* Internally handle focus-in events. +This function potentially generates an artifical switch-frame event. */) + (Lisp_Object event) +{ + Lisp_Object frame; + if (!EQ (CAR_SAFE (event), Qfocus_in) || + !CONSP (XCDR (event)) || + !FRAMEP ((frame = XCAR (XCDR (event))))) + error ("invalid focus-in event"); + + /* Conceptually, the concept of window manager focus on a particular + frame and the Emacs selected frame shouldn't be related, but for + a long time, we automatically switched the selected frame in + response to focus events, so let's keep doing that. */ + bool switching = (!EQ (frame, internal_last_event_frame) + && !EQ (frame, selected_frame)); + internal_last_event_frame = frame; + if (switching || !NILP (unread_switch_frame)) + unread_switch_frame = make_lispy_switch_frame (frame); + + return Qnil; +} + /* Try to recognize SYMBOL as a modifier name. Return the modifier flag bit, or 0 if not recognized. */ @@ -6800,7 +6708,7 @@ lucid_event_type_list_p (Lisp_Object object) { Lisp_Object elt; elt = XCAR (tail); - if (! (INTEGERP (elt) || SYMBOLP (elt))) + if (! (FIXNUMP (elt) || SYMBOLP (elt))) return 0; } @@ -7449,7 +7357,7 @@ menu_bar_items (Lisp_Object old) if (!NILP (old)) menu_bar_items_vector = old; else - menu_bar_items_vector = Fmake_vector (make_number (24), Qnil); + menu_bar_items_vector = make_nil_vector (24); menu_bar_items_index = 0; /* Build our list of keymaps. @@ -7621,7 +7529,7 @@ menu_bar_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy1, void *dumm ASET (menu_bar_items_vector, i, AREF (item_properties, ITEM_PROPERTY_NAME)); i++; ASET (menu_bar_items_vector, i, list1 (item)); i++; - ASET (menu_bar_items_vector, i, make_number (0)); i++; + ASET (menu_bar_items_vector, i, make_fixnum (0)); i++; menu_bar_items_index = i; } /* We did find an item for this KEY. Add ITEM to its list of maps. */ @@ -7692,8 +7600,7 @@ parse_menu_item (Lisp_Object item, int inmenubar) /* Create item_properties vector if necessary. */ if (NILP (item_properties)) - item_properties - = Fmake_vector (make_number (ITEM_PROPERTY_ENABLE + 1), Qnil); + item_properties = make_nil_vector (ITEM_PROPERTY_ENABLE + 1); /* Initialize optional entries. */ for (i = ITEM_PROPERTY_DEF; i < ITEM_PROPERTY_ENABLE; i++) @@ -8187,8 +8094,7 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item) set_prop (i, Qnil); } else - tool_bar_item_properties - = Fmake_vector (make_number (TOOL_BAR_ITEM_NSLOTS), Qnil); + tool_bar_item_properties = make_nil_vector (TOOL_BAR_ITEM_NSLOTS); /* Set defaults. */ set_prop (TOOL_BAR_ITEM_KEY, key); @@ -8383,7 +8289,7 @@ init_tool_bar_items (Lisp_Object reuse) if (VECTORP (reuse)) tool_bar_items_vector = reuse; else - tool_bar_items_vector = Fmake_vector (make_number (64), Qnil); + tool_bar_items_vector = make_nil_vector (64); ntool_bar_items = 0; } @@ -8454,7 +8360,7 @@ read_char_x_menu_prompt (Lisp_Object map, /* Display the menu and get the selection. */ Lisp_Object value; - value = Fx_popup_menu (prev_event, get_keymap (map, 0, 1)); + value = x_popup_menu_1 (prev_event, get_keymap (map, 0, 1)); if (CONSP (value)) { Lisp_Object tem; @@ -8473,7 +8379,7 @@ read_char_x_menu_prompt (Lisp_Object map, { record_menu_key (XCAR (tem)); if (SYMBOLP (XCAR (tem)) - || INTEGERP (XCAR (tem))) + || FIXNUMP (XCAR (tem))) XSETCAR (tem, Fcons (XCAR (tem), Qdisabled)); } @@ -8584,7 +8490,7 @@ read_char_minibuf_menu_prompt (int commandflag, } /* Ignore the element if it has no prompt string. */ - if (INTEGERP (event) && parse_menu_item (elt, -1)) + if (FIXNUMP (event) && parse_menu_item (elt, -1)) { /* True if the char to type matches the string. */ bool char_matches; @@ -8595,8 +8501,8 @@ read_char_minibuf_menu_prompt (int commandflag, upcased_event = Fupcase (event); downcased_event = Fdowncase (event); - char_matches = (XINT (upcased_event) == SREF (s, 0) - || XINT (downcased_event) == SREF (s, 0)); + char_matches = (XFIXNUM (upcased_event) == SREF (s, 0) + || XFIXNUM (downcased_event) == SREF (s, 0)); if (! char_matches) desc = Fsingle_key_description (event, Qnil); @@ -8652,8 +8558,8 @@ read_char_minibuf_menu_prompt (int commandflag, /* Add as much of string as fits. */ thiswidth = min (SCHARS (desc), width - i); menu_strings - = Fcons (Fsubstring (desc, make_number (0), - make_number (thiswidth)), + = Fcons (Fsubstring (desc, make_fixnum (0), + make_fixnum (thiswidth)), menu_strings); i += thiswidth; PUSH_C_STR (" = ", menu_strings); @@ -8663,8 +8569,8 @@ read_char_minibuf_menu_prompt (int commandflag, /* Add as much of string as fits. */ thiswidth = min (SCHARS (s), width - i); menu_strings - = Fcons (Fsubstring (s, make_number (0), - make_number (thiswidth)), + = Fcons (Fsubstring (s, make_fixnum (0), + make_fixnum (thiswidth)), menu_strings); i += thiswidth; } @@ -8701,10 +8607,10 @@ read_char_minibuf_menu_prompt (int commandflag, while (BUFFERP (obj)); kset_defining_kbd_macro (current_kboard, orig_defn_macro); - if (!INTEGERP (obj) || XINT (obj) == -2 + if (!FIXNUMP (obj) || XFIXNUM (obj) == -2 || (! EQ (obj, menu_prompt_more_char) - && (!INTEGERP (menu_prompt_more_char) - || ! EQ (obj, make_number (Ctl (XINT (menu_prompt_more_char))))))) + && (!FIXNUMP (menu_prompt_more_char) + || ! EQ (obj, make_fixnum (Ctl (XFIXNUM (menu_prompt_more_char))))))) { if (!NILP (KVAR (current_kboard, defining_kbd_macro))) store_kbd_macro_char (obj); @@ -8724,10 +8630,19 @@ follow_key (Lisp_Object keymap, Lisp_Object key) } static Lisp_Object -active_maps (Lisp_Object first_event) +active_maps (Lisp_Object first_event, Lisp_Object second_event) { Lisp_Object position - = CONSP (first_event) ? CAR_SAFE (XCDR (first_event)) : Qnil; + = EVENT_HAS_PARAMETERS (first_event) ? EVENT_START (first_event) : Qnil; + /* The position of a click can be in the second event if the first event + is a fake_prefixed_key like `header-line` or `mode-line`. */ + if (SYMBOLP (first_event) + && EVENT_HAS_PARAMETERS (second_event) + && EQ (first_event, POSN_POSN (EVENT_START (second_event)))) + { + eassert (NILP (position)); + position = EVENT_START (second_event); + } return Fcons (Qkeymap, Fcurrent_active_maps (Qt, position)); } @@ -8789,8 +8704,7 @@ access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt, /* Do one step of the key remapping used for function-key-map and key-translation-map: - KEYBUF is the buffer holding the input events. - BUFSIZE is its maximum size. + KEYBUF is the READ_KEY_ELTS-size buffer holding the input events. FKEY is a pointer to the keyremap structure to use. INPUT is the index of the last element in KEYBUF. DOIT if true says that the remapping can actually take place. @@ -8800,7 +8714,7 @@ access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt, Return true if the remapping actually took place. */ static bool -keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey, +keyremap_step (Lisp_Object *keybuf, volatile keyremap *fkey, int input, bool doit, int *diff, Lisp_Object prompt) { Lisp_Object next, key; @@ -8817,12 +8731,12 @@ keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey, the binding and restart with fkey->start at the end. */ if ((VECTORP (next) || STRINGP (next)) && doit) { - int len = XFASTINT (Flength (next)); + int len = XFIXNAT (Flength (next)); int i; *diff = len - (fkey->end - fkey->start); - if (bufsize - input <= *diff) + if (READ_KEY_ELTS - input <= *diff) error ("Key sequence too long"); /* Shift the keys that follow fkey->end. */ @@ -8835,7 +8749,7 @@ keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey, /* Overwrite the old keys with the new ones. */ for (i = 0; i < len; i++) keybuf[fkey->start + i] - = Faref (next, make_number (i)); + = Faref (next, make_fixnum (i)); fkey->start = fkey->end += *diff; fkey->map = fkey->parent; @@ -8864,8 +8778,13 @@ test_undefined (Lisp_Object binding) && EQ (Fcommand_remapping (binding, Qnil, Qnil), Qundefined))); } +void init_raw_keybuf_count (void) +{ + raw_keybuf_count = 0; +} + /* Read a sequence of keys that ends with a non prefix character, - storing it in KEYBUF, a buffer of size BUFSIZE. + storing it in KEYBUF, a buffer of size READ_KEY_ELTS. Prompt with PROMPT. Return the length of the key sequence stored. Return -1 if the user rejected a command menu. @@ -8905,7 +8824,7 @@ test_undefined (Lisp_Object binding) from the selected window's buffer. */ static int -read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, +read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt, bool dont_downcase_last, bool can_return_switch_frame, bool fix_current_buffer, bool prevent_redisplay) { @@ -8920,7 +8839,6 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, ptrdiff_t keys_start; Lisp_Object current_binding = Qnil; - Lisp_Object first_event = Qnil; /* Index of the first key that has no binding. It is useless to try fkey.start larger than that. */ @@ -8941,6 +8859,9 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, reading characters from the keyboard. */ int mock_input = 0; + /* Whether each event in the mocked input came from a mouse menu. */ + bool used_mouse_menu_history[READ_KEY_ELTS] = {0}; + /* If the sequence is unbound in submaps[], then keybuf[fkey.start..fkey.end-1] is a prefix in Vfunction_key_map, and fkey.map is its binding. @@ -8975,9 +8896,11 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, /* List of events for which a fake prefix key has been generated. */ Lisp_Object fake_prefixed_keys = Qnil; - raw_keybuf_count = 0; - - last_nonmenu_event = Qnil; + /* raw_keybuf_count is now initialized in (most of) the callers of + read_key_sequence. This is so that in a recursive call (for + mouse menus) a spurious initialization doesn't erase the contents + of raw_keybuf created by the outer call. */ + /* raw_keybuf_count = 0; */ delayed_switch_frame = Qnil; @@ -9029,17 +8952,20 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, replay_sequence: starting_buffer = current_buffer; - first_unbound = bufsize + 1; + first_unbound = READ_KEY_ELTS + 1; + Lisp_Object first_event = mock_input > 0 ? keybuf[0] : Qnil; + Lisp_Object second_event = mock_input > 1 ? keybuf[1] : Qnil; /* Build our list of keymaps. If we recognize a function key and replace its escape sequence in keybuf with its symbol, or if the sequence starts with a mouse click and we need to switch buffers, we jump back here to rebuild the initial keymaps from the current buffer. */ - current_binding = active_maps (first_event); + current_binding = active_maps (first_event, second_event); /* Start from the beginning in keybuf. */ t = 0; + last_nonmenu_event = Qnil; /* These are no-ops the first time through, but if we restart, they revert the echo area and this_command_keys to their original state. */ @@ -9107,7 +9033,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, goto replay_sequence; } - if (t >= bufsize) + if (t >= READ_KEY_ELTS) error ("Key sequence too long"); if (INTERACTIVE) @@ -9138,6 +9064,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, current_kboard->immediate_echo = false; echo_now (); } + used_mouse_menu = used_mouse_menu_history[t]; } /* If not, we should actually read a character. */ @@ -9151,7 +9078,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, key = read_char (prevent_redisplay ? -2 : NILP (prompt), current_binding, last_nonmenu_event, &used_mouse_menu, NULL); - if ((INTEGERP (key) && XINT (key) == -2) /* wrong_kboard_jmpbuf */ + used_mouse_menu_history[t] = used_mouse_menu; + if ((FIXNUMP (key) && XFIXNUM (key) == -2) /* wrong_kboard_jmpbuf */ /* When switching to a new tty (with a new keyboard), read_char returns the new buffer, rather than -2 (Bug#5095). This is because `terminal-init-xterm' @@ -9219,7 +9147,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, /* read_char returns -1 at the end of a macro. Emacs 18 handles this by returning immediately with a zero, so that's what we'll do. */ - if (INTEGERP (key) && XINT (key) == -1) + if (FIXNUMP (key) && XFIXNUM (key) == -1) { t = 0; /* The Microsoft C compiler can't handle the goto that @@ -9254,8 +9182,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, /* If we have a quit that was typed in another frame, and quit_throw_to_read_char switched buffers, replay to get the right keymap. */ - if (INTEGERP (key) - && XINT (key) == quit_char + if (FIXNUMP (key) + && XFIXNUM (key) == quit_char && current_buffer != starting_buffer) { GROW_RAW_KEYBUF; @@ -9296,11 +9224,14 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, && (XBUFFER (XWINDOW (selected_window)->contents) != current_buffer)) Fset_buffer (XWINDOW (selected_window)->contents); - current_binding = active_maps (first_event); + current_binding = active_maps (first_event, Qnil); } GROW_RAW_KEYBUF; - ASET (raw_keybuf, raw_keybuf_count, key); + ASET (raw_keybuf, raw_keybuf_count, + /* Copy the event, in case it gets modified by side-effect + by some remapping function (bug#30955). */ + CONSP (key) ? Fcopy_sequence (key) : key); raw_keybuf_count++; } @@ -9347,8 +9278,6 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, && BUFFERP (XWINDOW (window)->contents) && XBUFFER (XWINDOW (window)->contents) != current_buffer) { - ASET (raw_keybuf, raw_keybuf_count, key); - raw_keybuf_count++; keybuf[t] = key; mock_input = t + 1; @@ -9377,7 +9306,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, && (NILP (fake_prefixed_keys) || NILP (Fmemq (key, fake_prefixed_keys)))) { - if (bufsize - t <= 1) + if (READ_KEY_ELTS - t <= 1) error ("Key sequence too long"); keybuf[t] = posn; @@ -9393,24 +9322,24 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, } } else if (CONSP (XCDR (key)) - && CONSP (EVENT_START (key)) - && CONSP (XCDR (EVENT_START (key)))) + && CONSP (xevent_start (key)) + && CONSP (XCDR (xevent_start (key)))) { Lisp_Object posn; - posn = POSN_POSN (EVENT_START (key)); + posn = POSN_POSN (xevent_start (key)); /* Handle menu-bar events: insert the dummy prefix event `menu-bar'. */ if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar)) { - if (bufsize - t <= 1) + if (READ_KEY_ELTS - t <= 1) error ("Key sequence too long"); keybuf[t] = posn; keybuf[t + 1] = key; /* Zap the position in key, so we know that we've expanded it, and don't try to do so again. */ - POSN_SET_POSN (EVENT_START (key), list1 (posn)); + POSN_SET_POSN (xevent_start (key), list1 (posn)); mock_input = t + 2; goto replay_sequence; @@ -9454,7 +9383,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, int modifiers; breakdown = parse_modifiers (head); - modifiers = XINT (XCAR (XCDR (breakdown))); + modifiers = XFIXNUM (XCAR (XCDR (breakdown))); /* Attempt to reduce an unbound mouse event to a simpler event that is bound: Drags reduce to clicks. @@ -9606,8 +9535,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, bool done; int diff; - done = keyremap_step (keybuf, bufsize, &indec, max (t, mock_input), - 1, &diff, prompt); + done = keyremap_step (keybuf, &indec, max (t, mock_input), + true, &diff, prompt); if (done) { mock_input = diff + max (t, mock_input); @@ -9637,13 +9566,13 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, bool done; int diff; - done = keyremap_step (keybuf, bufsize, &fkey, + done = keyremap_step (keybuf, &fkey, max (t, mock_input), /* If there's a binding (i.e. first_binding >= nmaps) we don't want to apply this function-key-mapping. */ - fkey.end + 1 == t - && (test_undefined (current_binding)), + (fkey.end + 1 == t + && test_undefined (current_binding)), &diff, prompt); if (done) { @@ -9663,8 +9592,8 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, bool done; int diff; - done = keyremap_step (keybuf, bufsize, &keytran, max (t, mock_input), - 1, &diff, prompt); + done = keyremap_step (keybuf, &keytran, max (t, mock_input), + true, &diff, prompt); if (done) { mock_input = diff + max (t, mock_input); @@ -9684,14 +9613,14 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, use the corresponding lower-case letter instead. */ if (NILP (current_binding) && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t - && INTEGERP (key)) + && FIXNUMP (key)) { Lisp_Object new_key; - EMACS_INT k = XINT (key); + EMACS_INT k = XFIXNUM (key); if (k & shift_modifier) XSETINT (new_key, k & ~shift_modifier); - else if (CHARACTERP (make_number (k & ~CHAR_MODIFIER_MASK))) + else if (CHARACTERP (make_fixnum (k & ~CHAR_MODIFIER_MASK))) { int dc = downcase (k & ~CHAR_MODIFIER_MASK); if (dc == (k & ~CHAR_MODIFIER_MASK)) @@ -9734,11 +9663,11 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, { Lisp_Object breakdown = parse_modifiers (key); int modifiers - = CONSP (breakdown) ? (XINT (XCAR (XCDR (breakdown)))) : 0; + = CONSP (breakdown) ? (XFIXNUM (XCAR (XCDR (breakdown)))) : 0; if (modifiers & shift_modifier /* Treat uppercase keys as shifted. */ - || (INTEGERP (key) + || (FIXNUMP (key) && (KEY_TO_CHAR (key) < XCHAR_TABLE (BVAR (current_buffer, downcase_table))->header.size) && uppercasep (KEY_TO_CHAR (key)))) @@ -9747,7 +9676,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, = (modifiers & shift_modifier ? apply_modifiers (modifiers & ~shift_modifier, XCAR (breakdown)) - : make_number (downcase (KEY_TO_CHAR (key)) | modifiers)); + : make_fixnum (downcase (KEY_TO_CHAR (key)) | modifiers)); original_uppercase = key; original_uppercase_position = t - 1; @@ -9817,8 +9746,6 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop, bool allow_string) { - Lisp_Object keybuf[30]; - int i; ptrdiff_t count = SPECPDL_INDEX (); if (!NILP (prompt)) @@ -9841,9 +9768,10 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo, cancel_hourglass (); #endif - i = read_key_sequence (keybuf, ARRAYELTS (keybuf), - prompt, ! NILP (dont_downcase_last), - ! NILP (can_return_switch_frame), 0, 0); + raw_keybuf_count = 0; + Lisp_Object keybuf[READ_KEY_ELTS]; + int i = read_key_sequence (keybuf, prompt, ! NILP (dont_downcase_last), + ! NILP (can_return_switch_frame), false, false); #if 0 /* The following is fine for code reading a key sequence and then proceeding with a lengthy computation, but it's not good @@ -10069,16 +9997,16 @@ Internal use only. */) /* Kludge alert: this makes M-x be in the form expected by novice.el. (248 is \370, a.k.a. "Meta-x".) Any better ideas? */ if (key0 == 248) - add_command_key (make_number ('x' | meta_modifier)); + add_command_key (make_fixnum ('x' | meta_modifier)); else - add_command_key (make_number (key0)); + add_command_key (make_fixnum (key0)); for (ptrdiff_t i = 1; i < SCHARS (keys); i++) { int key_i; FETCH_STRING_CHAR_ADVANCE (key_i, keys, charidx, byteidx); if (CHAR_BYTE8_P (key_i)) key_i = CHAR_TO_BYTE8 (key_i); - add_command_key (make_number (key_i)); + add_command_key (make_fixnum (key_i)); } return Qnil; } @@ -10151,15 +10079,18 @@ DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0, { EMACS_INT sum; INT_ADD_WRAPV (command_loop_level, minibuf_level, &sum); - return make_number (sum); + return make_fixnum (sum); } DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1, "FOpen dribble file: ", - doc: /* Start writing all keyboard characters to a dribble file called FILE. + doc: /* Start writing input events to a dribble file called FILE. If FILE is nil, close any open dribble file. The file will be closed when Emacs exits. +The events written to the file include keyboard and mouse input +events, but not events from executing keyboard macros. + Be aware that this records ALL characters you type! This may include sensitive information such as passwords. */) (Lisp_Object file) @@ -10290,15 +10221,14 @@ stuff_buffered_input (Lisp_Object stuffstring) rms: we should stuff everything back into the kboard it came from. */ - for (; kbd_fetch_ptr != kbd_store_ptr; kbd_fetch_ptr++) + for (; kbd_fetch_ptr != kbd_store_ptr; + kbd_fetch_ptr = next_kbd_event (kbd_fetch_ptr)) { - if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE) - kbd_fetch_ptr = kbd_buffer; if (kbd_fetch_ptr->kind == ASCII_KEYSTROKE_EVENT) stuff_char (kbd_fetch_ptr->ie.code); - clear_event (kbd_fetch_ptr); + clear_event (&kbd_fetch_ptr->ie); } input_pending = false; @@ -10701,7 +10631,7 @@ See also `current-input-mode'. */) return Qnil; tty = t->display_info.tty; - if (NILP (quit) || !INTEGERP (quit) || XINT (quit) < 0 || XINT (quit) > 0400) + if (NILP (quit) || !FIXNUMP (quit) || XFIXNUM (quit) < 0 || XFIXNUM (quit) > 0400) error ("QUIT must be an ASCII character"); #ifndef DOS_NT @@ -10710,7 +10640,7 @@ See also `current-input-mode'. */) #endif /* Don't let this value be out of range. */ - quit_char = XINT (quit) & (tty->meta_key == 0 ? 0177 : 0377); + quit_char = XFIXNUM (quit) & (tty->meta_key == 0 ? 0177 : 0377); #ifndef DOS_NT init_sys_modes (tty); @@ -10764,7 +10694,7 @@ The elements of this list correspond to the arguments of { flow = FRAME_TTY (sf)->flow_control ? Qt : Qnil; meta = (FRAME_TTY (sf)->meta_key == 2 - ? make_number (0) + ? make_fixnum (0) : (CURTTY ()->meta_key == 1 ? Qt : Qnil)); } else @@ -10772,7 +10702,7 @@ The elements of this list correspond to the arguments of flow = Qnil; meta = Qt; } - Lisp_Object quit = make_number (quit_char); + Lisp_Object quit = make_fixnum (quit_char); return list4 (interrupt, flow, meta, quit); } @@ -10790,12 +10720,12 @@ The return value is similar to a mouse click position: The `posn-' functions access elements of such lists. */) (Lisp_Object x, Lisp_Object y, Lisp_Object frame_or_window, Lisp_Object whole) { - CHECK_NUMBER (x); + CHECK_FIXNUM (x); /* We allow X of -1, for the newline in a R2L line that overflowed into the left fringe. */ - if (XINT (x) != -1) - CHECK_NATNUM (x); - CHECK_NATNUM (y); + if (XFIXNUM (x) != -1) + CHECK_FIXNAT (x); + CHECK_FIXNAT (y); if (NILP (frame_or_window)) frame_or_window = selected_window; @@ -10804,12 +10734,12 @@ The `posn-' functions access elements of such lists. */) { struct window *w = decode_live_window (frame_or_window); - XSETINT (x, (XINT (x) + XSETINT (x, (XFIXNUM (x) + WINDOW_LEFT_EDGE_X (w) + (NILP (whole) ? window_box_left_offset (w, TEXT_AREA) : 0))); - XSETINT (y, WINDOW_TO_FRAME_PIXEL_Y (w, XINT (y))); + XSETINT (y, WINDOW_TO_FRAME_PIXEL_Y (w, XFIXNUM (y))); frame_or_window = w->frame; } @@ -10842,17 +10772,17 @@ 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); + int y_coord = XFIXNUM (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) + if (XFIXNUM (x) < -1) return Qnil; if (!NILP (aux_info) && y_coord < 0) { - int rtop = XINT (XCAR (aux_info)); + int rtop = XFIXNUM (XCAR (aux_info)); - y = make_number (y_coord + rtop); + y = make_fixnum (y_coord + rtop); } tem = Fposn_at_x_y (x, y, window, Qnil); } @@ -11119,6 +11049,10 @@ syms_of_keyboard (void) DEFSYM (Qdbus_event, "dbus-event"); #endif +#ifdef THREADS_ENABLED + DEFSYM (Qthread_event, "thread-event"); +#endif + #ifdef HAVE_XWIDGETS DEFSYM (Qxwidget_event, "xwidget-event"); #endif @@ -11243,32 +11177,31 @@ syms_of_keyboard (void) } } - button_down_location = Fmake_vector (make_number (5), Qnil); + button_down_location = make_nil_vector (5); staticpro (&button_down_location); - mouse_syms = Fmake_vector (make_number (5), Qnil); + mouse_syms = make_nil_vector (5); staticpro (&mouse_syms); - wheel_syms = Fmake_vector (make_number (ARRAYELTS (lispy_wheel_names)), - Qnil); + wheel_syms = make_nil_vector (ARRAYELTS (lispy_wheel_names)); staticpro (&wheel_syms); { int i; int len = ARRAYELTS (modifier_names); - modifier_symbols = Fmake_vector (make_number (len), Qnil); + modifier_symbols = make_nil_vector (len); for (i = 0; i < len; i++) if (modifier_names[i]) ASET (modifier_symbols, i, intern_c_string (modifier_names[i])); staticpro (&modifier_symbols); } - recent_keys = Fmake_vector (make_number (NUM_RECENT_KEYS), Qnil); + recent_keys = make_nil_vector (NUM_RECENT_KEYS); staticpro (&recent_keys); - this_command_keys = Fmake_vector (make_number (40), Qnil); + this_command_keys = make_nil_vector (40); staticpro (&this_command_keys); - raw_keybuf = Fmake_vector (make_number (30), Qnil); + raw_keybuf = make_nil_vector (30); staticpro (&raw_keybuf); DEFSYM (Qcommand_execute, "command-execute"); @@ -11306,6 +11239,7 @@ syms_of_keyboard (void) defsubr (&Scurrent_idle_time); defsubr (&Sevent_symbol_parse_modifiers); defsubr (&Sevent_convert_list); + defsubr (&Sinternal_handle_focus_in); defsubr (&Sread_key_sequence); defsubr (&Sread_key_sequence_vector); defsubr (&Srecursive_edit); @@ -11431,6 +11365,10 @@ result of looking up the original command in the active keymaps. */); Zero means disable autosaving due to number of characters typed. */); auto_save_interval = 300; + DEFVAR_BOOL ("auto-save-no-message", auto_save_no_message, + doc: /* Non-nil means do not print any message when auto-saving. */); + auto_save_no_message = false; + DEFVAR_LISP ("auto-save-timeout", Vauto_save_timeout, doc: /* Number of seconds idle time before auto-save. Zero or nil means disable auto-saving due to idleness. @@ -11442,7 +11380,7 @@ Emacs also does a garbage collection if that seems to be warranted. */); doc: /* Nonzero means echo unfinished commands after this many seconds of pause. The value may be integer or floating point. If the value is zero, don't echo at all. */); - Vecho_keystrokes = make_number (1); + Vecho_keystrokes = make_fixnum (1); DEFVAR_INT ("polling-period", polling_period, doc: /* Interval between polling for input during Lisp execution. @@ -11456,7 +11394,7 @@ Polling is automatically disabled in all other cases. */); Measured in milliseconds. The value nil means disable double-click recognition; t means double-clicks have no time limit and are detected by position only. */); - Vdouble_click_time = make_number (500); + Vdouble_click_time = make_fixnum (500); DEFVAR_INT ("double-click-fuzz", double_click_fuzz, doc: /* Maximum mouse movement between clicks to make a double-click. @@ -11806,7 +11744,7 @@ suppressed only after special commands that leave doc: /* How long to display an echo-area message when the minibuffer is active. If the value is a number, it should be specified in seconds. If the value is not a number, such messages never time out. */); - Vminibuffer_message_timeout = make_number (2); + Vminibuffer_message_timeout = make_fixnum (2); DEFVAR_LISP ("throw-on-input", Vthrow_on_input, doc: /* If non-nil, any keyboard input throws to this symbol. @@ -11897,6 +11835,14 @@ If nil, Emacs crashes immediately in response to fatal signals. */); Vwhile_no_input_ignore_events, doc: /* Ignored events from while-no-input. */); Vwhile_no_input_ignore_events = Qnil; + + DEFVAR_BOOL ("inhibit--record-char", + inhibit_record_char, + doc: /* If non-nil, don't record input events. +This inhibits recording input events for the purposes of keyboard +macros, dribble file, and `recent-keys'. +Internal use only. */); + inhibit_record_char = false; } void @@ -11957,6 +11903,12 @@ keys_of_keyboard (void) "dbus-handle-event"); #endif +#ifdef THREADS_ENABLED + /* Define a special event which is raised for thread signals. */ + initial_define_lispy_key (Vspecial_event_map, "thread-event", + "thread-handle-event"); +#endif + #ifdef USE_FILE_NOTIFY /* Define a special event which is raised for notification callback functions. */ @@ -12009,26 +11961,18 @@ mark_kboards (void) mark_object (KVAR (kb, echo_string)); mark_object (KVAR (kb, echo_prompt)); } - { - union buffered_input_event *event; - for (event = kbd_fetch_ptr; event != kbd_store_ptr; event++) - { - if (event == kbd_buffer + KBD_BUFFER_SIZE) - { - event = kbd_buffer; - if (event == kbd_store_ptr) - break; - } - /* These two special event types has no Lisp_Objects to mark. */ - if (event->kind != SELECTION_REQUEST_EVENT - && event->kind != SELECTION_CLEAR_EVENT) - { - mark_object (event->ie.x); - mark_object (event->ie.y); - mark_object (event->ie.frame_or_window); - mark_object (event->ie.arg); - } - } - } + for (union buffered_input_event *event = kbd_fetch_ptr; + event != kbd_store_ptr; event = next_kbd_event (event)) + { + /* These two special event types have no Lisp_Objects to mark. */ + if (event->kind != SELECTION_REQUEST_EVENT + && event->kind != SELECTION_CLEAR_EVENT) + { + mark_object (event->ie.x); + mark_object (event->ie.y); + mark_object (event->ie.frame_or_window); + mark_object (event->ie.arg); + } + } } diff --git a/src/keyboard.h b/src/keyboard.h index a016ee74d6b..0898c752ea4 100644 --- a/src/keyboard.h +++ b/src/keyboard.h @@ -391,7 +391,7 @@ extern void unuse_menu_items (void); #define EVENT_END(event) (CAR_SAFE (CDR_SAFE (CDR_SAFE (event)))) /* Extract the click count from a multi-click event. */ -#define EVENT_CLICK_COUNT(event) (Fnth (make_number (2), (event))) +#define EVENT_CLICK_COUNT(event) (Fnth (make_fixnum (2), (event))) /* Extract the fields of a position. */ #define POSN_WINDOW(posn) (CAR_SAFE (posn)) @@ -399,17 +399,17 @@ extern void unuse_menu_items (void); #define POSN_SET_POSN(posn,x) (XSETCAR (XCDR (posn), (x))) #define POSN_WINDOW_POSN(posn) (CAR_SAFE (CDR_SAFE (CDR_SAFE (posn)))) #define POSN_TIMESTAMP(posn) (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (posn))))) -#define POSN_SCROLLBAR_PART(posn) (Fnth (make_number (4), (posn))) +#define POSN_SCROLLBAR_PART(posn) (Fnth (make_fixnum (4), (posn))) /* A cons (STRING . STRING-CHARPOS), or nil in mouse-click events. It's a cons if the click is over a string in the mode line. */ -#define POSN_STRING(posn) (Fnth (make_number (4), (posn))) +#define POSN_STRING(posn) (Fnth (make_fixnum (4), (posn))) /* If POSN_STRING is nil, event refers to buffer location. */ #define POSN_INBUFFER_P(posn) (NILP (POSN_STRING (posn))) -#define POSN_BUFFER_POSN(posn) (Fnth (make_number (5), (posn))) +#define POSN_BUFFER_POSN(posn) (Fnth (make_fixnum (5), (posn))) /* Getting the kind of an event head. */ #define EVENT_HEAD_KIND(event_head) \ @@ -438,6 +438,7 @@ extern unsigned int timers_run; extern bool menu_separator_name_p (const char *); extern bool parse_menu_item (Lisp_Object, int); +extern void init_raw_keybuf_count (void); extern KBOARD *allocate_kboard (Lisp_Object); extern void delete_kboard (KBOARD *); extern void not_single_kboard_state (KBOARD *); diff --git a/src/keymap.c b/src/keymap.c index 975688b9d3d..21d37328ade 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -159,7 +159,7 @@ in case you use it as a menu with `x-popup-menu'. */) void initial_define_key (Lisp_Object keymap, int key, const char *defname) { - store_in_keymap (keymap, make_number (key), intern_c_string (defname)); + store_in_keymap (keymap, make_fixnum (key), intern_c_string (defname)); } void @@ -248,7 +248,7 @@ get_keymap (Lisp_Object object, bool error_if_not_keymap, bool autoload) { Lisp_Object tail; - tail = Fnth (make_number (4), tem); + tail = Fnth (make_fixnum (4), tem); if (EQ (tail, Qkeymap)) { if (autoload) @@ -379,28 +379,28 @@ access_keymap_1 (Lisp_Object map, Lisp_Object idx, be put in the canonical order. */ if (SYMBOLP (idx)) idx = reorder_modifiers (idx); - else if (INTEGERP (idx)) + else if (FIXNUMP (idx)) /* Clobber the high bits that can be present on a machine with more than 24 bits of integer. */ - XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1))); + XSETFASTINT (idx, XFIXNUM (idx) & (CHAR_META | (CHAR_META - 1))); /* Handle the special meta -> esc mapping. */ - if (INTEGERP (idx) && XFASTINT (idx) & meta_modifier) + if (FIXNUMP (idx) && XFIXNAT (idx) & meta_modifier) { /* See if there is a meta-map. If there's none, there is no binding for IDX, unless a default binding exists in MAP. */ Lisp_Object event_meta_binding, event_meta_map; /* A strange value in which Meta is set would cause infinite recursion. Protect against that. */ - if (XINT (meta_prefix_char) & CHAR_META) - meta_prefix_char = make_number (27); + if (XFIXNUM (meta_prefix_char) & CHAR_META) + meta_prefix_char = make_fixnum (27); event_meta_binding = access_keymap_1 (map, meta_prefix_char, t_ok, noinherit, autoload); event_meta_map = get_keymap (event_meta_binding, 0, autoload); if (CONSP (event_meta_map)) { map = event_meta_map; - idx = make_number (XFASTINT (idx) & ~meta_modifier); + idx = make_fixnum (XFIXNAT (idx) & ~meta_modifier); } else if (t_ok) /* Set IDX to t, so that we only find a default binding. */ @@ -473,15 +473,15 @@ access_keymap_1 (Lisp_Object map, Lisp_Object idx, } else if (VECTORP (binding)) { - if (INTEGERP (idx) && XFASTINT (idx) < ASIZE (binding)) - val = AREF (binding, XFASTINT (idx)); + if (FIXNUMP (idx) && XFIXNAT (idx) < ASIZE (binding)) + val = AREF (binding, XFIXNAT (idx)); } else if (CHAR_TABLE_P (binding)) { /* Character codes with modifiers are not included in a char-table. All character codes without modifiers are included. */ - if (INTEGERP (idx) && (XFASTINT (idx) & CHAR_MODIFIER_MASK) == 0) + if (FIXNUMP (idx) && (XFIXNAT (idx) & CHAR_MODIFIER_MASK) == 0) { val = Faref (binding, idx); /* nil has a special meaning for char-tables, so @@ -546,19 +546,29 @@ map_keymap_item (map_keymap_function_t fun, Lisp_Object args, Lisp_Object key, L (*fun) (key, val, args, data); } +union map_keymap +{ + struct + { + map_keymap_function_t fun; + Lisp_Object args; + void *data; + } s; + GCALIGNED_UNION_MEMBER +}; +verify (GCALIGNED (union map_keymap)); + static void map_keymap_char_table_item (Lisp_Object args, Lisp_Object key, Lisp_Object val) { if (!NILP (val)) { - map_keymap_function_t fun - = (map_keymap_function_t) XSAVE_FUNCPOINTER (args, 0); /* If the key is a range, make a copy since map_char_table modifies it in place. */ if (CONSP (key)) key = Fcons (XCAR (key), XCDR (key)); - map_keymap_item (fun, XSAVE_OBJECT (args, 2), key, - val, XSAVE_POINTER (args, 1)); + union map_keymap *md = XFIXNUMPTR (args); + map_keymap_item (md->s.fun, md->s.args, key, val, md->s.data); } } @@ -594,9 +604,11 @@ map_keymap_internal (Lisp_Object map, } } else if (CHAR_TABLE_P (binding)) - map_char_table (map_keymap_char_table_item, Qnil, binding, - make_save_funcptr_ptr_obj ((voidfuncptr) fun, data, - args)); + { + union map_keymap mapdata = {{fun, args, data}}; + map_char_table (map_keymap_char_table_item, Qnil, binding, + make_pointer_integer (&mapdata)); + } } return tail; @@ -770,10 +782,10 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) be put in the canonical order. */ if (SYMBOLP (idx)) idx = reorder_modifiers (idx); - else if (INTEGERP (idx)) + else if (FIXNUMP (idx)) /* Clobber the high bits that can be present on a machine with more than 24 bits of integer. */ - XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1))); + XSETFASTINT (idx, XFIXNUM (idx) & (CHAR_META | (CHAR_META - 1))); /* Scan the keymap for a binding of idx. */ { @@ -795,22 +807,22 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) elt = XCAR (tail); if (VECTORP (elt)) { - if (NATNUMP (idx) && XFASTINT (idx) < ASIZE (elt)) + if (FIXNATP (idx) && XFIXNAT (idx) < ASIZE (elt)) { CHECK_IMPURE (elt, XVECTOR (elt)); - ASET (elt, XFASTINT (idx), def); + ASET (elt, XFIXNAT (idx), def); return def; } else if (CONSP (idx) && CHARACTERP (XCAR (idx))) { - int from = XFASTINT (XCAR (idx)); - int to = XFASTINT (XCDR (idx)); + int from = XFIXNAT (XCAR (idx)); + int to = XFIXNAT (XCDR (idx)); if (to >= ASIZE (elt)) to = ASIZE (elt) - 1; for (; from <= to; from++) ASET (elt, from, def); - if (to == XFASTINT (XCDR (idx))) + if (to == XFIXNAT (XCDR (idx))) /* We have defined all keys in IDX. */ return def; } @@ -821,7 +833,7 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) /* Character codes with modifiers are not included in a char-table. All character codes without modifiers are included. */ - if (NATNUMP (idx) && !(XFASTINT (idx) & CHAR_MODIFIER_MASK)) + if (FIXNATP (idx) && !(XFIXNAT (idx) & CHAR_MODIFIER_MASK)) { Faset (elt, idx, /* nil has a special meaning for char-tables, so @@ -858,11 +870,11 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) && CHARACTERP (XCAR (idx)) && CHARACTERP (XCAR (elt))) { - int from = XFASTINT (XCAR (idx)); - int to = XFASTINT (XCDR (idx)); + int from = XFIXNAT (XCAR (idx)); + int to = XFIXNAT (XCDR (idx)); - if (from <= XFASTINT (XCAR (elt)) - && to >= XFASTINT (XCAR (elt))) + if (from <= XFIXNAT (XCAR (elt)) + && to >= XFIXNAT (XCAR (elt))) { XSETCDR (elt, def); if (from == to) @@ -1081,7 +1093,7 @@ binding KEY to DEF is added at the front of KEYMAP. */) if (VECTORP (def) && ASIZE (def) > 0 && CONSP (AREF (def, 0))) { /* DEF is apparently an XEmacs-style keyboard macro. */ - Lisp_Object tmp = Fmake_vector (make_number (ASIZE (def)), Qnil); + Lisp_Object tmp = make_nil_vector (ASIZE (def)); ptrdiff_t i = ASIZE (def); while (--i >= 0) { @@ -1096,7 +1108,7 @@ binding KEY to DEF is added at the front of KEYMAP. */) idx = 0; while (1) { - c = Faref (key, make_number (idx)); + c = Faref (key, make_fixnum (idx)); if (CONSP (c)) { @@ -1111,8 +1123,8 @@ binding KEY to DEF is added at the front of KEYMAP. */) if (SYMBOLP (c)) silly_event_symbol_error (c); - if (INTEGERP (c) - && (XINT (c) & meta_bit) + if (FIXNUMP (c) + && (XFIXNUM (c) & meta_bit) && !metized) { c = meta_prefix_char; @@ -1120,17 +1132,17 @@ binding KEY to DEF is added at the front of KEYMAP. */) } else { - if (INTEGERP (c)) - XSETINT (c, XINT (c) & ~meta_bit); + if (FIXNUMP (c)) + XSETINT (c, XFIXNUM (c) & ~meta_bit); metized = 0; idx++; } - if (!INTEGERP (c) && !SYMBOLP (c) + if (!FIXNUMP (c) && !SYMBOLP (c) && (!CONSP (c) /* If C is a range, it must be a leaf. */ - || (INTEGERP (XCAR (c)) && idx != length))) + || (FIXNUMP (XCAR (c)) && idx != length))) message_with_string ("Key sequence contains invalid event %s", c, 1); if (idx == length) @@ -1153,8 +1165,8 @@ binding KEY to DEF is added at the front of KEYMAP. */) error; key might be a vector, not a string. */ error ("Key sequence %s starts with non-prefix key %s%s", SDATA (Fkey_description (key, Qnil)), - SDATA (Fkey_description (Fsubstring (key, make_number (0), - make_number (idx)), + SDATA (Fkey_description (Fsubstring (key, make_fixnum (0), + make_fixnum (idx)), Qnil)), trailing_esc); } @@ -1174,7 +1186,7 @@ number or marker, in which case the keymap properties at the specified buffer position instead of point are used. The KEYMAPS argument is ignored if POSITION is non-nil. -If the optional argument KEYMAPS is non-nil, it should be a list of +If the optional argument KEYMAPS is non-nil, it should be a keymap or list of keymaps to search for command remapping. Otherwise, search for the remapping in all currently active keymaps. */) (Lisp_Object command, Lisp_Object position, Lisp_Object keymaps) @@ -1187,16 +1199,15 @@ remapping in all currently active keymaps. */) if (NILP (keymaps)) command = Fkey_binding (command_remapping_vector, Qnil, Qt, position); else - command = Flookup_key (Fcons (Qkeymap, keymaps), - command_remapping_vector, Qnil); - return INTEGERP (command) ? Qnil : command; + command = Flookup_key (keymaps, command_remapping_vector, Qnil); + return FIXNUMP (command) ? Qnil : command; } /* Value is number if KEY is too long; nil if valid but has no definition. */ /* GC is possible in this function. */ DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0, - doc: /* In keymap KEYMAP, look up key sequence KEY. Return the definition. + doc: /* Look up key sequence KEY in KEYMAP. Return the definition. A value of nil means undefined. See doc of `define-key' for kinds of definitions. @@ -1205,6 +1216,7 @@ that is, characters or symbols in it except for the last one fail to be a valid sequence of prefix characters in KEYMAP. The number is how many characters at the front of KEY it takes to reach a non-prefix key. +KEYMAP can also be a list of keymaps. Normally, `lookup-key' ignores bindings for t, which act as default bindings, used when nothing else in the keymap applies; this makes it @@ -1219,7 +1231,8 @@ recognize the default bindings, just as `read-key-sequence' does. */) ptrdiff_t length; bool t_ok = !NILP (accept_default); - keymap = get_keymap (keymap, 1, 1); + if (!CONSP (keymap) && !NILP (keymap)) + keymap = get_keymap (keymap, true, true); length = CHECK_VECTOR_OR_STRING (key); if (length == 0) @@ -1228,18 +1241,18 @@ recognize the default bindings, just as `read-key-sequence' does. */) idx = 0; while (1) { - c = Faref (key, make_number (idx++)); + c = Faref (key, make_fixnum (idx++)); if (CONSP (c) && lucid_event_type_list_p (c)) c = Fevent_convert_list (c); /* Turn the 8th bit of string chars into a meta modifier. */ - if (STRINGP (key) && XINT (c) & 0x80 && !STRING_MULTIBYTE (key)) - XSETINT (c, (XINT (c) | meta_modifier) & ~0x80); + if (STRINGP (key) && XFIXNUM (c) & 0x80 && !STRING_MULTIBYTE (key)) + XSETINT (c, (XFIXNUM (c) | meta_modifier) & ~0x80); /* Allow string since binding for `menu-bar-select-buffer' includes the buffer name in the key sequence. */ - if (!INTEGERP (c) && !SYMBOLP (c) && !CONSP (c) && !STRINGP (c)) + if (!FIXNUMP (c) && !SYMBOLP (c) && !CONSP (c) && !STRINGP (c)) message_with_string ("Key sequence contains invalid event %s", c, 1); cmd = access_keymap (keymap, c, t_ok, 0, 1); @@ -1248,7 +1261,7 @@ recognize the default bindings, just as `read-key-sequence' does. */) keymap = get_keymap (cmd, 0, 1); if (!CONSP (keymap)) - return make_number (idx); + return make_fixnum (idx); maybe_quit (); } @@ -1288,7 +1301,7 @@ silly_event_symbol_error (Lisp_Object c) int modifiers; parsed = parse_modifiers (c); - modifiers = XFASTINT (XCAR (XCDR (parsed))); + modifiers = XFIXNAT (XCAR (XCDR (parsed))); base = XCAR (parsed); name = Fsymbol_name (base); /* This alist includes elements such as ("RET" . "\\r"). */ @@ -1462,7 +1475,7 @@ current_minor_maps (Lisp_Object **modeptr, Lisp_Object **mapptr) static ptrdiff_t click_position (Lisp_Object position) { - EMACS_INT pos = (INTEGERP (position) ? XINT (position) + EMACS_INT pos = (FIXNUMP (position) ? XFIXNUM (position) : MARKERP (position) ? marker_position (position) : PT); if (! (BEGV <= pos && pos <= ZV)) @@ -1540,13 +1553,13 @@ like in the respective argument of `key-binding'. */) Lisp_Object pos; pos = POSN_BUFFER_POSN (position); - if (INTEGERP (pos) - && XINT (pos) >= BEG && XINT (pos) <= Z) + if (FIXNUMP (pos) + && XFIXNUM (pos) >= BEG && XFIXNUM (pos) <= Z) { - local_map = get_local_map (XINT (pos), + local_map = get_local_map (XFIXNUM (pos), current_buffer, Qlocal_map); - keymap = get_local_map (XINT (pos), + keymap = get_local_map (XFIXNUM (pos), current_buffer, Qkeymap); } } @@ -1563,9 +1576,9 @@ like in the respective argument of `key-binding'. */) pos = XCDR (string); string = XCAR (string); - if (INTEGERP (pos) - && XINT (pos) >= 0 - && XINT (pos) < SCHARS (string)) + if (FIXNUMP (pos) + && XFIXNUM (pos) >= 0 + && XFIXNUM (pos) < SCHARS (string)) { map = Fget_text_property (pos, Qlocal_map, string); if (!NILP (map)) @@ -1596,9 +1609,7 @@ like in the respective argument of `key-binding'. */) keymaps = Fcons (otlp, keymaps); } - unbind_to (count, Qnil); - - return keymaps; + return unbind_to (count, keymaps); } /* GC is possible in this function if it autoloads a keymap. */ @@ -1654,10 +1665,10 @@ specified buffer position instead of point are used. } } - value = Flookup_key (Fcons (Qkeymap, Fcurrent_active_maps (Qt, position)), + value = Flookup_key (Fcurrent_active_maps (Qt, position), key, accept_default); - if (NILP (value) || INTEGERP (value)) + if (NILP (value) || FIXNUMP (value)) return Qnil; /* If the result of the ordinary keymap lookup is an interactive @@ -1735,7 +1746,7 @@ bindings; see the description of `lookup-key' for more details about this. */) for (i = j = 0; i < nmaps; i++) if (!NILP (maps[i]) && !NILP (binding = Flookup_key (maps[i], key, accept_default)) - && !INTEGERP (binding)) + && !FIXNUMP (binding)) { if (KEYMAPP (binding)) maps[j++] = Fcons (modes[i], binding); @@ -1833,7 +1844,7 @@ accessible_keymaps_1 (Lisp_Object key, Lisp_Object cmd, Lisp_Object args, void * Lisp_Object maps = d->maps; Lisp_Object tail = d->tail; Lisp_Object thisseq = d->thisseq; - bool is_metized = d->is_metized && INTEGERP (key); + bool is_metized = d->is_metized && FIXNUMP (key); Lisp_Object tem; cmd = get_keymap (get_keyelt (cmd, 0), 0, 0); @@ -1844,12 +1855,12 @@ accessible_keymaps_1 (Lisp_Object key, Lisp_Object cmd, Lisp_Object args, void * while (!NILP (tem = Frassq (cmd, maps))) { Lisp_Object prefix = XCAR (tem); - ptrdiff_t lim = XINT (Flength (XCAR (tem))); - if (lim <= XINT (Flength (thisseq))) + ptrdiff_t lim = XFIXNUM (Flength (XCAR (tem))); + if (lim <= XFIXNUM (Flength (thisseq))) { /* This keymap was already seen with a smaller prefix. */ ptrdiff_t i = 0; - while (i < lim && EQ (Faref (prefix, make_number (i)), - Faref (thisseq, make_number (i)))) + while (i < lim && EQ (Faref (prefix, make_fixnum (i)), + Faref (thisseq, make_fixnum (i)))) i++; if (i >= lim) /* `prefix' is a prefix of `thisseq' => there's a cycle. */ @@ -1869,10 +1880,10 @@ accessible_keymaps_1 (Lisp_Object key, Lisp_Object cmd, Lisp_Object args, void * if (is_metized) { int meta_bit = meta_modifier; - Lisp_Object last = make_number (XINT (Flength (thisseq)) - 1); + Lisp_Object last = make_fixnum (XFIXNUM (Flength (thisseq)) - 1); tem = Fcopy_sequence (thisseq); - Faset (tem, last, make_number (XINT (key) | meta_bit)); + Faset (tem, last, make_fixnum (XFIXNUM (key) | meta_bit)); /* This new sequence is the same length as thisseq, so stick it in the list right @@ -1900,7 +1911,7 @@ then the value includes only maps for prefixes that start with PREFIX. */) (Lisp_Object keymap, Lisp_Object prefix) { Lisp_Object maps, tail; - EMACS_INT prefixlen = XFASTINT (Flength (prefix)); + EMACS_INT prefixlen = XFIXNAT (Flength (prefix)); if (!NILP (prefix)) { @@ -1920,18 +1931,16 @@ then the value includes only maps for prefixes that start with PREFIX. */) we don't have to deal with the possibility of a string. */ if (STRINGP (prefix)) { - int i, i_byte, c; - Lisp_Object copy; - - copy = Fmake_vector (make_number (SCHARS (prefix)), Qnil); - for (i = 0, i_byte = 0; i < SCHARS (prefix);) + ptrdiff_t i_byte = 0; + Lisp_Object copy = make_nil_vector (SCHARS (prefix)); + for (ptrdiff_t i = 0; i < SCHARS (prefix); ) { - int i_before = i; - + ptrdiff_t i_before = i; + int c; FETCH_STRING_CHAR_ADVANCE (c, prefix, i, i_byte); if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) c ^= 0200 | meta_modifier; - ASET (copy, i_before, make_number (c)); + ASET (copy, i_before, make_fixnum (c)); } prefix = copy; } @@ -1959,11 +1968,11 @@ then the value includes only maps for prefixes that start with PREFIX. */) data.thisseq = Fcar (XCAR (tail)); data.maps = maps; data.tail = tail; - last = make_number (XINT (Flength (data.thisseq)) - 1); + last = make_fixnum (XFIXNUM (Flength (data.thisseq)) - 1); /* Does the current sequence end in the meta-prefix-char? */ - data.is_metized = (XINT (last) >= 0 + data.is_metized = (XFIXNUM (last) >= 0 /* Don't metize the last char of PREFIX. */ - && XINT (last) >= prefixlen + && XFIXNUM (last) >= prefixlen && EQ (Faref (data.thisseq, last), meta_prefix_char)); /* Since we can't run lisp code, we can't scan autoloaded maps. */ @@ -1987,7 +1996,7 @@ For an approximate inverse of this, see `kbd'. */) EMACS_INT i; ptrdiff_t i_byte; Lisp_Object *args; - EMACS_INT size = XINT (Flength (keys)); + EMACS_INT size = XFIXNUM (Flength (keys)); Lisp_Object list; Lisp_Object sep = build_string (" "); Lisp_Object key; @@ -1996,7 +2005,7 @@ For an approximate inverse of this, see `kbd'. */) USE_SAFE_ALLOCA; if (!NILP (prefix)) - size += XINT (Flength (prefix)); + size += XFIXNUM (Flength (prefix)); /* This has one extra element at the end that we don't pass to Fconcat. */ EMACS_INT size4; @@ -2033,7 +2042,7 @@ For an approximate inverse of this, see `kbd'. */) else if (VECTORP (list)) size = ASIZE (list); else if (CONSP (list)) - size = XINT (Flength (list)); + size = XFIXNUM (Flength (list)); else wrong_type_argument (Qarrayp, list); @@ -2062,9 +2071,9 @@ For an approximate inverse of this, see `kbd'. */) if (add_meta) { - if (!INTEGERP (key) + if (!FIXNUMP (key) || EQ (key, meta_prefix_char) - || (XINT (key) & meta_modifier)) + || (XFIXNUM (key) & meta_modifier)) { args[len++] = Fsingle_key_description (meta_prefix_char, Qnil); args[len++] = sep; @@ -2072,7 +2081,7 @@ For an approximate inverse of this, see `kbd'. */) continue; } else - XSETINT (key, XINT (key) | meta_modifier); + XSETINT (key, XFIXNUM (key) | meta_modifier); add_meta = 0; } else if (EQ (key, meta_prefix_char)) @@ -2098,7 +2107,7 @@ push_key_description (EMACS_INT ch, char *p) c2 = c & ~(alt_modifier | ctrl_modifier | hyper_modifier | meta_modifier | shift_modifier | super_modifier); - if (! CHARACTERP (make_number (c2))) + if (! CHARACTERP (make_fixnum (c2))) { /* KEY_DESCRIPTION_SIZE is large enough for this. */ p += sprintf (p, "[%d]", c); @@ -2218,7 +2227,7 @@ See `text-char-description' for describing character codes. */) if (CONSP (key) && lucid_event_type_list_p (key)) key = Fevent_convert_list (key); - if (CONSP (key) && INTEGERP (XCAR (key)) && INTEGERP (XCDR (key))) + if (CONSP (key) && FIXNUMP (XCAR (key)) && FIXNUMP (XCDR (key))) /* An interval from a map-char-table. */ { AUTO_STRING (dot_dot, ".."); @@ -2229,10 +2238,10 @@ See `text-char-description' for describing character codes. */) key = EVENT_HEAD (key); - if (INTEGERP (key)) /* Normal character. */ + if (FIXNUMP (key)) /* Normal character. */ { char tem[KEY_DESCRIPTION_SIZE]; - char *p = push_key_description (XINT (key), tem); + char *p = push_key_description (XFIXNUM (key), tem); *p = 0; return make_specified_string (tem, -1, p - tem, 1); } @@ -2300,7 +2309,7 @@ See Info node `(elisp)Describing Characters' for examples. */) CHECK_CHARACTER (character); - c = XINT (character); + c = XFIXNUM (character); if (!ASCII_CHAR_P (c)) { int len = CHAR_STRING (c, (unsigned char *) str); @@ -2322,7 +2331,7 @@ static int preferred_sequence_p (Lisp_Object seq) { EMACS_INT i; - EMACS_INT len = XFASTINT (Flength (seq)); + EMACS_INT len = XFIXNAT (Flength (seq)); int result = 1; for (i = 0; i < len; i++) @@ -2332,11 +2341,11 @@ preferred_sequence_p (Lisp_Object seq) XSETFASTINT (ii, i); elt = Faref (seq, ii); - if (!INTEGERP (elt)) + if (!FIXNUMP (elt)) return 0; else { - int modifiers = XINT (elt) & (CHAR_MODIFIER_MASK & ~CHAR_META); + int modifiers = XFIXNUM (elt) & (CHAR_MODIFIER_MASK & ~CHAR_META); if (modifiers == where_is_preferred_modifier) result = 2; else if (modifiers) @@ -2353,39 +2362,24 @@ preferred_sequence_p (Lisp_Object seq) static void where_is_internal_1 (Lisp_Object key, Lisp_Object binding, Lisp_Object args, void *data); -/* Like Flookup_key, but uses a list of keymaps SHADOW instead of a single map. - Returns the first non-nil binding found in any of those maps. - If REMAP is true, pass the result of the lookup through command - remapping before returning it. */ +/* Like Flookup_key, but with command remapping; just returns nil + if the key sequence is too long. */ static Lisp_Object -shadow_lookup (Lisp_Object shadow, Lisp_Object key, Lisp_Object flag, +shadow_lookup (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default, bool remap) { - Lisp_Object tail, value; + Lisp_Object value = Flookup_key (keymap, key, accept_default); - for (tail = shadow; CONSP (tail); tail = XCDR (tail)) + if (FIXNATP (value)) /* `key' is too long! */ + return Qnil; + else if (!NILP (value) && remap && SYMBOLP (value)) { - value = Flookup_key (XCAR (tail), key, flag); - if (NATNUMP (value)) - { - value = Flookup_key (XCAR (tail), - Fsubstring (key, make_number (0), value), flag); - if (!NILP (value)) - return Qnil; - } - else if (!NILP (value)) - { - Lisp_Object remapping; - if (remap && SYMBOLP (value) - && (remapping = Fcommand_remapping (value, Qnil, shadow), - !NILP (remapping))) - return remapping; - else - return value; - } + Lisp_Object remapping = Fcommand_remapping (value, Qnil, keymap); + return (!NILP (remapping) ? remapping : value); } - return Qnil; + else + return value; } static Lisp_Object Vmouse_events; @@ -2457,13 +2451,13 @@ where_is_internal (Lisp_Object definition, Lisp_Object keymaps, this = Fcar (XCAR (maps)); map = Fcdr (XCAR (maps)); - last = make_number (XINT (Flength (this)) - 1); - last_is_meta = (XINT (last) >= 0 + last = make_fixnum (XFIXNUM (Flength (this)) - 1); + last_is_meta = (XFIXNUM (last) >= 0 && EQ (Faref (this, last), meta_prefix_char)); /* if (nomenus && !preferred_sequence_p (this)) */ - if (nomenus && XINT (last) >= 0 - && SYMBOLP (tem = Faref (this, make_number (0))) + if (nomenus && XFIXNUM (last) >= 0 + && SYMBOLP (tem = Faref (this, make_fixnum (0))) && !NILP (Fmemq (XCAR (parse_modifiers (tem)), Vmouse_events))) /* If no menu entries should be returned, skip over the keymaps bound to `menu-bar' and `tool-bar' and other @@ -2559,7 +2553,7 @@ The optional 5th arg NO-REMAP alters how command remapping is handled: keymaps = Fcurrent_active_maps (Qnil, Qnil); tem = Fcommand_remapping (definition, Qnil, keymaps); - /* If `definition' is remapped to tem', then OT1H no key will run + /* If `definition' is remapped to `tem', then OT1H no key will run that command (since they will run `tem' instead), so we should return nil; but OTOH all keys bound to `definition' (or to `tem') will run the same command. @@ -2581,6 +2575,8 @@ The optional 5th arg NO-REMAP alters how command remapping is handled: && !NILP (tem = Fget (definition, QCadvertised_binding))) { /* We have a list of advertised bindings. */ + /* FIXME: Not sure why we use false for shadow_lookup's remapping, + nor why we use `EQ' here but `Fequal' in the call further down. */ while (CONSP (tem)) if (EQ (shadow_lookup (keymaps, XCAR (tem), Qnil, 0), definition)) return XCAR (tem); @@ -2640,9 +2636,9 @@ The optional 5th arg NO-REMAP alters how command remapping is handled: if (! NILP (sequence)) { Lisp_Object tem1; - tem1 = Faref (sequence, make_number (ASIZE (sequence) - 1)); + tem1 = Faref (sequence, make_fixnum (ASIZE (sequence) - 1)); if (STRINGP (tem1)) - Faset (sequence, make_number (ASIZE (sequence) - 1), + Faset (sequence, make_fixnum (ASIZE (sequence) - 1), build_string ("(any string)")); } @@ -2711,10 +2707,10 @@ where_is_internal_1 (Lisp_Object key, Lisp_Object binding, Lisp_Object args, voi return; /* We have found a match. Construct the key sequence where we found it. */ - if (INTEGERP (key) && last_is_meta) + if (FIXNUMP (key) && last_is_meta) { sequence = Fcopy_sequence (this); - Faset (sequence, last, make_number (XINT (key) | meta_modifier)); + Faset (sequence, last, make_fixnum (XFIXNUM (key) | meta_modifier)); } else { @@ -2780,7 +2776,7 @@ You type Translation\n\ bufend = push_key_description (translate[c], buf); insert (buf, bufend - buf); - Findent_to (make_number (16), make_number (1)); + Findent_to (make_fixnum (16), make_fixnum (1)); bufend = push_key_description (c, buf); insert (buf, bufend - buf); @@ -2956,7 +2952,7 @@ key binding\n\ elt_prefix = Fcar (elt); if (ASIZE (elt_prefix) >= 1) { - tem = Faref (elt_prefix, make_number (0)); + tem = Faref (elt_prefix, make_fixnum (0)); if (EQ (tem, Qmenu_bar)) maps = Fdelq (elt, maps); } @@ -2986,38 +2982,17 @@ key binding\n\ elt = XCAR (maps); elt_prefix = Fcar (elt); - sub_shadows = Qnil; - - for (tail = shadow; CONSP (tail); tail = XCDR (tail)) - { - Lisp_Object shmap; - - shmap = XCAR (tail); - - /* If the sequence by which we reach this keymap is zero-length, - then the shadow map for this keymap is just SHADOW. */ - if ((STRINGP (elt_prefix) && SCHARS (elt_prefix) == 0) - || (VECTORP (elt_prefix) && ASIZE (elt_prefix) == 0)) - ; - /* If the sequence by which we reach this keymap actually has - some elements, then the sequence's definition in SHADOW is - what we should use. */ - else - { - shmap = Flookup_key (shmap, Fcar (elt), Qt); - if (INTEGERP (shmap)) - shmap = Qnil; - } - - /* If shmap is not nil and not a keymap, + sub_shadows = Flookup_key (shadow, elt_prefix, Qt); + if (FIXNATP (sub_shadows)) + sub_shadows = Qnil; + else if (!KEYMAPP (sub_shadows) + && !NILP (sub_shadows) + && !(CONSP (sub_shadows) + && KEYMAPP (XCAR (sub_shadows)))) + /* If elt_prefix is bound to something that's not a keymap, it completely shadows this map, so don't describe this map at all. */ - if (!NILP (shmap) && !KEYMAPP (shmap)) - goto skip; - - if (!NILP (shmap)) - sub_shadows = Fcons (shmap, sub_shadows); - } + goto skip; /* Maps we have already listed in this loop shadow this map. */ for (tail = orig_maps; !EQ (tail, maps); tail = XCDR (tail)) @@ -3060,7 +3035,7 @@ describe_command (Lisp_Object definition, Lisp_Object args) else description_column = 16; - Findent_to (make_number (description_column), make_number (1)); + Findent_to (make_fixnum (description_column), make_fixnum (1)); previous_description_column = description_column; if (SYMBOLP (definition)) @@ -3082,7 +3057,7 @@ describe_translation (Lisp_Object definition, Lisp_Object args) { register Lisp_Object tem1; - Findent_to (make_number (16), make_number (1)); + Findent_to (make_fixnum (16), make_fixnum (1)); if (SYMBOLP (definition)) { @@ -3119,12 +3094,12 @@ static int describe_map_compare (const void *aa, const void *bb) { const struct describe_map_elt *a = aa, *b = bb; - if (INTEGERP (a->event) && INTEGERP (b->event)) - return ((XINT (a->event) > XINT (b->event)) - - (XINT (a->event) < XINT (b->event))); - if (!INTEGERP (a->event) && INTEGERP (b->event)) + if (FIXNUMP (a->event) && FIXNUMP (b->event)) + return ((XFIXNUM (a->event) > XFIXNUM (b->event)) + - (XFIXNUM (a->event) < XFIXNUM (b->event))); + if (!FIXNUMP (a->event) && FIXNUMP (b->event)) return 1; - if (INTEGERP (a->event) && !INTEGERP (b->event)) + if (FIXNUMP (a->event) && !FIXNUMP (b->event)) return -1; if (SYMBOLP (a->event) && SYMBOLP (b->event)) return (!NILP (Fstring_lessp (a->event, b->event)) ? -1 @@ -3164,7 +3139,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix, /* This vector gets used to present single keys to Flookup_key. Since that is done once per keymap element, we don't want to cons up a fresh vector every time. */ - kludge = Fmake_vector (make_number (1), Qnil); + kludge = make_nil_vector (1); definition = Qnil; map = call1 (Qkeymap_canonicalize, map); @@ -3192,7 +3167,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix, /* Ignore bindings whose "prefix" are not really valid events. (We get these in the frames and buffers menu.) */ - if (!(SYMBOLP (event) || INTEGERP (event))) + if (!(SYMBOLP (event) || FIXNUMP (event))) continue; if (nomenu && EQ (event, Qmenu_bar)) @@ -3276,10 +3251,10 @@ describe_map (Lisp_Object map, Lisp_Object prefix, definition = vect[i].definition; /* Find consecutive chars that are identically defined. */ - if (INTEGERP (vect[i].event)) + if (FIXNUMP (vect[i].event)) { while (i + 1 < slots_used - && EQ (vect[i+1].event, make_number (XINT (vect[i].event) + 1)) + && EQ (vect[i+1].event, make_fixnum (XFIXNUM (vect[i].event) + 1)) && !NILP (Fequal (vect[i + 1].definition, definition)) && vect[i].shadowed == vect[i + 1].shadowed) i++; @@ -3322,7 +3297,7 @@ describe_map (Lisp_Object map, Lisp_Object prefix, static void describe_vector_princ (Lisp_Object elt, Lisp_Object fun) { - Findent_to (make_number (16), make_number (1)); + Findent_to (make_fixnum (16), make_fixnum (1)); call1 (fun, elt); Fterpri (Qnil, Qnil); } @@ -3401,7 +3376,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, if (!keymap_p) { /* Call Fkey_description first, to avoid GC bug for the other string. */ - if (!NILP (prefix) && XFASTINT (Flength (prefix)) > 0) + if (!NILP (prefix) && XFIXNAT (Flength (prefix)) > 0) { Lisp_Object tem = Fkey_description (prefix, Qnil); AUTO_STRING (space, " "); @@ -3413,7 +3388,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, /* This vector gets used to present single keys to Flookup_key. Since that is done once per vector element, we don't want to cons up a fresh vector every time. */ - kludge = Fmake_vector (make_number (1), Qnil); + kludge = make_nil_vector (1); if (partial) suppress = intern ("suppress-keymap"); @@ -3463,7 +3438,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, if (!NILP (tem)) continue; } - character = make_number (starting_i); + character = make_fixnum (starting_i); ASET (kludge, 0, character); /* If this binding is shadowed by some other map, ignore it. */ @@ -3535,7 +3510,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, { insert (" .. ", 4); - ASET (kludge, 0, make_number (i)); + ASET (kludge, 0, make_fixnum (i)); if (!NILP (elt_prefix)) insert1 (elt_prefix); @@ -3612,7 +3587,7 @@ syms_of_keymap (void) /* Now we are ready to set up this property, so we can create char tables. */ - Fput (Qkeymap, Qchar_table_extra_slots, make_number (0)); + Fput (Qkeymap, Qchar_table_extra_slots, make_fixnum (0)); /* Initialize the keymaps standardly used. Each one is the value of a Lisp variable, and is also @@ -3713,7 +3688,7 @@ be preferred. */); DEFSYM (Qremap, "remap"); DEFSYM (QCadvertised_binding, ":advertised-binding"); - command_remapping_vector = Fmake_vector (make_number (2), Qremap); + command_remapping_vector = make_vector (2, Qremap); staticpro (&command_remapping_vector); where_is_cache_keymaps = Qt; diff --git a/src/kqueue.c b/src/kqueue.c index 725a98b0b9f..655bfd58d3b 100644 --- a/src/kqueue.c +++ b/src/kqueue.c @@ -24,7 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <sys/types.h> #include <sys/event.h> #include <sys/time.h> -#include <sys/file.h> +#include <fcntl.h> #include "lisp.h" #include "keyboard.h" #include "process.h" @@ -55,15 +55,15 @@ kqueue_directory_listing (Lisp_Object directory_files) result = Fcons (list5 (/* inode. */ - Fnth (make_number (11), XCAR (dl)), + Fnth (make_fixnum (11), XCAR (dl)), /* filename. */ XCAR (XCAR (dl)), /* last modification time. */ - Fnth (make_number (6), XCAR (dl)), + Fnth (make_fixnum (6), XCAR (dl)), /* last status change time. */ - Fnth (make_number (7), XCAR (dl)), + Fnth (make_fixnum (7), XCAR (dl)), /* size. */ - Fnth (make_number (8), XCAR (dl))), + Fnth (make_fixnum (8), XCAR (dl))), result); } return result; @@ -78,7 +78,7 @@ kqueue_generate_event (Lisp_Object watch_object, Lisp_Object actions, struct input_event event; /* Check, whether all actions shall be monitored. */ - flags = Fnth (make_number (2), watch_object); + flags = Fnth (make_fixnum (2), watch_object); action = actions; do { if (NILP (action)) @@ -101,7 +101,7 @@ kqueue_generate_event (Lisp_Object watch_object, Lisp_Object actions, NILP (file1) ? Fcons (file, Qnil) : list2 (file, file1))), - Fnth (make_number (3), watch_object)); + Fnth (make_fixnum (3), watch_object)); kbd_buffer_store_event (&event); } } @@ -121,7 +121,7 @@ kqueue_compare_dir_list (Lisp_Object watch_object) pending_dl = Qnil; deleted_dl = Qnil; - old_directory_files = Fnth (make_number (4), watch_object); + old_directory_files = Fnth (make_fixnum (4), watch_object); old_dl = kqueue_directory_listing (old_directory_files); /* When the directory is not accessible anymore, it has been deleted. */ @@ -155,14 +155,14 @@ kqueue_compare_dir_list (Lisp_Object watch_object) if (strcmp (SSDATA (XCAR (XCDR (old_entry))), SSDATA (XCAR (XCDR (new_entry)))) == 0) { /* Modification time has been changed, the file has been written. */ - if (NILP (Fequal (Fnth (make_number (2), old_entry), - Fnth (make_number (2), new_entry)))) + if (NILP (Fequal (Fnth (make_fixnum (2), old_entry), + Fnth (make_fixnum (2), new_entry)))) kqueue_generate_event (watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (old_entry)), Qnil); /* Status change time has been changed, the file attributes have changed. */ - if (NILP (Fequal (Fnth (make_number (3), old_entry), - Fnth (make_number (3), new_entry)))) + if (NILP (Fequal (Fnth (make_fixnum (3), old_entry), + Fnth (make_fixnum (3), new_entry)))) kqueue_generate_event (watch_object, Fcons (Qattrib, Qnil), XCAR (XCDR (old_entry)), Qnil); @@ -233,8 +233,8 @@ kqueue_compare_dir_list (Lisp_Object watch_object) (watch_object, Fcons (Qcreate, Qnil), XCAR (XCDR (entry)), Qnil); /* Check size of that file. */ - Lisp_Object size = Fnth (make_number (4), entry); - if (FLOATP (size) || (XINT (size) > 0)) + Lisp_Object size = Fnth (make_fixnum (4), entry); + if (FLOATP (size) || (XFIXNUM (size) > 0)) kqueue_generate_event (watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (entry)), Qnil); @@ -270,7 +270,7 @@ kqueue_compare_dir_list (Lisp_Object watch_object) report_file_error ("Pending events list not empty", pending_dl); /* Replace old directory listing with the new one. */ - XSETCDR (Fnthcdr (make_number (3), watch_object), + XSETCDR (Fnthcdr (make_fixnum (3), watch_object), Fcons (new_directory_files, Qnil)); return; } @@ -293,7 +293,7 @@ kqueue_callback (int fd, void *data) } /* Determine descriptor and file name. */ - descriptor = make_number (kev.ident); + descriptor = make_fixnum (kev.ident); watch_object = assq_no_quit (descriptor, watch_list); if (CONSP (watch_object)) file = XCAR (XCDR (watch_object)); @@ -306,7 +306,7 @@ kqueue_callback (int fd, void *data) actions = Fcons (Qdelete, actions); if (kev.fflags & NOTE_WRITE) { /* Check, whether this is a directory event. */ - if (NILP (Fnth (make_number (4), watch_object))) + if (NILP (Fnth (make_fixnum (4), watch_object))) actions = Fcons (Qwrite, actions); else kqueue_compare_dir_list (watch_object); @@ -395,7 +395,7 @@ only when the upper directory of the renamed file is watched. */) maxfd = 256; /* We assume 50 file descriptors are sufficient for the rest of Emacs. */ - if ((maxfd - 50) < XINT (Flength (watch_list))) + if ((maxfd - 50) < XFIXNUM (Flength (watch_list))) xsignal2 (Qfile_notify_error, build_string ("File watching not possible, no file descriptor left"), @@ -449,7 +449,7 @@ only when the upper directory of the renamed file is watched. */) } /* Store watch object in watch list. */ - Lisp_Object watch_descriptor = make_number (fd); + Lisp_Object watch_descriptor = make_fixnum (fd); if (NILP (Ffile_directory_p (file))) watch_object = list4 (watch_descriptor, file, flags, callback); else { @@ -473,8 +473,8 @@ WATCH-DESCRIPTOR should be an object returned by `kqueue-add-watch'. */) xsignal2 (Qfile_notify_error, build_string ("Not a watch descriptor"), watch_descriptor); - eassert (INTEGERP (watch_descriptor)); - int fd = XINT (watch_descriptor); + eassert (FIXNUMP (watch_descriptor)); + int fd = XFIXNUM (watch_descriptor); if ( fd >= 0) emacs_close (fd); diff --git a/src/lastfile.c b/src/lastfile.c index 5c7e5b8b26d..706f667dbb9 100644 --- a/src/lastfile.c +++ b/src/lastfile.c @@ -49,9 +49,6 @@ char my_edata[] = "End of Emacs initialized data"; isn't always a separate section in NT executables). */ char my_endbss[1]; -/* The Alpha MSVC linker globally segregates all static and public bss - data, so we must take both into account to determine the true extent - of the bss area used by Emacs. */ static char _my_endbss[1]; char * my_endbss_static = _my_endbss; diff --git a/src/lcms.c b/src/lcms.c index 65cbf44e0f9..cd8de0e45a8 100644 --- a/src/lcms.c +++ b/src/lcms.c @@ -34,6 +34,7 @@ typedef struct #ifdef WINDOWSNT # include <windows.h> +# include "w32common.h" # include "w32.h" DEF_DLL_FN (cmsFloat64Number, cmsCIE2000DeltaE, @@ -251,10 +252,10 @@ parse_viewing_conditions (Lisp_Object view, const cmsCIEXYZ *wp, else \ return false; #define PARSE_VIEW_CONDITION_INT(field) \ - if (CONSP (view) && NATNUMP (XCAR (view))) \ + if (CONSP (view) && FIXNATP (XCAR (view))) \ { \ CHECK_RANGED_INTEGER (XCAR (view), 1, 4); \ - vc->field = XINT (XCAR (view)); \ + vc->field = XFIXNUM (XCAR (view)); \ view = XCDR (view); \ } \ else \ @@ -554,7 +555,7 @@ Valid range of TEMPERATURE is from 4000K to 25000K. */) } #endif - CHECK_NUMBER_OR_FLOAT (temperature); + CHECK_NUMBER (temperature); tempK = XFLOATINT (temperature); if (!(cmsWhitePointFromTemp (&whitepoint, tempK))) diff --git a/src/lisp.h b/src/lisp.h index 08c6dbdf72b..b650702bddc 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -228,28 +228,22 @@ extern bool suppress_checking EXTERNALLY_VISIBLE; USE_LSB_TAG not only requires the least 3 bits of pointers returned by malloc to be 0 but also needs to be able to impose a mult-of-8 alignment - on the few static Lisp_Objects used, all of which are aligned via - 'char alignas (GCALIGNMENT) gcaligned;' inside a union. */ + on some non-GC Lisp_Objects, all of which are aligned via + GCALIGNED_UNION_MEMBER. */ enum Lisp_Bits { - /* 2**GCTYPEBITS. This must be a macro that expands to a literal - integer constant, for older versions of GCC (through at least 4.9). */ -#define GCALIGNMENT 8 - /* Number of bits in a Lisp_Object value, not counting the tag. */ VALBITS = EMACS_INT_WIDTH - GCTYPEBITS, - /* Number of bits in a Lisp fixnum tag. */ - INTTYPEBITS = GCTYPEBITS - 1, - /* Number of bits in a Lisp fixnum value, not counting the tag. */ FIXNUM_BITS = VALBITS + 1 }; -#if GCALIGNMENT != 1 << GCTYPEBITS -# error "GCALIGNMENT and GCTYPEBITS are inconsistent" -#endif +/* Number of bits in a Lisp fixnum tag; can be used in #if. */ +DEFINE_GDB_SYMBOL_BEGIN (int, INTTYPEBITS) +#define INTTYPEBITS (GCTYPEBITS - 1) +DEFINE_GDB_SYMBOL_END (INTTYPEBITS) /* The maximum value that can be stored in a EMACS_INT, assuming all bits other than the type bits contribute to a nonnegative signed value. @@ -277,6 +271,58 @@ DEFINE_GDB_SYMBOL_END (VALMASK) error !; #endif +/* Minimum alignment requirement for Lisp objects, imposed by the + internal representation of tagged pointers. It is 2**GCTYPEBITS if + USE_LSB_TAG, 1 otherwise. It must be a literal integer constant, + for older versions of GCC (through at least 4.9). */ +#if USE_LSB_TAG +# define GCALIGNMENT 8 +# if GCALIGNMENT != 1 << GCTYPEBITS +# error "GCALIGNMENT and GCTYPEBITS are inconsistent" +# endif +#else +# define GCALIGNMENT 1 +#endif + +/* To cause a union to have alignment of at least GCALIGNMENT, put + GCALIGNED_UNION_MEMBER in its member list. + + If a struct is always GC-aligned (either by the GC, or via + allocation in a containing union that has GCALIGNED_UNION_MEMBER) + and does not contain a GC-aligned struct or union, putting + GCALIGNED_STRUCT after its closing '}' can help the compiler + generate better code. + + Although these macros are reasonably portable, they are not + guaranteed on non-GCC platforms, as C11 does not require support + for alignment to GCALIGNMENT and older compilers may ignore + alignment requests. For any type T where garbage collection + requires alignment, use verify (GCALIGNED (T)) to verify the + requirement on the current platform. Types need this check if + their objects can be allocated outside the garbage collector. For + example, struct Lisp_Symbol needs the check because of lispsym and + struct Lisp_Cons needs it because of STACK_CONS. */ + +#define GCALIGNED_UNION_MEMBER char alignas (GCALIGNMENT) gcaligned; +#if HAVE_STRUCT_ATTRIBUTE_ALIGNED +# define GCALIGNED_STRUCT __attribute__ ((aligned (GCALIGNMENT))) +#else +# define GCALIGNED_STRUCT +#endif +#define GCALIGNED(type) (alignof (type) % GCALIGNMENT == 0) + +/* Lisp_Word is a scalar word suitable for holding a tagged pointer or + integer. Usually it is a pointer to a deliberately-incomplete type + 'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and + pointers differ in width. */ + +#define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX) +#if LISP_WORDS_ARE_POINTERS +typedef union Lisp_X *Lisp_Word; +#else +typedef EMACS_INT Lisp_Word; +#endif + /* Some operations are so commonly executed that they are implemented as macros, not functions, because otherwise runtime performance would suffer too much when compiling with GCC without optimization. @@ -302,26 +348,48 @@ error !; 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. */ - -#if CHECK_LISP_OBJECT_TYPE -# define lisp_h_XLI(o) ((o).i) -# define lisp_h_XIL(i) ((Lisp_Object) { i }) + For the macros that have corresponding functions (defined later), + see these functions for commentary. */ + +/* Convert among the various Lisp-related types: I for EMACS_INT, L + for Lisp_Object, P for void *. */ +#if !CHECK_LISP_OBJECT_TYPE +# if LISP_WORDS_ARE_POINTERS +# define lisp_h_XLI(o) ((EMACS_INT) (o)) +# define lisp_h_XIL(i) ((Lisp_Object) (i)) +# define lisp_h_XLP(o) ((void *) (o)) +# define lisp_h_XPL(p) ((Lisp_Object) (p)) +# else +# define lisp_h_XLI(o) (o) +# define lisp_h_XIL(i) (i) +# define lisp_h_XLP(o) ((void *) (uintptr_t) (o)) +# define lisp_h_XPL(p) ((Lisp_Object) (uintptr_t) (p)) +# endif #else -# define lisp_h_XLI(o) (o) -# define lisp_h_XIL(i) (i) +# if LISP_WORDS_ARE_POINTERS +# define lisp_h_XLI(o) ((EMACS_INT) (o).i) +# define lisp_h_XIL(i) ((Lisp_Object) {(Lisp_Word) (i)}) +# define lisp_h_XLP(o) ((void *) (o).i) +# define lisp_h_XPL(p) lisp_h_XIL (p) +# else +# define lisp_h_XLI(o) ((o).i) +# define lisp_h_XIL(i) ((Lisp_Object) {i}) +# define lisp_h_XLP(o) ((void *) (uintptr_t) (o).i) +# define lisp_h_XPL(p) ((Lisp_Object) {(uintptr_t) (p)}) +# endif #endif -#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x) + +#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ ((ok) ? (void) 0 : wrong_type_argument (predicate, x)) -#define lisp_h_CONSP(x) (XTYPE (x) == Lisp_Cons) +#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons) #define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) -#define lisp_h_FLOATP(x) (XTYPE (x) == Lisp_Float) -#define lisp_h_INTEGERP(x) ((XTYPE (x) & (Lisp_Int0 | ~Lisp_Int1)) == Lisp_Int0) -#define lisp_h_MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker) -#define lisp_h_MISCP(x) (XTYPE (x) == Lisp_Misc) +#define lisp_h_FIXNUMP(x) \ + (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \ + & ((1 << INTTYPEBITS) - 1))) +#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float) #define lisp_h_NILP(x) EQ (x, Qnil) #define lisp_h_SET_SYMBOL_VAL(sym, v) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \ @@ -331,29 +399,39 @@ error !; #define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write) #define lisp_h_SYMBOL_VAL(sym) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value) -#define lisp_h_SYMBOLP(x) (XTYPE (x) == Lisp_Symbol) -#define lisp_h_VECTORLIKEP(x) (XTYPE (x) == Lisp_Vectorlike) +#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol) +#define lisp_h_TAGGEDP(a, tag) \ + (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ + - (unsigned) (tag)) \ + & ((1 << GCTYPEBITS) - 1))) +#define lisp_h_VECTORLIKEP(x) TAGGEDP (x, Lisp_Vectorlike) #define lisp_h_XCAR(c) XCONS (c)->u.s.car #define lisp_h_XCDR(c) XCONS (c)->u.s.u.cdr #define lisp_h_XCONS(a) \ - (eassert (CONSP (a)), (struct Lisp_Cons *) XUNTAG (a, Lisp_Cons)) -#define lisp_h_XHASH(a) XUINT (a) + (eassert (CONSP (a)), XUNTAG (a, Lisp_Cons, struct Lisp_Cons)) +#define lisp_h_XHASH(a) XUFIXNUM (a) #ifndef GC_CHECK_CONS_LIST # define lisp_h_check_cons_list() ((void) 0) #endif #if USE_LSB_TAG -# define lisp_h_make_number(n) \ +# define lisp_h_make_fixnum(n) \ XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0)) -# define lisp_h_XFASTINT(a) XINT (a) -# define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS) -# define lisp_h_XSYMBOL(a) \ +# define lisp_h_XFIXNAT(a) XFIXNUM (a) +# define lisp_h_XFIXNUM(a) (XLI (a) >> INTTYPEBITS) +# ifdef __CHKP__ +# define lisp_h_XSYMBOL(a) \ + (eassert (SYMBOLP (a)), \ + (struct Lisp_Symbol *) ((char *) XUNTAG (a, Lisp_Symbol, \ + struct Lisp_Symbol) \ + + (intptr_t) lispsym)) +# else + /* If !__CHKP__ this is equivalent, and is a bit faster as of GCC 7. */ +# define lisp_h_XSYMBOL(a) \ (eassert (SYMBOLP (a)), \ (struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \ + (char *) lispsym)) +# endif # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) -# 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 @@ -370,21 +448,22 @@ error !; #if DEFINE_KEY_OPS_AS_MACROS # define XLI(o) lisp_h_XLI (o) # define XIL(i) lisp_h_XIL (i) -# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x) +# define XLP(o) lisp_h_XLP (o) +# define XPL(p) lisp_h_XPL (p) +# define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) # define CONSP(x) lisp_h_CONSP (x) # define EQ(x, y) lisp_h_EQ (x, y) # define FLOATP(x) lisp_h_FLOATP (x) -# define INTEGERP(x) lisp_h_INTEGERP (x) -# define MARKERP(x) lisp_h_MARKERP (x) -# define MISCP(x) lisp_h_MISCP (x) +# define FIXNUMP(x) lisp_h_FIXNUMP (x) # 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 TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) # define XCAR(c) lisp_h_XCAR (c) # define XCDR(c) lisp_h_XCDR (c) @@ -394,12 +473,11 @@ error !; # define check_cons_list() lisp_h_check_cons_list () # endif # if USE_LSB_TAG -# define make_number(n) lisp_h_make_number (n) -# define XFASTINT(a) lisp_h_XFASTINT (a) -# define XINT(a) lisp_h_XINT (a) +# define make_fixnum(n) lisp_h_make_fixnum (n) +# define XFIXNAT(a) lisp_h_XFIXNAT (a) +# define XFIXNUM(a) lisp_h_XFIXNUM (a) # define XSYMBOL(a) lisp_h_XSYMBOL (a) # define XTYPE(a) lisp_h_XTYPE (a) -# define XUNTAG(a, type) lisp_h_XUNTAG (a, type) # endif #endif @@ -416,9 +494,8 @@ error !; #define case_Lisp_Int case Lisp_Int0: case Lisp_Int1 /* Idea stolen from GDB. Pedantic GCC complains about enum bitfields, - MSVC doesn't support them, and xlc and Oracle Studio c99 complain - vociferously about them. */ -#if (defined __STRICT_ANSI__ || defined _MSC_VER || defined __IBMC__ \ + and xlc and Oracle Studio c99 complain vociferously about them. */ +#if (defined __STRICT_ANSI__ || defined __IBMC__ \ || (defined __SUNPRO_C && __STDC__)) #define ENUM_BF(TYPE) unsigned int #else @@ -431,11 +508,9 @@ enum Lisp_Type /* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */ Lisp_Symbol = 0, - /* Miscellaneous. XMISC (object) points to a union Lisp_Misc, - whose first member indicates the subtype. */ - Lisp_Misc = 1, + /* Type 1 is currently unused. */ - /* Integer. XINT (obj) is the integer value. */ + /* Fixnum. XFIXNUM (obj) is the integer value. */ Lisp_Int0 = 2, Lisp_Int1 = USE_LSB_TAG ? 6 : 3, @@ -455,25 +530,6 @@ enum Lisp_Type Lisp_Float = 7 }; -/* This is the set of data types that share a common structure. - The first member of the structure is a type code from this set. - The enum values are arbitrary, but we'll use large numbers to make it - more likely that we'll spot the error if a random word in memory is - mistakenly interpreted as a Lisp_Misc. */ -enum Lisp_Misc_Type - { - Lisp_Misc_Free = 0x5eab, - Lisp_Misc_Marker, - Lisp_Misc_Overlay, - Lisp_Misc_Save_Value, - Lisp_Misc_Finalizer, -#ifdef HAVE_MODULES - Lisp_Misc_User_Ptr, -#endif - /* This is not a type code. It is for range checking. */ - Lisp_Misc_Limit - }; - /* These are the types of forwarding objects used in the value slot of symbols for special built-in variables whose value is stored in C variables. */ @@ -487,16 +543,15 @@ enum Lisp_Fwd_Type }; /* If you want to define a new Lisp data type, here are some - instructions. See the thread at - https://lists.gnu.org/r/emacs-devel/2012-10/msg00561.html - for more info. + instructions. First, there are already a couple of Lisp types that can be used if your new type does not need to be exposed to Lisp programs nor - displayed to users. These are Lisp_Save_Value, a Lisp_Misc - subtype; and PVEC_OTHER, a kind of vectorlike object. The former - is suitable for temporarily stashing away pointers and integers in - a Lisp object. The latter is useful for vector-like Lisp objects + displayed to users. These are Lisp_Misc_Ptr and PVEC_OTHER, + which are both vectorlike objects. The former + is suitable for stashing a pointer in a Lisp object; the pointer + might be to some low-level C object that contains auxiliary + information. The latter is useful for vector-like Lisp objects that need to be used as part of other objects, but which are never shown to users or Lisp code (search for PVEC_OTHER in xterm.c for an example). @@ -504,30 +559,13 @@ enum Lisp_Fwd_Type These two types don't look pretty when printed, so they are unsuitable for Lisp objects that can be exposed to users. - To define a new data type, add one more Lisp_Misc subtype or one - more pseudovector subtype. Pseudovectors are more suitable for - objects with several slots that need to support fast random access, - while Lisp_Misc types are for everything else. A pseudovector object - provides one or more slots for Lisp objects, followed by struct - members that are accessible only from C. A Lisp_Misc object is a - wrapper for a C struct that can contain anything you like. - - Explicit freeing is discouraged for Lisp objects in general. But if - you really need to exploit this, use Lisp_Misc (check free_misc in - alloc.c to see why). There is no way to free a vectorlike object. - - To add a new pseudovector type, extend the pvec_type enumeration; - to add a new Lisp_Misc, extend the Lisp_Misc_Type enumeration. - - For a Lisp_Misc, you will also need to add your entry to union - Lisp_Misc, but make sure the first word has the same structure as - the others, starting with a 16-bit member of the Lisp_Misc_Type - enumeration and a 1-bit GC markbit. Also make sure the overall - size of the union is not increased by your addition. The latter - requirement is to keep Lisp_Misc objects small enough, so they - are handled faster: since all Lisp_Misc types use the same space, - enlarging any of them will affect all the rest. If you really - need a larger object, it is best to use Lisp_Vectorlike instead. + To define a new data type, add a pseudovector subtype by extending + the pvec_type enumeration. A pseudovector provides one or more + slots for Lisp objects, followed by struct members that are + accessible only from C. + + There is no way to explicitly free a Lisp Object; only the garbage + collector frees them. For a new pseudovector, it's highly desirable to limit the size of your data type by VBLOCK_BYTES_MAX bytes (defined in alloc.c). @@ -542,24 +580,29 @@ enum Lisp_Fwd_Type resources allocated for it that are not Lisp objects. You can even make a pointer to the function that frees the resources a slot in your object -- this way, the same object could be used to represent - several disparate C structures. */ + several disparate C structures. -#ifdef CHECK_LISP_OBJECT_TYPE + You also need to add the new type to the constant + `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */ -typedef struct Lisp_Object { EMACS_INT i; } Lisp_Object; -#define LISP_INITIALLY(i) {i} +/* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a + Lisp_Word. However, if CHECK_LISP_OBJECT_TYPE, it is a wrapper + around Lisp_Word, to help catch thinkos like 'Lisp_Object x = 0;'. -#undef CHECK_LISP_OBJECT_TYPE -enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; -#else /* CHECK_LISP_OBJECT_TYPE */ + LISP_INITIALLY (W) initializes a Lisp object with a tagged value + that is a Lisp_Word W. It can be used in a static initializer. */ -/* If a struct type is not wanted, define Lisp_Object as just a number. */ - -typedef EMACS_INT Lisp_Object; -#define LISP_INITIALLY(i) (i) +#ifdef CHECK_LISP_OBJECT_TYPE +typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object; +# define LISP_INITIALLY(w) {w} +# undef CHECK_LISP_OBJECT_TYPE +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; +#else +typedef Lisp_Word Lisp_Object; +# define LISP_INITIALLY(w) (w) enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; -#endif /* CHECK_LISP_OBJECT_TYPE */ +#endif /* Forward declarations. */ @@ -567,6 +610,11 @@ enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, Lisp_Object); +/* Defined in bignum.c. */ +extern double bignum_to_double (Lisp_Object); +extern Lisp_Object make_bigint (intmax_t); +extern Lisp_Object make_biguint (uintmax_t); + /* Defined in chartab.c. */ extern Lisp_Object char_table_ref (Lisp_Object, int); extern void char_table_set (Lisp_Object, int, Lisp_Object); @@ -591,8 +639,10 @@ 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. */ +/* Convert among various types use to implement Lisp_Object. At the + machine level, these operations may widen or narrow their arguments + if pointers differ in width from EMACS_INT; otherwise they are + no-ops. */ INLINE EMACS_INT (XLI) (Lisp_Object o) @@ -606,6 +656,18 @@ INLINE Lisp_Object return lisp_h_XIL (i); } +INLINE void * +(XLP) (Lisp_Object o) +{ + return lisp_h_XLP (o); +} + +INLINE Lisp_Object +(XPL) (void *p) +{ + return lisp_h_XPL (p); +} + /* Extract A's type. */ INLINE enum Lisp_Type @@ -619,25 +681,26 @@ INLINE enum Lisp_Type #endif } +/* True if A has type tag TAG. + Equivalent to XTYPE (a) == TAG, but often faster. */ + +INLINE bool +(TAGGEDP) (Lisp_Object a, enum Lisp_Type tag) +{ + return lisp_h_TAGGEDP (a, tag); +} + 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 -} +/* Extract A's pointer value, assuming A's Lisp type is TYPE and the + extracted pointer's type is CTYPE *. */ +#define XUNTAG(a, type, ctype) ((ctype *) \ + ((char *) XLP (a) - LISP_WORD_TAG (type))) /* Interned state of a symbol. */ @@ -715,10 +778,10 @@ struct Lisp_Symbol /* Next symbol in obarray bucket, if the symbol is interned. */ struct Lisp_Symbol *next; } s; - char alignas (GCALIGNMENT) gcaligned; + GCALIGNED_UNION_MEMBER } u; }; -verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0); +verify (GCALIGNED (struct Lisp_Symbol)); /* Declare a Lisp-callable function. The MAXARGS parameter has the same meaning as in the DEFUN macro, and is used to construct a prototype. */ @@ -745,35 +808,47 @@ verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0); #define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) -/* Yield a signed integer that contains TAG along with PTR. - - Sign-extend pointers when USE_LSB_TAG (this simplifies emacs-module.c), - and zero-extend otherwise (that’s a bit faster here). - Sign extension matters only when EMACS_INT is wider than a pointer. */ -#define TAG_PTR(tag, ptr) \ - (USE_LSB_TAG \ - ? (intptr_t) (ptr) + (tag) \ - : (EMACS_INT) (((EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr))) +/* untagged_ptr represents a pointer before tagging, and Lisp_Word_tag + contains a possibly-shifted tag to be added to an untagged_ptr to + convert it to a Lisp_Word. */ +#if LISP_WORDS_ARE_POINTERS +/* untagged_ptr is a pointer so that the compiler knows that TAG_PTR + yields a pointer; this can help with gcc -fcheck-pointer-bounds. + It is char * so that adding a tag uses simple machine addition. */ +typedef char *untagged_ptr; +typedef uintptr_t Lisp_Word_tag; +#else +/* untagged_ptr is an unsigned integer instead of a pointer, so that + it can be added to the possibly-wider Lisp_Word_tag type without + losing information. */ +typedef uintptr_t untagged_ptr; +typedef EMACS_UINT Lisp_Word_tag; +#endif -/* Yield an integer that contains a symbol tag along with OFFSET. - OFFSET should be the offset in bytes from 'lispsym' to the symbol. */ -#define TAG_SYMOFFSET(offset) TAG_PTR (Lisp_Symbol, offset) +/* A integer value tagged with TAG, and otherwise all zero. */ +#define LISP_WORD_TAG(tag) \ + ((Lisp_Word_tag) (tag) << (USE_LSB_TAG ? 0 : VALBITS)) -/* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to - XLI (builtin_lisp_symbol (Qwhatever)), - except the former expands to an integer constant expression. */ -#define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym) +/* An initializer for a Lisp_Object that contains TAG along with PTR. */ +#define TAG_PTR(tag, ptr) \ + LISP_INITIALLY ((Lisp_Word) ((untagged_ptr) (ptr) + LISP_WORD_TAG (tag))) /* 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)) +#define LISPSYM_INITIALLY(name) \ + TAG_PTR (Lisp_Symbol, (char *) (intptr_t) ((i##name) * sizeof *lispsym)) /* 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 (LISPSYM_INITIALLY (name)) + format does not represent C macros. However, they are unbounded + and would just be asking for trouble if checking pointer bounds. */ +#ifdef __CHKP__ +# define DEFINE_LISP_SYMBOL(name) +#else +# define DEFINE_LISP_SYMBOL(name) \ + DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ + DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) +#endif /* The index of the C-defined Lisp symbol SYM. This can be used in a static initializer. */ @@ -795,7 +870,9 @@ verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0); and PSEUDOVECTORP cast their pointers to union 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. */ + Bug#8546. This union formerly contained more members, and there's + no compelling reason to change it to a struct merely because the + number of members has been reduced to one. */ union vectorlike_header { /* The main member contains various pieces of information: @@ -818,9 +895,7 @@ union vectorlike_header 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; - char alignas (GCALIGNMENT) gcaligned; }; -verify (alignof (union vectorlike_header) % GCALIGNMENT == 0); INLINE bool (SYMBOLP) (Lisp_Object x) @@ -828,15 +903,20 @@ INLINE bool return lisp_h_SYMBOLP (x); } -INLINE struct Lisp_Symbol * +INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED (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); + intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); void *p = (char *) lispsym + i; +# ifdef __CHKP__ + /* Bypass pointer checking. Although this could be improved it is + probably not worth the trouble. */ + p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol)); +# endif return p; #endif } @@ -844,7 +924,20 @@ INLINE struct Lisp_Symbol * INLINE Lisp_Object make_lisp_symbol (struct Lisp_Symbol *sym) { - Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym)); +#ifdef __CHKP__ + /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)' + should be more efficient, it runs afoul of GCC bug 83251 + <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=83251>. + Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym) + here seems to trigger a GCC bug, as yet undiagnosed. */ + char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym); + char *symoffset = addr - (intptr_t) lispsym; +#else + /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is + cast to char * rather than to intptr_t. */ + char *symoffset = (char *) ((char *) sym - (char *) lispsym); +#endif + Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); eassert (XSYMBOL (a) == sym); return a; } @@ -880,6 +973,14 @@ enum pvec_type { PVEC_NORMAL_VECTOR, PVEC_FREE, + PVEC_BIGNUM, + PVEC_MARKER, + PVEC_OVERLAY, + PVEC_FINALIZER, + PVEC_MISC_PTR, +#ifdef HAVE_MODULES + PVEC_USER_PTR, +#endif PVEC_PROCESS, PVEC_FRAME, PVEC_WINDOW, @@ -932,28 +1033,28 @@ enum More_Lisp_Bits that cons. */ /* Largest and smallest representable fixnum values. These are the C - values. They are macros for use in static initializers. */ + values. They are macros for use in #if and static initializers. */ #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) #define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) #if USE_LSB_TAG INLINE Lisp_Object -(make_number) (EMACS_INT n) +(make_fixnum) (EMACS_INT n) { - return lisp_h_make_number (n); + return lisp_h_make_fixnum (n); } INLINE EMACS_INT -(XINT) (Lisp_Object a) +(XFIXNUM) (Lisp_Object a) { - return lisp_h_XINT (a); + return lisp_h_XFIXNUM (a); } INLINE EMACS_INT -(XFASTINT) (Lisp_Object a) +(XFIXNAT) (Lisp_Object a) { - EMACS_INT n = lisp_h_XFASTINT (a); + EMACS_INT n = lisp_h_XFIXNAT (a); eassume (0 <= n); return n; } @@ -967,7 +1068,7 @@ INLINE EMACS_INT /* Make a Lisp integer representing the value of the low order bits of N. */ INLINE Lisp_Object -make_number (EMACS_INT n) +make_fixnum (EMACS_INT n) { EMACS_INT int0 = Lisp_Int0; if (USE_LSB_TAG) @@ -986,7 +1087,7 @@ make_number (EMACS_INT n) /* Extract A's value as a signed integer. */ INLINE EMACS_INT -XINT (Lisp_Object a) +XFIXNUM (Lisp_Object a) { EMACS_INT i = XLI (a); if (! USE_LSB_TAG) @@ -997,14 +1098,14 @@ XINT (Lisp_Object a) return i >> INTTYPEBITS; } -/* Like XINT (A), but may be faster. A must be nonnegative. +/* Like XFIXNUM (A), but may be faster. A must be nonnegative. If ! USE_LSB_TAG, this takes advantage of the fact that Lisp integers have zero-bits in their tags. */ INLINE EMACS_INT -XFASTINT (Lisp_Object a) +XFIXNAT (Lisp_Object a) { EMACS_INT int0 = Lisp_Int0; - EMACS_INT n = USE_LSB_TAG ? XINT (a) : XLI (a) - (int0 << VALBITS); + EMACS_INT n = USE_LSB_TAG ? XFIXNUM (a) : XLI (a) - (int0 << VALBITS); eassume (0 <= n); return n; } @@ -1013,14 +1114,14 @@ XFASTINT (Lisp_Object a) /* Extract A's value as an unsigned integer. */ INLINE EMACS_UINT -XUINT (Lisp_Object a) +XUFIXNUM (Lisp_Object a) { EMACS_UINT i = XLI (a); return USE_LSB_TAG ? i >> INTTYPEBITS : i & INTMASK; } -/* Return A's (Lisp-integer sized) hash. Happens to be like XUINT - right now, but XUINT should only be applied to objects we know are +/* Return A's (Lisp-integer sized) hash. Happens to be like XUFIXNUM + right now, but XUFIXNUM should only be applied to objects we know are integers. */ INLINE EMACS_INT @@ -1029,13 +1130,13 @@ INLINE EMACS_INT return lisp_h_XHASH (a); } -/* Like make_number (N), but may be faster. N must be in nonnegative range. */ +/* Like make_fixnum (N), but may be faster. N must be in nonnegative range. */ INLINE Lisp_Object -make_natnum (EMACS_INT n) +make_fixed_natnum (EMACS_INT n) { eassert (0 <= n && n <= MOST_POSITIVE_FIXNUM); EMACS_INT int0 = Lisp_Int0; - return USE_LSB_TAG ? make_number (n) : XIL (n + (int0 << VALBITS)); + return USE_LSB_TAG ? make_fixnum (n) : XIL (n + (int0 << VALBITS)); } /* Return true if X and Y are the same object. */ @@ -1062,25 +1163,24 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) INLINE Lisp_Object make_lisp_ptr (void *ptr, enum Lisp_Type type) { - Lisp_Object a = XIL (TAG_PTR (type, ptr)); - eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr); + Lisp_Object a = TAG_PTR (type, ptr); + eassert (TAGGEDP (a, type) && XUNTAG (a, type, char) == ptr); return a; } INLINE bool -(INTEGERP) (Lisp_Object x) +(FIXNUMP) (Lisp_Object x) { - return lisp_h_INTEGERP (x); + return lisp_h_FIXNUMP (x); } -#define XSETINT(a, b) ((a) = make_number (b)) -#define XSETFASTINT(a, b) ((a) = make_natnum (b)) +#define XSETINT(a, b) ((a) = make_fixnum (b)) +#define XSETFASTINT(a, b) ((a) = make_fixed_natnum (b)) #define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons)) #define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike)) #define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String)) #define XSETSYMBOL(a, b) ((a) = make_lisp_symbol (b)) #define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float)) -#define XSETMISC(a, b) ((a) = make_lisp_ptr (b, Lisp_Misc)) /* Pseudovector types. */ @@ -1095,8 +1195,8 @@ INLINE bool /* The cast to union vectorlike_header * avoids aliasing issues. */ #define XSETPSEUDOVECTOR(a, b, code) \ XSETTYPED_PSEUDOVECTOR (a, b, \ - (((union vectorlike_header *) \ - XUNTAG (a, Lisp_Vectorlike)) \ + (XUNTAG (a, Lisp_Vectorlike, \ + union vectorlike_header) \ ->size), \ code) #define XSETTYPED_PSEUDOVECTOR(a, b, size, code) \ @@ -1125,16 +1225,23 @@ INLINE bool bits set, which makes this conversion inherently unportable. */ INLINE void * -XINTPTR (Lisp_Object a) +XFIXNUMPTR (Lisp_Object a) +{ + return XUNTAG (a, Lisp_Int0, char); +} + +INLINE Lisp_Object +make_pointer_integer_unsafe (void *p) { - return XUNTAG (a, Lisp_Int0); + Lisp_Object a = TAG_PTR (Lisp_Int0, p); + return a; } INLINE Lisp_Object make_pointer_integer (void *p) { - Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p)); - eassert (INTEGERP (a) && XINTPTR (a) == p); + Lisp_Object a = make_pointer_integer_unsafe (p); + eassert (FIXNUMP (a) && XFIXNUMPTR (a) == p); return a; } @@ -1160,10 +1267,10 @@ struct Lisp_Cons struct Lisp_Cons *chain; } u; } s; - char alignas (GCALIGNMENT) gcaligned; + GCALIGNED_UNION_MEMBER } u; }; -verify (alignof (struct Lisp_Cons) % GCALIGNMENT == 0); +verify (GCALIGNED (struct Lisp_Cons)); INLINE bool (NILP) (Lisp_Object x) @@ -1282,15 +1389,15 @@ struct Lisp_String unsigned char *data; } s; struct Lisp_String *next; - char alignas (GCALIGNMENT) gcaligned; + GCALIGNED_UNION_MEMBER } u; }; -verify (alignof (struct Lisp_String) % GCALIGNMENT == 0); +verify (GCALIGNED (struct Lisp_String)); INLINE bool STRINGP (Lisp_Object x) { - return XTYPE (x) == Lisp_String; + return TAGGEDP (x, Lisp_String); } INLINE void @@ -1303,7 +1410,7 @@ INLINE struct Lisp_String * XSTRING (Lisp_Object a) { eassert (STRINGP (a)); - return XUNTAG (a, Lisp_String); + return XUNTAG (a, Lisp_String, struct Lisp_String); } /* True if STR is a multibyte string. */ @@ -1416,7 +1523,7 @@ struct Lisp_Vector { union vectorlike_header header; Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; - }; + } GCALIGNED_STRUCT; INLINE bool (VECTORLIKEP) (Lisp_Object x) @@ -1428,7 +1535,7 @@ INLINE struct Lisp_Vector * XVECTOR (Lisp_Object a) { eassert (VECTORLIKEP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Vector); } INLINE ptrdiff_t @@ -1488,8 +1595,9 @@ PSEUDOVECTORP (Lisp_Object a, int code) else { /* Converting to union vectorlike_header * avoids aliasing issues. */ - union vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike); - return PSEUDOVECTOR_TYPEP (h, code); + return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, + union vectorlike_header), + code); } } @@ -1507,10 +1615,19 @@ struct Lisp_Bool_Vector The bits are in little-endian order in the bytes, and the bytes are in little-endian order in the words. */ bits_word data[FLEXIBLE_ARRAY_MEMBER]; - }; + } GCALIGNED_STRUCT; /* Some handy constants for calculating sizes - and offsets, mostly of vectorlike objects. */ + and offsets, mostly of vectorlike objects. + + The garbage collector assumes that the initial part of any struct + that starts with a union vectorlike_header followed by N + Lisp_Objects (some possibly in arrays and/or a trailing flexible + array) will be laid out like a struct Lisp_Vector with N + Lisp_Objects. This assumption is true in practice on known Emacs + targets even though the C standard does not guarantee it. This + header contains a few sanity checks that should suffice to detect + violations of this assumption on plausible practical hosts. */ enum { @@ -1551,7 +1668,7 @@ INLINE struct Lisp_Bool_Vector * XBOOL_VECTOR (Lisp_Object a) { eassert (BOOL_VECTOR_P (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Bool_Vector); } INLINE EMACS_INT @@ -1645,8 +1762,10 @@ gc_aset (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) /* True, since Qnil's representation is zero. Every place in the code that assumes Qnil is zero should verify (NIL_IS_ZERO), to make it easy - to find such assumptions later if we change Qnil to be nonzero. */ -enum { NIL_IS_ZERO = XLI_BUILTIN_LISPSYM (iQnil) == 0 }; + to find such assumptions later if we change Qnil to be nonzero. + Test iQnil and Lisp_Symbol instead of Qnil directly, since the latter + is not suitable for use in an integer constant expression. */ +enum { NIL_IS_ZERO = iQnil == 0 && Lisp_Symbol == 0 }; /* Clear the object addressed by P, with size NBYTES, so that all its bytes are zero and all its Lisp values are nil. */ @@ -1670,7 +1789,8 @@ memclear (void *p, ptrdiff_t nbytes) ones that the GC needs to trace). */ #define PSEUDOVECSIZE(type, nonlispfield) \ - ((offsetof (type, nonlispfield) - header_size) / word_size) + (offsetof (type, nonlispfield) < header_size \ + ? 0 : (offsetof (type, nonlispfield) - header_size) / word_size) /* Compute A OP B, using the unsigned comparison operator OP. A and B should be integer expressions. This is not the same as @@ -1735,7 +1855,7 @@ struct Lisp_Char_Table /* These hold additional data. It is a vector. */ Lisp_Object extras[FLEXIBLE_ARRAY_MEMBER]; - }; + } GCALIGNED_STRUCT; INLINE bool CHAR_TABLE_P (Lisp_Object a) @@ -1747,7 +1867,7 @@ INLINE struct Lisp_Char_Table * XCHAR_TABLE (Lisp_Object a) { eassert (CHAR_TABLE_P (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Char_Table); } struct Lisp_Sub_Char_Table @@ -1769,7 +1889,7 @@ struct Lisp_Sub_Char_Table /* Use set_sub_char_table_contents to set this. */ Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER]; - }; + } GCALIGNED_STRUCT; INLINE bool SUB_CHAR_TABLE_P (Lisp_Object a) @@ -1781,7 +1901,7 @@ INLINE struct Lisp_Sub_Char_Table * XSUB_CHAR_TABLE (Lisp_Object a) { eassert (SUB_CHAR_TABLE_P (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Sub_Char_Table); } INLINE Lisp_Object @@ -1847,7 +1967,13 @@ struct Lisp_Subr const char *symbol_name; const char *intspec; EMACS_INT doc; + } GCALIGNED_STRUCT; +union Aligned_Lisp_Subr + { + struct Lisp_Subr s; + GCALIGNED_UNION_MEMBER }; +verify (GCALIGNED (union Aligned_Lisp_Subr)); INLINE bool SUBRP (Lisp_Object a) @@ -1859,7 +1985,7 @@ INLINE struct Lisp_Subr * XSUBR (Lisp_Object a) { eassert (SUBRP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Subr)->s; } enum char_table_specials @@ -1874,6 +2000,13 @@ enum char_table_specials SUB_CHAR_TABLE_OFFSET = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) }; +/* Sanity-check pseudovector layout. */ +verify (offsetof (struct Lisp_Char_Table, defalt) == header_size); +verify (offsetof (struct Lisp_Char_Table, extras) + == header_size + CHAR_TABLE_STANDARD_SLOTS * sizeof (Lisp_Object)); +verify (offsetof (struct Lisp_Sub_Char_Table, contents) + == header_size + SUB_CHAR_TABLE_OFFSET * sizeof (Lisp_Object)); + /* Return the number of "extra" slots in the char table CT. */ INLINE int @@ -1883,11 +2016,6 @@ CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct) - CHAR_TABLE_STANDARD_SLOTS); } -/* Make sure that sub char-table contents slot is where we think it is. */ -verify (offsetof (struct Lisp_Sub_Char_Table, contents) - == (offsetof (struct Lisp_Vector, contents) - + SUB_CHAR_TABLE_OFFSET * sizeof (Lisp_Object))); - /* Save and restore the instruction and environment pointers, without affecting the signal mask. */ @@ -2099,8 +2227,10 @@ struct Lisp_Hash_Table /* Next weak hash table if this is a weak hash table. The head of the list is in weak_hash_tables. */ struct Lisp_Hash_Table *next_weak; -}; +} GCALIGNED_STRUCT; +/* Sanity-check pseudovector layout. */ +verify (offsetof (struct Lisp_Hash_Table, weak) == header_size); INLINE bool HASH_TABLE_P (Lisp_Object a) @@ -2112,7 +2242,7 @@ INLINE struct Lisp_Hash_Table * XHASH_TABLE (Lisp_Object a) { eassert (HASH_TABLE_P (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table); } #define XSET_HASH_TABLE(VAR, PTR) \ @@ -2177,46 +2307,10 @@ SXHASH_REDUCE (EMACS_UINT x) return (x ^ x >> (EMACS_INT_WIDTH - FIXNUM_BITS)) & INTMASK; } -/* These structures are used for various misc types. */ - -struct Lisp_Misc_Any /* Supertype of all Misc types. */ -{ - ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_??? */ - bool_bf gcmarkbit : 1; - 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 */ - bool_bf gcmarkbit : 1; - unsigned spacer : 13; - /* This flag is temporarily used in the functions - decode/encode_coding_object to record that the marker position - must be adjusted after the conversion. */ - bool_bf need_adjustment : 1; - /* True means normal insertion at the marker's position - leaves the marker after the inserted text. */ - bool_bf insertion_type : 1; + union vectorlike_header header; + /* This is the buffer that the marker points into, or 0 if it points nowhere. Note: a chain of markers can contain markers pointing into different buffers (the chain is per buffer_text rather than per buffer, so it's @@ -2229,11 +2323,21 @@ struct Lisp_Marker */ struct buffer *buffer; + /* This flag is temporarily used in the functions + decode/encode_coding_object to record that the marker position + must be adjusted after the conversion. */ + bool_bf need_adjustment : 1; + /* True means normal insertion at the marker's position + leaves the marker after the inserted text. */ + bool_bf insertion_type : 1; + /* The remaining fields are meaningless in a marker that does not point anywhere. */ /* For markers that point somewhere, - this is used to chain of all the markers in a given buffer. */ + this is used to chain of all the markers in a given buffer. + The chain does not preserve markers from garbage collection; + instead, markers are removed from the chain when freed by GC. */ /* We could remove it and use an array in buffer_text instead. That would also allow us to preserve it ordered. */ struct Lisp_Marker *next; @@ -2244,7 +2348,7 @@ struct Lisp_Marker used to implement the functionality of markers, but rather to (ab)use markers as a cache for char<->byte mappings). */ ptrdiff_t bytepos; -}; +} GCALIGNED_STRUCT; /* START and END are markers in the overlay's buffer, and PLIST is the overlay's property list. */ @@ -2261,285 +2365,164 @@ struct Lisp_Overlay I.e. 9words plus 2 bits, 3words of which are for external linked lists. */ { - ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Overlay */ - bool_bf gcmarkbit : 1; - unsigned spacer : 15; - struct Lisp_Overlay *next; + union vectorlike_header header; Lisp_Object start; Lisp_Object end; Lisp_Object plist; - }; - -/* 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. */ -enum { SAVE_VALUE_SLOTS = 4 }; - -/* Bit-width and values for struct Lisp_Save_Value's save_type member. */ - -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)), - SAVE_TYPE_OBJ_OBJ = SAVE_OBJECT + (SAVE_OBJECT << SAVE_SLOT_BITS), - SAVE_TYPE_OBJ_OBJ_OBJ = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ << SAVE_SLOT_BITS), - SAVE_TYPE_OBJ_OBJ_OBJ_OBJ - = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ_OBJ << SAVE_SLOT_BITS), - SAVE_TYPE_PTR_INT = SAVE_POINTER + (SAVE_INTEGER << SAVE_SLOT_BITS), - SAVE_TYPE_PTR_OBJ = SAVE_POINTER + (SAVE_OBJECT << SAVE_SLOT_BITS), - SAVE_TYPE_PTR_PTR = SAVE_POINTER + (SAVE_POINTER << SAVE_SLOT_BITS), - SAVE_TYPE_FUNCPTR_PTR_OBJ - = SAVE_FUNCPOINTER + (SAVE_TYPE_PTR_OBJ << SAVE_SLOT_BITS), - - /* This has an extra bit indicating it's raw memory. */ - 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 - record_unwind_protect when two or more values need to be saved. - For example: - - ... - struct my_data *md = get_my_data (); - ptrdiff_t mi = get_my_integer (); - record_unwind_protect (my_unwind, make_save_ptr_int (md, mi)); - ... - - Lisp_Object my_unwind (Lisp_Object arg) - { - struct my_data *md = XSAVE_POINTER (arg, 0); - ptrdiff_t mi = XSAVE_INTEGER (arg, 1); - ... - } - - If ENABLE_CHECKING is in effect, XSAVE_xxx macros do type checking of the - saved objects and raise eassert if type of the saved object doesn't match - the type which is extracted. In the example above, XSAVE_INTEGER (arg, 2) - and XSAVE_OBJECT (arg, 0) are wrong because nothing was saved in slot 2 and - slot 0 is a pointer. */ - -typedef void (*voidfuncptr) (void); + struct Lisp_Overlay *next; + } GCALIGNED_STRUCT; -struct Lisp_Save_Value +struct Lisp_Misc_Ptr { - ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Save_Value */ - bool_bf gcmarkbit : 1; - unsigned spacer : 32 - (16 + 1 + SAVE_TYPE_BITS); - - /* V->data may hold up to SAVE_VALUE_SLOTS entries. The type of - V's data entries are determined by V->save_type. E.g., if - V->save_type == SAVE_TYPE_PTR_OBJ, V->data[0] is a pointer, - V->data[1] is an integer, and V's other data entries are unused. - - If V->save_type == SAVE_TYPE_MEMORY, V->data[0].pointer is the address of - a memory area containing V->data[1].integer potential Lisp_Objects. */ - ENUM_BF (Lisp_Save_Type) save_type : SAVE_TYPE_BITS; - union { - void *pointer; - voidfuncptr funcpointer; - ptrdiff_t integer; - Lisp_Object object; - } data[SAVE_VALUE_SLOTS]; - }; - -INLINE bool -SAVE_VALUEP (Lisp_Object x) -{ - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value; -} + union vectorlike_header header; + void *pointer; + } GCALIGNED_STRUCT; + +extern Lisp_Object make_misc_ptr (void *); + +/* A mint_ptr object OBJ represents a C-language pointer P efficiently. + Preferably (and typically), OBJ is a Lisp integer I such that + XFIXNUMPTR (I) == P, as this represents P within a single Lisp value + without requiring any auxiliary memory. However, if P would be + damaged by being tagged as an integer and then untagged via + XFIXNUMPTR, then OBJ is a Lisp_Misc_Ptr with pointer component P. + + mint_ptr objects are efficiency hacks intended for C code. + Although xmint_ptr can be given any mint_ptr generated by non-buggy + C code, it should not be given a mint_ptr generated from Lisp code + as that would allow Lisp code to coin pointers from integers and + could lead to crashes. To package a C pointer into a Lisp-visible + object you can put the pointer into a pseudovector instead; see + Lisp_User_Ptr for an example. */ -INLINE struct Lisp_Save_Value * -XSAVE_VALUE (Lisp_Object a) +INLINE Lisp_Object +make_mint_ptr (void *a) { - eassert (SAVE_VALUEP (a)); - return XUNTAG (a, Lisp_Misc); + Lisp_Object val = TAG_PTR (Lisp_Int0, a); + return FIXNUMP (val) && XFIXNUMPTR (val) == a ? val : make_misc_ptr (a); } -/* Return the type of V's Nth saved value. */ -INLINE int -save_type (struct Lisp_Save_Value *v, int n) +INLINE bool +mint_ptrp (Lisp_Object x) { - eassert (0 <= n && n < SAVE_VALUE_SLOTS); - return (v->save_type >> (SAVE_SLOT_BITS * n) & ((1 << SAVE_SLOT_BITS) - 1)); + return FIXNUMP (x) || PSEUDOVECTORP (x, PVEC_MISC_PTR); } -/* Get and set the Nth saved pointer. */ - INLINE void * -XSAVE_POINTER (Lisp_Object obj, int n) +xmint_pointer (Lisp_Object a) { - eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER); - return XSAVE_VALUE (obj)->data[n].pointer; -} -INLINE void -set_save_pointer (Lisp_Object obj, int n, void *val) -{ - eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER); - XSAVE_VALUE (obj)->data[n].pointer = val; -} -INLINE voidfuncptr -XSAVE_FUNCPOINTER (Lisp_Object obj, int n) -{ - eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_FUNCPOINTER); - return XSAVE_VALUE (obj)->data[n].funcpointer; -} - -/* Likewise for the saved integer. */ - -INLINE ptrdiff_t -XSAVE_INTEGER (Lisp_Object obj, int n) -{ - eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER); - return XSAVE_VALUE (obj)->data[n].integer; -} -INLINE void -set_save_integer (Lisp_Object obj, int n, ptrdiff_t val) -{ - eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER); - XSAVE_VALUE (obj)->data[n].integer = val; -} - -/* Extract Nth saved object. */ - -INLINE Lisp_Object -XSAVE_OBJECT (Lisp_Object obj, int n) -{ - eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_OBJECT); - return XSAVE_VALUE (obj)->data[n].object; + eassert (mint_ptrp (a)); + if (FIXNUMP (a)) + return XFIXNUMPTR (a); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Misc_Ptr)->pointer; } #ifdef HAVE_MODULES struct Lisp_User_Ptr { - ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_User_Ptr */ - bool_bf gcmarkbit : 1; - unsigned spacer : 15; - + union vectorlike_header header; void (*finalizer) (void *); void *p; -}; +} GCALIGNED_STRUCT; #endif /* A finalizer sentinel. */ struct Lisp_Finalizer { - struct Lisp_Misc_Any base; - - /* Circular list of all active weak references. */ - struct Lisp_Finalizer *prev; - struct Lisp_Finalizer *next; + union vectorlike_header header; /* Call FUNCTION when the finalizer becomes unreachable, even if FUNCTION contains a reference to the finalizer; i.e., call FUNCTION when it is reachable _only_ through finalizers. */ Lisp_Object function; - }; + + /* Circular list of all active weak references. */ + struct Lisp_Finalizer *prev; + struct Lisp_Finalizer *next; + } GCALIGNED_STRUCT; INLINE bool FINALIZERP (Lisp_Object x) { - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer; + return PSEUDOVECTORP (x, PVEC_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 - { - ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Free */ - bool_bf gcmarkbit : 1; - unsigned spacer : 15; - union Lisp_Misc *chain; - }; - -/* To get the type field of a union Lisp_Misc, use XMISCTYPE. - It uses one of these struct subtypes to get the type field. */ - -union Lisp_Misc - { - struct Lisp_Misc_Any u_any; /* Supertype of all Misc types. */ - struct Lisp_Free u_free; - struct Lisp_Marker u_marker; - struct Lisp_Overlay u_overlay; - struct Lisp_Save_Value u_save_value; - struct Lisp_Finalizer u_finalizer; -#ifdef HAVE_MODULES - struct Lisp_User_Ptr u_user_ptr; -#endif - }; - -INLINE union Lisp_Misc * -XMISC (Lisp_Object a) -{ - return XUNTAG (a, Lisp_Misc); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Finalizer); } INLINE bool -(MARKERP) (Lisp_Object x) +MARKERP (Lisp_Object x) { - return lisp_h_MARKERP (x); + return PSEUDOVECTORP (x, PVEC_MARKER); } INLINE struct Lisp_Marker * XMARKER (Lisp_Object a) { eassert (MARKERP (a)); - return XUNTAG (a, Lisp_Misc); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Marker); } INLINE bool OVERLAYP (Lisp_Object x) { - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay; + return PSEUDOVECTORP (x, PVEC_OVERLAY); } INLINE struct Lisp_Overlay * XOVERLAY (Lisp_Object a) { eassert (OVERLAYP (a)); - return XUNTAG (a, Lisp_Misc); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay); } #ifdef HAVE_MODULES INLINE bool USER_PTRP (Lisp_Object x) { - return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_User_Ptr; + return PSEUDOVECTORP (x, PVEC_USER_PTR); } INLINE struct Lisp_User_Ptr * XUSER_PTR (Lisp_Object a) { eassert (USER_PTRP (a)); - return XUNTAG (a, Lisp_Misc); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_User_Ptr); } #endif +INLINE bool +BIGNUMP (Lisp_Object x) +{ + return PSEUDOVECTORP (x, PVEC_BIGNUM); +} + +INLINE bool +INTEGERP (Lisp_Object x) +{ + return FIXNUMP (x) || BIGNUMP (x); +} + +/* Return a Lisp integer with value taken from N. */ +INLINE Lisp_Object +make_int (intmax_t n) +{ + return FIXNUM_OVERFLOW_P (n) ? make_bigint (n) : make_fixnum (n); +} +INLINE Lisp_Object +make_uint (uintmax_t n) +{ + return FIXNUM_OVERFLOW_P (n) ? make_biguint (n) : make_fixnum (n); +} + +/* Return a Lisp integer equal to the value of the C integer EXPR. */ +#define INT_TO_INTEGER(expr) \ + (EXPR_SIGNED (expr) ? make_int (expr) : make_uint (expr)) + /* Forwarding pointer to an int variable. This is allowed only in the value cell of a symbol, @@ -2577,7 +2560,7 @@ struct Lisp_Buffer_Objfwd { enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Buffer_Obj */ int offset; - /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */ + /* One of Qnil, Qfixnump, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */ Lisp_Object predicate; }; @@ -2668,7 +2651,7 @@ struct Lisp_Float double data; struct Lisp_Float *chain; } u; - }; + } GCALIGNED_STRUCT; INLINE bool (FLOATP) (Lisp_Object x) @@ -2680,7 +2663,7 @@ INLINE struct Lisp_Float * XFLOAT (Lisp_Object a) { eassert (FLOATP (a)); - return XUNTAG (a, Lisp_Float); + return XUNTAG (a, Lisp_Float, struct Lisp_Float); } INLINE double @@ -2691,24 +2674,14 @@ XFLOAT_DATA (Lisp_Object f) /* Most hosts nowadays use IEEE floating point, so they use IEC 60559 representations, have infinities and NaNs, and do not trap on - exceptions. Define IEEE_FLOATING_POINT if this host is one of the + exceptions. Define IEEE_FLOATING_POINT to 1 if this host is one of the typical ones. The C11 macro __STDC_IEC_559__ is close to what is wanted here, but is not quite right because Emacs does not require all the features of C11 Annex F (and does not require C11 at all, for that matter). */ -enum - { - IEEE_FLOATING_POINT - = (FLT_RADIX == 2 && FLT_MANT_DIG == 24 - && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) - }; -/* A character, declared with the following typedef, is a member - of some character set associated with the current buffer. */ -#ifndef _UCHAR_T /* Protect against something in ctab.h on AIX. */ -#define _UCHAR_T -typedef unsigned char UCHAR; -#endif +#define IEEE_FLOATING_POINT (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ + && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) /* Meanings of slots in a Lisp_Compiled: */ @@ -2746,26 +2719,26 @@ enum char_bits /* Data type checking. */ INLINE bool -NUMBERP (Lisp_Object x) +FIXNATP (Lisp_Object x) { - return INTEGERP (x) || FLOATP (x); + return FIXNUMP (x) && 0 <= XFIXNUM (x); } INLINE bool -NATNUMP (Lisp_Object x) +NUMBERP (Lisp_Object x) { - return INTEGERP (x) && 0 <= XINT (x); + return INTEGERP (x) || FLOATP (x); } INLINE bool -RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi) +RANGED_FIXNUMP (intmax_t lo, Lisp_Object x, intmax_t hi) { - return INTEGERP (x) && lo <= XINT (x) && XINT (x) <= hi; + return FIXNUMP (x) && lo <= XFIXNUM (x) && XFIXNUM (x) <= hi; } -#define TYPE_RANGED_INTEGERP(type, x) \ - (INTEGERP (x) \ - && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \ - && XINT (x) <= TYPE_MAXIMUM (type)) +#define TYPE_RANGED_FIXNUMP(type, x) \ + (FIXNUMP (x) \ + && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XFIXNUM (x) : 0 <= XFIXNUM (x)) \ + && XFIXNUM (x) <= TYPE_MAXIMUM (type)) INLINE bool AUTOLOADP (Lisp_Object x) @@ -2833,9 +2806,9 @@ CHECK_LIST_END (Lisp_Object x, Lisp_Object y) } INLINE void -(CHECK_NUMBER) (Lisp_Object x) +(CHECK_FIXNUM) (Lisp_Object x) { - lisp_h_CHECK_NUMBER (x); + lisp_h_CHECK_FIXNUM (x); } INLINE void @@ -2859,21 +2832,21 @@ CHECK_ARRAY (Lisp_Object x, Lisp_Object predicate) CHECK_TYPE (ARRAYP (x), predicate, x); } INLINE void -CHECK_NATNUM (Lisp_Object x) +CHECK_FIXNAT (Lisp_Object x) { - CHECK_TYPE (NATNUMP (x), Qwholenump, x); + CHECK_TYPE (FIXNATP (x), Qwholenump, x); } #define CHECK_RANGED_INTEGER(x, lo, hi) \ do { \ - CHECK_NUMBER (x); \ - if (! ((lo) <= XINT (x) && XINT (x) <= (hi))) \ + CHECK_FIXNUM (x); \ + if (! ((lo) <= XFIXNUM (x) && XFIXNUM (x) <= (hi))) \ args_out_of_range_3 \ (x, \ - make_number ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM \ + make_fixnum ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM \ ? MOST_NEGATIVE_FIXNUM \ : (lo)), \ - make_number (min (hi, MOST_POSITIVE_FIXNUM))); \ + make_fixnum (min (hi, MOST_POSITIVE_FIXNUM))); \ } while (false) #define CHECK_TYPE_RANGED_INTEGER(type, x) \ do { \ @@ -2883,27 +2856,35 @@ CHECK_NATNUM (Lisp_Object x) CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type)); \ } while (false) -#define CHECK_NUMBER_COERCE_MARKER(x) \ +#define CHECK_FIXNUM_COERCE_MARKER(x) \ do { \ if (MARKERP ((x))) \ XSETFASTINT (x, marker_position (x)); \ else \ - CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); \ + CHECK_TYPE (FIXNUMP (x), Qinteger_or_marker_p, x); \ } while (false) INLINE double XFLOATINT (Lisp_Object n) { - return FLOATP (n) ? XFLOAT_DATA (n) : XINT (n); + return (FIXNUMP (n) ? XFIXNUM (n) + : FLOATP (n) ? XFLOAT_DATA (n) + : bignum_to_double (n)); } INLINE void -CHECK_NUMBER_OR_FLOAT (Lisp_Object x) +CHECK_NUMBER (Lisp_Object x) { CHECK_TYPE (NUMBERP (x), Qnumberp, x); } -#define CHECK_NUMBER_OR_FLOAT_COERCE_MARKER(x) \ +INLINE void +CHECK_INTEGER (Lisp_Object x) +{ + CHECK_TYPE (INTEGERP (x), Qnumberp, x); +} + +#define CHECK_NUMBER_COERCE_MARKER(x) \ do { \ if (MARKERP (x)) \ XSETFASTINT (x, marker_position (x)); \ @@ -2911,23 +2892,13 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x) CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \ } while (false) -/* Since we can't assign directly to the CAR or CDR fields of a cons - cell, use these when checking that those fields contain numbers. */ -INLINE void -CHECK_NUMBER_CAR (Lisp_Object x) -{ - Lisp_Object tmp = XCAR (x); - CHECK_NUMBER (tmp); - XSETCAR (x, tmp); -} - -INLINE void -CHECK_NUMBER_CDR (Lisp_Object x) -{ - Lisp_Object tmp = XCDR (x); - CHECK_NUMBER (tmp); - XSETCDR (x, tmp); -} +#define CHECK_INTEGER_COERCE_MARKER(x) \ + do { \ + if (MARKERP (x)) \ + XSETFASTINT (x, marker_position (x)); \ + else \ + CHECK_TYPE (INTEGERP (x), Qnumber_or_marker_p, x); \ + } while (false) /* Define a built-in function for calling from Lisp. `lname' should be the name to give the function in Lisp, @@ -2956,27 +2927,16 @@ CHECK_NUMBER_CDR (Lisp_Object x) /* This version of DEFUN declares a function prototype with the right arguments, so we can catch errors with maxargs at compile-time. */ -#ifdef _MSC_VER #define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ - Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \ - static struct Lisp_Subr sname = \ - { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \ - | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \ - { (Lisp_Object (__cdecl *)(void))fnname }, \ - minargs, maxargs, lname, intspec, 0}; \ - Lisp_Object fnname -#else /* not _MSC_VER */ -#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ - static struct Lisp_Subr sname = \ - { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ + static union Aligned_Lisp_Subr sname = \ + {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, intspec, 0}; \ + minargs, maxargs, lname, intspec, 0}}; \ Lisp_Object fnname -#endif /* defsubr (Sname); is how we define the symbol for function `name' at start-up time. */ -extern void defsubr (struct Lisp_Subr *); +extern void defsubr (union Aligned_Lisp_Subr *); enum maxargs { @@ -3065,8 +3025,11 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int); enum specbind_tag { SPECPDL_UNWIND, /* An unwind_protect function on Lisp_Object. */ + SPECPDL_UNWIND_ARRAY, /* Likewise, on an array that needs freeing. + Its elements are potential Lisp_Objects. */ SPECPDL_UNWIND_PTR, /* Likewise, on void *. */ SPECPDL_UNWIND_INT, /* Likewise, on int. */ + SPECPDL_UNWIND_EXCURSION, /* Likewise, on an execursion. */ SPECPDL_UNWIND_VOID, /* Likewise, with no arg. */ SPECPDL_BACKTRACE, /* An element of the backtrace. */ SPECPDL_LET, /* A plain and simple dynamic let-binding. */ @@ -3077,14 +3040,22 @@ enum specbind_tag { union specbinding { + /* Aligning similar members consistently might help efficiency slightly + (Bug#31996#25). */ ENUM_BF (specbind_tag) kind : CHAR_BIT; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; void (*func) (Lisp_Object); Lisp_Object arg; + EMACS_INT eval_depth; } unwind; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; + ptrdiff_t nelts; + Lisp_Object *array; + } unwind_array; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; void (*func) (void *); void *arg; } unwind_ptr; @@ -3095,6 +3066,10 @@ union specbinding } unwind_int; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; + Lisp_Object marker, window; + } unwind_excursion; + struct { + ENUM_BF (specbind_tag) kind : CHAR_BIT; void (*func) (void); } unwind_void; struct { @@ -3323,6 +3298,50 @@ set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) XSUB_CHAR_TABLE (table)->contents[idx] = val; } +/* Defined in bignum.c. This part of bignum.c's API does not require + the caller to access bignum internals; see bignum.h for that. */ +extern intmax_t bignum_to_intmax (Lisp_Object); +extern uintmax_t bignum_to_uintmax (Lisp_Object); +extern ptrdiff_t bignum_bufsize (Lisp_Object, int); +extern ptrdiff_t bignum_to_c_string (char *, ptrdiff_t, Lisp_Object, int); +extern Lisp_Object bignum_to_string (Lisp_Object, int); +extern Lisp_Object make_bignum_str (char const *, int); +extern Lisp_Object make_neg_biguint (uintmax_t); +extern Lisp_Object double_to_integer (double); + +/* Converthe integer NUM to *N. Return true if successful, false + (possibly setting *N) otherwise. */ +INLINE bool +integer_to_intmax (Lisp_Object num, intmax_t *n) +{ + if (FIXNUMP (num)) + { + *n = XFIXNUM (num); + return true; + } + else + { + intmax_t i = bignum_to_intmax (num); + *n = i; + return i != 0; + } +} +INLINE bool +integer_to_uintmax (Lisp_Object num, uintmax_t *n) +{ + if (FIXNUMP (num)) + { + *n = XFIXNUM (num); + return 0 <= XFIXNUM (num); + } + else + { + uintmax_t i = bignum_to_uintmax (num); + *n = i; + return i != 0; + } +} + /* Defined in data.c. */ extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object); extern void notify_variable_watchers (Lisp_Object, Lisp_Object, @@ -3340,16 +3359,6 @@ enum Arith_Comparison { extern Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison); -/* Convert the integer I to an Emacs representation, either the integer - itself, or a cons of two or three integers, or if all else fails a float. - I should not have side effects. */ -#define INTEGER_TO_CONS(i) \ - (! FIXNUM_OVERFLOW_P (i) \ - ? make_number (i) \ - : EXPR_SIGNED (i) ? intbig_to_lisp (i) : uintbig_to_lisp (i)) -extern Lisp_Object intbig_to_lisp (intmax_t); -extern Lisp_Object uintbig_to_lisp (uintmax_t); - /* Convert the Emacs representation CONS back to an integer of type TYPE, storing the result the variable VAR. Signal an error if CONS is not a valid representation or is out of range for TYPE. */ @@ -3376,7 +3385,7 @@ 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 Lisp_Object expt_integer (Lisp_Object, Lisp_Object); extern void syms_of_data (void); extern void swap_in_global_binding (struct Lisp_Symbol *); @@ -3442,8 +3451,11 @@ extern Lisp_Object string_make_unibyte (Lisp_Object); extern void syms_of_fns (void); /* Defined in floatfns.c. */ -extern void syms_of_floatfns (void); +#ifndef HAVE_TRUNC +extern double trunc (double); +#endif extern Lisp_Object fmod_float (Lisp_Object x, Lisp_Object y); +extern void syms_of_floatfns (void); /* Defined in fringe.c. */ extern void syms_of_fringe (void); @@ -3458,6 +3470,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t); extern void reset_image_types (void); extern void syms_of_image (void); +#ifdef HAVE_JSON +/* Defined in json.c. */ +extern void init_json (void); +extern void syms_of_json (void); +#endif + /* Defined in insdel.c. */ extern void move_gap_both (ptrdiff_t, ptrdiff_t); extern _Noreturn void buffer_overflow (void); @@ -3507,8 +3525,7 @@ extern void replace_range_2 (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, extern void syms_of_insdel (void); /* Defined in dispnew.c. */ -#if (defined PROFILING \ - && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__)) +#ifdef PROFILING _Noreturn void __executable_start (void); #endif extern Lisp_Object Vwindow_system; @@ -3559,7 +3576,6 @@ extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t, /* Defined in alloc.c. */ extern void *my_heap_start (void); extern void check_pure_size (void); -extern void free_misc (Lisp_Object); extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT); extern void malloc_warning (const char *); extern _Noreturn void memory_full (size_t); @@ -3571,6 +3587,7 @@ extern void refill_memory_reserve (void); #endif extern void alloc_unexec_pre (void); extern void alloc_unexec_post (void); +extern void mark_maybe_objects (Lisp_Object *, ptrdiff_t); extern void mark_stack (char *, char *); extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern const char *pending_malloc_warning; @@ -3592,20 +3609,20 @@ extern Lisp_Object listn (enum constype, ptrdiff_t, Lisp_Object, ...); INLINE Lisp_Object list2i (EMACS_INT x, EMACS_INT y) { - return list2 (make_number (x), make_number (y)); + return list2 (make_fixnum (x), make_fixnum (y)); } INLINE Lisp_Object list3i (EMACS_INT x, EMACS_INT y, EMACS_INT w) { - return list3 (make_number (x), make_number (y), make_number (w)); + return list3 (make_fixnum (x), make_fixnum (y), make_fixnum (w)); } INLINE Lisp_Object list4i (EMACS_INT x, EMACS_INT y, EMACS_INT w, EMACS_INT h) { - return list4 (make_number (x), make_number (y), - make_number (w), make_number (h)); + return list4 (make_fixnum (x), make_fixnum (y), + make_fixnum (w), make_fixnum (h)); } extern Lisp_Object make_uninit_bool_vector (EMACS_INT); @@ -3652,8 +3669,9 @@ build_string (const char *str) } extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); +extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object); extern void make_byte_code (struct Lisp_Vector *); -extern struct Lisp_Vector *allocate_vector (EMACS_INT); +extern struct Lisp_Vector *allocate_vector (ptrdiff_t); /* Make an uninitialized vector for SIZE objects. NOTE: you must be sure that GC cannot happen until the vector is completely @@ -3667,12 +3685,7 @@ extern struct Lisp_Vector *allocate_vector (EMACS_INT); INLINE Lisp_Object make_uninit_vector (ptrdiff_t size) { - Lisp_Object v; - struct Lisp_Vector *p; - - p = allocate_vector (size); - XSETVECTOR (v, p); - return v; + return make_lisp_ptr (allocate_vector (size), Lisp_Vectorlike); } /* Like above, but special for sub char-tables. */ @@ -3689,6 +3702,16 @@ make_uninit_sub_char_table (int depth, int min_char) return v; } +/* Make a vector of SIZE nils. */ + +INLINE Lisp_Object +make_nil_vector (ptrdiff_t size) +{ + Lisp_Object vec = make_uninit_vector (size); + memclear (XVECTOR (vec)->contents, size * word_size); + return vec; +} + extern struct Lisp_Vector *allocate_pseudovector (int, int, int, enum pvec_type); @@ -3712,16 +3735,6 @@ extern bool gc_in_progress; extern Lisp_Object make_float (double); extern void display_malloc_warning (void); extern ptrdiff_t inhibit_garbage_collection (void); -extern Lisp_Object make_save_int_int_int (ptrdiff_t, ptrdiff_t, ptrdiff_t); -extern Lisp_Object make_save_obj_obj_obj_obj (Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object); -extern Lisp_Object make_save_ptr (void *); -extern Lisp_Object make_save_ptr_int (void *, ptrdiff_t); -extern Lisp_Object make_save_ptr_ptr (void *, void *); -extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *, - Lisp_Object); -extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t); -extern void free_save_value (Lisp_Object); extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); extern void free_cons (struct Lisp_Cons *); extern void init_alloc_once (void); @@ -3809,7 +3822,8 @@ LOADHIST_ATTACH (Lisp_Object x) } extern int openp (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object *, Lisp_Object, bool); -extern Lisp_Object string_to_number (char const *, int, bool); +enum { S2N_IGNORE_TRAILING = 1 }; +extern Lisp_Object string_to_number (char const *, int, ptrdiff_t *); extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object), Lisp_Object); extern void dir_warning (const char *, Lisp_Object); @@ -3859,6 +3873,7 @@ 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 _Noreturn void overflow_error (void); 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); @@ -3880,13 +3895,16 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); +extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object)); extern struct handler *push_handler (Lisp_Object, enum handlertype); extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); extern void specbind (Lisp_Object, Lisp_Object); extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object); +extern void record_unwind_protect_array (Lisp_Object *, ptrdiff_t); extern void record_unwind_protect_ptr (void (*) (void *), void *); extern void record_unwind_protect_int (void (*) (int), int); extern void record_unwind_protect_void (void (*) (void)); +extern void record_unwind_protect_excursion (void); extern void record_unwind_protect_nothing (void); extern void clear_unwind_protect (ptrdiff_t); extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); @@ -3946,7 +3964,7 @@ struct Lisp_Module_Function ptrdiff_t min_arity, max_arity; emacs_subr subr; void *data; -}; +} GCALIGNED_STRUCT; INLINE bool MODULE_FUNCTIONP (Lisp_Object o) @@ -3958,7 +3976,7 @@ INLINE struct Lisp_Module_Function * XMODULE_FUNCTION (Lisp_Object o) { eassert (MODULE_FUNCTIONP (o)); - return XUNTAG (o, Lisp_Vectorlike); + return XUNTAG (o, Lisp_Vectorlike, struct Lisp_Module_Function); } #ifdef HAVE_MODULES @@ -3975,18 +3993,18 @@ extern void syms_of_module (void); /* Defined in thread.c. */ extern void mark_threads (void); +extern void unmark_main_thread (void); /* Defined in editfns.c. */ extern void insert1 (Lisp_Object); -extern Lisp_Object save_excursion_save (void); +extern void save_excursion_save (union specbinding *); +extern void save_excursion_restore (Lisp_Object, Lisp_Object); extern Lisp_Object save_restriction_save (void); -extern void save_excursion_restore (Lisp_Object); extern void save_restriction_restore (Lisp_Object); -extern _Noreturn void time_overflow (void); extern Lisp_Object make_buffer_string (ptrdiff_t, ptrdiff_t, bool); extern Lisp_Object make_buffer_string_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool); -extern void init_editfns (bool); +extern void init_editfns (void); extern void syms_of_editfns (void); /* Defined in buffer.c. */ @@ -4024,6 +4042,8 @@ extern void syms_of_marker (void); /* Defined in fileio.c. */ +extern char *splice_dir_file (char *, char const *, char const *); +extern char const *get_homedir (void); extern Lisp_Object expand_and_dir_to_file (Lisp_Object); extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, @@ -4037,7 +4057,7 @@ extern _Noreturn void report_file_error (const char *, Lisp_Object); extern _Noreturn void report_file_notify_error (const char *, Lisp_Object); extern bool internal_delete_file (Lisp_Object); extern Lisp_Object emacs_readlinkat (int, const char *); -extern bool file_directory_p (const char *); +extern bool file_directory_p (Lisp_Object); extern bool file_accessible_directory_p (Lisp_Object); extern void init_fileio (void); extern void syms_of_fileio (void); @@ -4048,10 +4068,6 @@ extern void restore_search_regs (void); extern void update_search_regs (ptrdiff_t oldstart, ptrdiff_t oldend, ptrdiff_t newend); extern void record_unwind_save_match_data (void); -struct re_registers; -extern struct re_pattern_buffer *compile_pattern (Lisp_Object, - struct re_registers *, - Lisp_Object, bool, bool); extern ptrdiff_t fast_string_match_internal (Lisp_Object, Lisp_Object, Lisp_Object); @@ -4152,6 +4168,7 @@ extern void syms_of_frame (void); /* Defined in emacs.c. */ extern char **initial_argv; extern int initial_argc; +extern char const *emacs_wd; #if defined (HAVE_X_WINDOWS) || defined (HAVE_NS) extern bool display_arg; #endif @@ -4292,9 +4309,13 @@ struct tty_display_info; /* Defined in sysdep.c. */ #ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE -extern bool disable_address_randomization (void); +extern int maybe_disable_address_randomization (bool, int, char **); #else -INLINE bool disable_address_randomization (void) { return false; } +INLINE int +maybe_disable_address_randomization (bool dumping, int argc, char **argv) +{ + return argc; +} #endif extern int emacs_exec_file (char const *, char *const *, char *const *); extern void init_standard_fds (void); @@ -4327,6 +4348,7 @@ extern ptrdiff_t emacs_write_quit (int, void const *, ptrdiff_t); extern void emacs_perror (char const *); extern int renameat_noreplace (int, char const *, int, char const *); extern int str_collate (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern void syms_of_sysdep (void); /* Defined in filelock.c. */ extern void lock_file (Lisp_Object); @@ -4392,6 +4414,11 @@ extern void syms_of_gfilenotify (void); extern void syms_of_w32notify (void); #endif +#if defined HAVE_NTGUI || defined CYGWIN +/* Defined in w32cygwinx.c. */ +extern void syms_of_w32cygwinx (void); +#endif + /* Defined in xfaces.c. */ extern Lisp_Object Vface_alternative_font_family_alist; extern Lisp_Object Vface_alternative_font_registry_alist; @@ -4417,9 +4444,9 @@ extern void syms_of_xterm (void); extern char *x_get_keysym_name (int); #endif /* HAVE_WINDOW_SYSTEM */ -#ifdef HAVE_LIBXML2 /* Defined in xml.c. */ extern void syms_of_xml (void); +#ifdef HAVE_LIBXML2 extern void xml_cleanup_parser (void); #endif @@ -4500,12 +4527,6 @@ extern void init_system_name (void); because 'abs' is reserved by the C standard. */ #define eabs(x) ((x) < 0 ? -(x) : (x)) -/* Return a fixnum or float, depending on whether the integer VAL fits - in a Lisp fixnum. */ - -#define make_fixnum_or_float(val) \ - (FIXNUM_OVERFLOW_P (val) ? make_float (val) : make_number (val)) - /* SAFE_ALLOCA normally allocates memory on the stack, but if size is larger than MAX_ALLOCA, use xmalloc to avoid overflowing the stack. */ @@ -4515,7 +4536,7 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); #define USE_SAFE_ALLOCA \ ptrdiff_t sa_avail = MAX_ALLOCA; \ - ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false + ptrdiff_t sa_count = SPECPDL_INDEX () #define AVAIL_ALLOCA(size) (sa_avail -= (size), alloca (size)) @@ -4523,7 +4544,7 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); #define SAFE_ALLOCA(size) ((size) <= sa_avail \ ? AVAIL_ALLOCA (size) \ - : (sa_must_free = true, record_xmalloc (size))) + : record_xmalloc (size)) /* SAFE_NALLOCA sets BUF to a newly allocated array of MULTIPLIER * NITEMS items, each of the same type as *BUF. MULTIPLIER must @@ -4536,7 +4557,6 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); else \ { \ (buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \ - sa_must_free = true; \ record_unwind_protect_ptr (xfree, buf); \ } \ } while (false) @@ -4549,15 +4569,44 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); memcpy (ptr, SDATA (string), SBYTES (string) + 1); \ } while (false) -/* SAFE_FREE frees xmalloced memory and enables GC as needed. */ +/* Free xmalloced memory and enable GC as needed. */ -#define SAFE_FREE() \ - do { \ - if (sa_must_free) { \ - sa_must_free = false; \ - unbind_to (sa_count, Qnil); \ - } \ - } while (false) +#define SAFE_FREE() safe_free (sa_count) + +INLINE void +safe_free (ptrdiff_t sa_count) +{ + while (specpdl_ptr != specpdl + sa_count) + { + specpdl_ptr--; + if (specpdl_ptr->kind == SPECPDL_UNWIND_PTR) + { + eassert (specpdl_ptr->unwind_ptr.func == xfree); + xfree (specpdl_ptr->unwind_ptr.arg); + } + else + { + eassert (specpdl_ptr->kind == SPECPDL_UNWIND_ARRAY); + xfree (specpdl_ptr->unwind_array.array); + } + } +} + +/* Pop the specpdl stack back to COUNT, and return VAL. + Prefer this to { SAFE_FREE (); unbind_to (COUNT, VAL); } + when COUNT predates USE_SAFE_ALLOCA, as it is a bit more efficient + and also lets callers intermix SAFE_ALLOCA calls with other calls + that grow the specpdl stack. */ + +#define SAFE_FREE_UNBIND_TO(count, val) \ + safe_free_unbind_to (count, sa_count, val) + +INLINE Lisp_Object +safe_free_unbind_to (ptrdiff_t count, ptrdiff_t sa_count, Lisp_Object val) +{ + eassert (count <= sa_count); + return unbind_to (count, val); +} /* Set BUF to point to an allocated array of NELT Lisp_Objects, immediately followed by EXTRA spare bytes. */ @@ -4573,11 +4622,8 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); (buf) = AVAIL_ALLOCA (alloca_nbytes); \ else \ { \ - Lisp_Object arg_; \ (buf) = xmalloc (alloca_nbytes); \ - arg_ = make_save_memory (buf, nelt); \ - sa_must_free = true; \ - record_unwind_protect (free_save_value, arg_); \ + record_unwind_protect_array (buf, nelt); \ } \ } while (false) @@ -4586,13 +4632,14 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); #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 - managed by the garbage collector, so they are dangerous: passing them - out of their scope (e.g., to user code) results in undefined behavior. - Conversely, they have better performance because GC is not involved. +/* If USE_STACK_LISP_OBJECTS, define macros and functions that + allocate some Lisp objects on the C stack. As the storage is not + managed by the garbage collector, these objects are dangerous: + passing them to user code could result in undefined behavior if the + objects are in use after the C function returns. Conversely, these + objects have better performance because GC is not involved. - This feature is experimental and requires careful debugging. + While debugging you may want to disable allocation on the C stack. Build with CPPFLAGS='-DUSE_STACK_LISP_OBJECTS=0' to disable it. */ #if (!defined USE_STACK_LISP_OBJECTS \ @@ -4657,7 +4704,8 @@ enum 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. */ + should not be modified or given text properties or made visible to + user code. */ #define AUTO_STRING(name, str) \ AUTO_STRING_WITH_LEN (name, str, strlen (str)) @@ -4666,7 +4714,8 @@ enum 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. */ + should not be modified or given text properties or made visible to + user code. */ #define AUTO_STRING_WITH_LEN(name, str, len) \ Lisp_Object name = \ @@ -4676,6 +4725,11 @@ enum Lisp_String)) \ : make_unibyte_string (str, len)) +/* The maximum length of "small" lists, as a heuristic. These lists + are so short that code need not check for cycles or quits while + traversing. */ +enum { SMALL_LIST_LEN_MAX = 127 }; + /* Loop over conses of the list TAIL, signaling if a cycle is found, and possibly quitting after each loop iteration. In the loop body, set TAIL to the current cons. If the loop exits normally, @@ -4686,7 +4740,7 @@ enum #define FOR_EACH_TAIL(tail) \ FOR_EACH_TAIL_INTERNAL (tail, circular_list (tail), true) -/* Like FOR_EACH_TAIL (LIST), except do not signal or quit. +/* Like FOR_EACH_TAIL (TAIL), except do not signal or quit. If the loop exits due to a cycle, TAIL’s value is undefined. */ #define FOR_EACH_TAIL_SAFE(tail) \ diff --git a/src/lread.c b/src/lread.c index b0eb29a2a1f..788e57b707f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -72,6 +72,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #define file_tell ftell #endif +#if IEEE_FLOATING_POINT +# include <ieee754.h> +#endif + /* The objects or placeholders read with the #n=object form. A hash table maps a number to either a placeholder (while the @@ -147,10 +151,10 @@ static ptrdiff_t prev_saved_doc_string_length; /* This is the file position that string came from. */ static file_offset prev_saved_doc_string_position; -/* True means inside a new-style backquote - with no surrounding parentheses. - Fread initializes this to false, so we need not specbind it - or worry about what happens to it when there is an error. */ +/* True means inside a new-style backquote with no surrounding + parentheses. Fread initializes this to the value of + `force_new_style_backquotes', so we need not specbind it or worry + about what happens to it when there is an error. */ static bool new_backquote_flag; /* A list of file names for files being loaded in Fload. Used to @@ -164,6 +168,8 @@ static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), static void readevalloop (Lisp_Object, struct infile *, Lisp_Object, bool, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + +static void build_load_history (Lisp_Object, bool); /* Functions that read one byte from the current source READCHARFUN or unreads one byte. If the integer argument C is -1, it returns @@ -329,7 +335,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) if (NILP (tem)) return -1; - return XINT (tem); + return XFIXNUM (tem); read_multibyte: if (unread_char >= 0) @@ -461,7 +467,7 @@ unreadchar (Lisp_Object readcharfun, int c) unread_char = c; } else - call1 (readcharfun, make_number (c)); + call1 (readcharfun, make_fixnum (c)); } static int @@ -671,7 +677,7 @@ read_filtered_event (bool no_switch_frame, bool ascii_required, do val = read_char (0, Qnil, (input_method ? Qnil : Qt), 0, NUMBERP (seconds) ? &end_time : NULL); - while (INTEGERP (val) && XINT (val) == -2); /* wrong_kboard_jmpbuf */ + while (FIXNUMP (val) && XFIXNUM (val) == -2); /* wrong_kboard_jmpbuf */ if (BUFFERP (val)) goto retry; @@ -702,12 +708,12 @@ read_filtered_event (bool no_switch_frame, bool ascii_required, /* Merge this symbol's modifier bits with the ASCII equivalent of its basic code. */ if (!NILP (tem1)) - XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem)))); + XSETFASTINT (val, XFIXNUM (tem1) | XFIXNUM (Fcar (Fcdr (tem)))); } } /* If we don't have a character now, deal with it appropriately. */ - if (!INTEGERP (val)) + if (!FIXNUMP (val)) { if (error_nonascii) { @@ -768,7 +774,7 @@ floating-point value. */) val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds); return (NILP (val) ? Qnil - : make_number (char_resolve_modifier_mask (XINT (val)))); + : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val)))); } DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0, @@ -816,7 +822,7 @@ floating-point value. */) val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds); return (NILP (val) ? Qnil - : make_number (char_resolve_modifier_mask (XINT (val)))); + : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val)))); } DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, @@ -825,7 +831,7 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, { if (!infile) error ("get-file-char misused"); - return make_number (readbyte_from_stdio ()); + return make_fixnum (readbyte_from_stdio ()); } @@ -1013,13 +1019,15 @@ load_error_handler (Lisp_Object data) return Qnil; } -static void -load_warn_old_style_backquotes (Lisp_Object file) +static _Noreturn void +load_error_old_style_backquotes (void) { - if (!NILP (Vlread_old_style_backquotes)) + if (NILP (Vload_file_name)) + xsignal1 (Qerror, build_string ("Old-style backquotes detected!")); + else { AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); - CALLN (Fmessage, format, file); + xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name)); } } @@ -1129,7 +1137,7 @@ Return t if the file exists and loads successfully. */) (Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage, Lisp_Object nosuffix, Lisp_Object must_suffix) { - FILE *stream; + FILE *stream UNINIT; int fd; int fd_index UNINIT; ptrdiff_t count = SPECPDL_INDEX (); @@ -1254,8 +1262,9 @@ Return t if the file exists and loads successfully. */) } #ifdef HAVE_MODULES - if (suffix_p (found, MODULES_SUFFIX)) - return unbind_to (count, Fmodule_load (found)); + bool is_module = suffix_p (found, MODULES_SUFFIX); +#else + bool is_module = false; #endif /* Check if we're stuck in a recursive load cycle. @@ -1292,10 +1301,6 @@ Return t if the file exists and loads successfully. */) version = -1; - /* Check for the presence of old-style quotes and warn about them. */ - specbind (Qlread_old_style_backquotes, Qnil); - record_unwind_protect (load_warn_old_style_backquotes, file); - /* Check for the presence of unescaped character literals and warn about them. */ specbind (Qlread_unescaped_character_literals, Qnil); @@ -1352,7 +1357,7 @@ Return t if the file exists and loads successfully. */) if (!NILP (nomessage) && !force_load_messages) { Lisp_Object msg_file; - msg_file = Fsubstring (found, make_number (0), make_number (-1)); + msg_file = Fsubstring (found, make_fixnum (0), make_fixnum (-1)); message_with_string ("Source file `%s' newer than byte-compiled file", msg_file, 1); } @@ -1360,7 +1365,7 @@ Return t if the file exists and loads successfully. */) } /* !load_prefer_newer */ } } - else + else if (!is_module) { /* We are loading a source file (*.el). */ if (!NILP (Vload_source_file_function)) @@ -1387,7 +1392,7 @@ Return t if the file exists and loads successfully. */) stream = NULL; errno = EINVAL; } - else + else if (!is_module) { #ifdef WINDOWSNT emacs_close (fd); @@ -1398,9 +1403,23 @@ Return t if the file exists and loads successfully. */) stream = fdopen (fd, fmode); #endif } - if (! stream) - report_file_error ("Opening stdio stream", file); - set_unwind_protect_ptr (fd_index, close_infile_unwind, stream); + + if (is_module) + { + /* `module-load' uses the file name, so we can close the stream + now. */ + if (fd >= 0) + { + emacs_close (fd); + clear_unwind_protect (fd_index); + } + } + else + { + if (! stream) + report_file_error ("Opening stdio stream", file); + set_unwind_protect_ptr (fd_index, close_infile_unwind, stream); + } if (! NILP (Vpurify_flag)) Vpreloaded_file_list = Fcons (Fpurecopy (file), Vpreloaded_file_list); @@ -1410,6 +1429,8 @@ Return t if the file exists and loads successfully. */) if (!safe_p) message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...", file, 1); + else if (is_module) + message_with_string ("Loading %s (module)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); else if (newer) @@ -1423,24 +1444,39 @@ Return t if the file exists and loads successfully. */) specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); - struct infile input; - input.stream = stream; - input.lookahead = 0; - infile = &input; - - if (lisp_file_lexically_bound_p (Qget_file_char)) - Fset (Qlexical_binding, Qt); - - if (! version || version >= 22) - readevalloop (Qget_file_char, &input, hist_file_name, - 0, Qnil, Qnil, Qnil, Qnil); + if (is_module) + { +#ifdef HAVE_MODULES + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fmodule_load (found); + build_load_history (found, true); +#else + /* This cannot happen. */ + emacs_abort (); +#endif + } else { - /* We can't handle a file which was compiled with - byte-compile-dynamic by older version of Emacs. */ - specbind (Qload_force_doc_strings, Qt); - readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name, - 0, Qnil, Qnil, Qnil, Qnil); + struct infile input; + input.stream = stream; + input.lookahead = 0; + infile = &input; + + if (lisp_file_lexically_bound_p (Qget_file_char)) + Fset (Qlexical_binding, Qt); + + if (! version || version >= 22) + readevalloop (Qget_file_char, &input, hist_file_name, + 0, Qnil, Qnil, Qnil, Qnil); + else + { + /* We can't handle a file which was compiled with + byte-compile-dynamic by older version of Emacs. */ + specbind (Qload_force_doc_strings, Qt); + readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name, + 0, Qnil, Qnil, Qnil, Qnil); + } } unbind_to (count, Qnil); @@ -1461,6 +1497,8 @@ Return t if the file exists and loads successfully. */) if (!safe_p) message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done", file, 1); + else if (is_module) + message_with_string ("Loading %s (module)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); else if (newer) @@ -1563,188 +1601,193 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, absolute = complete_filename_p (str); - for (; CONSP (path); path = XCDR (path)) - { - ptrdiff_t baselen, prefixlen; + /* Go through all entries in the path and see whether we find the + executable. */ + do { + ptrdiff_t baselen, prefixlen; + if (NILP (path)) + filename = str; + else filename = Fexpand_file_name (str, XCAR (path)); - if (!complete_filename_p (filename)) - /* If there are non-absolute elts in PATH (eg "."). */ - /* Of course, this could conceivably lose if luser sets - default-directory to be something non-absolute... */ - { - filename = Fexpand_file_name (filename, BVAR (current_buffer, directory)); - if (!complete_filename_p (filename)) - /* Give up on this path element! */ - continue; - } + if (!complete_filename_p (filename)) + /* If there are non-absolute elts in PATH (eg "."). */ + /* Of course, this could conceivably lose if luser sets + default-directory to be something non-absolute... */ + { + filename = Fexpand_file_name (filename, BVAR (current_buffer, directory)); + if (!complete_filename_p (filename)) + /* Give up on this path element! */ + continue; + } - /* Calculate maximum length of any filename made from - this path element/specified file name and any possible suffix. */ - want_length = max_suffix_len + SBYTES (filename); - if (fn_size <= want_length) - { - fn_size = 100 + want_length; - fn = SAFE_ALLOCA (fn_size); - } + /* Calculate maximum length of any filename made from + this path element/specified file name and any possible suffix. */ + want_length = max_suffix_len + SBYTES (filename); + if (fn_size <= want_length) + { + fn_size = 100 + want_length; + 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)) - { - Lisp_Object suffix = XCAR (tail); - ptrdiff_t fnlen, lsuffix = SBYTES (suffix); - Lisp_Object handler; - - /* 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) - handler = Qnil; - else - handler = Ffind_file_name_handler (filename, Qfile_exists_p); - It's not clear why that was the case and it breaks things like - (load "/bar.el") where the file is actually "/bar.el.gz". */ - /* make_string has its own ideas on when to return a unibyte - string and when a multibyte string, but we know better. - We must have a unibyte string when dumping, since - file-name encoding is shaky at best at that time, and in - particular default-file-name-coding-system is reset - several times during loadup. We therefore don't want to - encode the file before passing it to file I/O library - functions. */ - if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix)) - string = make_unibyte_string (fn, fnlen); - else - string = make_string (fn, fnlen); - handler = Ffind_file_name_handler (string, Qfile_exists_p); - if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt))) - && !NATNUMP (predicate)) - { - bool exists; - if (NILP (predicate) || EQ (predicate, Qt)) - exists = !NILP (Ffile_readable_p (string)); - else - { - Lisp_Object tmp = call1 (predicate, string); - if (NILP (tmp)) + /* 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)) + { + Lisp_Object suffix = XCAR (tail); + ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + Lisp_Object handler; + + /* 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) + handler = Qnil; + else + handler = Ffind_file_name_handler (filename, Qfile_exists_p); + It's not clear why that was the case and it breaks things like + (load "/bar.el") where the file is actually "/bar.el.gz". */ + /* make_string has its own ideas on when to return a unibyte + string and when a multibyte string, but we know better. + We must have a unibyte string when dumping, since + file-name encoding is shaky at best at that time, and in + particular default-file-name-coding-system is reset + several times during loadup. We therefore don't want to + encode the file before passing it to file I/O library + functions. */ + if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix)) + string = make_unibyte_string (fn, fnlen); + else + string = make_string (fn, fnlen); + handler = Ffind_file_name_handler (string, Qfile_exists_p); + if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt))) + && !FIXNATP (predicate)) + { + bool exists; + if (NILP (predicate) || EQ (predicate, Qt)) + exists = !NILP (Ffile_readable_p (string)); + else + { + Lisp_Object tmp = call1 (predicate, string); + if (NILP (tmp)) + exists = false; + else if (EQ (tmp, Qdir_ok) + || NILP (Ffile_directory_p (string))) + exists = true; + else + { exists = false; - else if (EQ (tmp, Qdir_ok) - || NILP (Ffile_directory_p (string))) - exists = true; - else - { - exists = false; - last_errno = EISDIR; - } - } + last_errno = EISDIR; + } + } - if (exists) - { - /* We succeeded; return this descriptor and filename. */ - if (storeptr) - *storeptr = string; - SAFE_FREE (); - return -2; - } - } - else - { - int fd; - const char *pfn; - struct stat st; + if (exists) + { + /* We succeeded; return this descriptor and filename. */ + if (storeptr) + *storeptr = string; + SAFE_FREE (); + return -2; + } + } + else + { + int fd; + const char *pfn; + struct stat st; - encoded_fn = ENCODE_FILE (string); - pfn = SSDATA (encoded_fn); + encoded_fn = ENCODE_FILE (string); + pfn = SSDATA (encoded_fn); - /* Check that we can access or open it. */ - if (NATNUMP (predicate)) - { - fd = -1; - if (INT_MAX < XFASTINT (predicate)) - last_errno = EINVAL; - else if (faccessat (AT_FDCWD, pfn, XFASTINT (predicate), - AT_EACCESS) - == 0) - { - if (file_directory_p (pfn)) - last_errno = EISDIR; - else - fd = 1; - } - } - else - { - fd = emacs_open (pfn, O_RDONLY, 0); - if (fd < 0) - { - if (errno != ENOENT) - last_errno = errno; - } - else - { - int err = (fstat (fd, &st) != 0 ? errno - : S_ISDIR (st.st_mode) ? EISDIR : 0); - if (err) - { - last_errno = err; - emacs_close (fd); - fd = -1; - } - } - } + /* Check that we can access or open it. */ + if (FIXNATP (predicate)) + { + fd = -1; + if (INT_MAX < XFIXNAT (predicate)) + last_errno = EINVAL; + else if (faccessat (AT_FDCWD, pfn, XFIXNAT (predicate), + AT_EACCESS) + == 0) + { + if (file_directory_p (encoded_fn)) + last_errno = EISDIR; + else + fd = 1; + } + } + else + { + fd = emacs_open (pfn, O_RDONLY, 0); + if (fd < 0) + { + if (errno != ENOENT) + last_errno = errno; + } + else + { + int err = (fstat (fd, &st) != 0 ? errno + : S_ISDIR (st.st_mode) ? EISDIR : 0); + if (err) + { + last_errno = err; + emacs_close (fd); + fd = -1; + } + } + } - if (fd >= 0) - { - if (newer && !NATNUMP (predicate)) - { - struct timespec mtime = get_stat_mtime (&st); + if (fd >= 0) + { + if (newer && !FIXNATP (predicate)) + { + struct timespec mtime = get_stat_mtime (&st); - if (timespec_cmp (mtime, save_mtime) <= 0) - emacs_close (fd); - else - { - if (0 <= save_fd) - emacs_close (save_fd); - save_fd = fd; - save_mtime = mtime; - save_string = string; - } - } - else - { - /* We succeeded; return this descriptor and filename. */ - if (storeptr) - *storeptr = string; - SAFE_FREE (); - return fd; - } - } + if (timespec_cmp (mtime, save_mtime) <= 0) + emacs_close (fd); + else + { + if (0 <= save_fd) + emacs_close (save_fd); + save_fd = fd; + save_mtime = mtime; + save_string = string; + } + } + else + { + /* We succeeded; return this descriptor and filename. */ + if (storeptr) + *storeptr = string; + SAFE_FREE (); + return fd; + } + } - /* No more suffixes. Return the newest. */ - if (0 <= save_fd && ! CONSP (XCDR (tail))) - { - if (storeptr) - *storeptr = save_string; - SAFE_FREE (); - return save_fd; - } - } - } - if (absolute) - break; - } + /* No more suffixes. Return the newest. */ + if (0 <= save_fd && ! CONSP (XCDR (tail))) + { + if (storeptr) + *storeptr = save_string; + SAFE_FREE (); + return save_fd; + } + } + } + if (absolute || NILP (path)) + break; + path = XCDR (path); + } while (CONSP (path)); SAFE_FREE (); errno = last_errno; @@ -1945,11 +1988,11 @@ readevalloop (Lisp_Object readcharfun, if (!NILP (start)) { /* Switch to the buffer we are reading from. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); set_buffer_internal (b); /* Save point in it. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); /* Save ZV in it. */ record_unwind_protect (save_restriction_restore, save_restriction_save ()); /* Those get unbound after we read one expression. */ @@ -1957,11 +2000,11 @@ readevalloop (Lisp_Object readcharfun, /* Set point and ZV around stuff to be read. */ Fgoto_char (start); if (!NILP (end)) - Fnarrow_to_region (make_number (BEGV), end); + Fnarrow_to_region (make_fixnum (BEGV), end); /* Just for cleanliness, convert END to a marker if it is an integer. */ - if (INTEGERP (end)) + if (FIXNUMP (end)) end = Fpoint_max_marker (); } @@ -2106,15 +2149,13 @@ This function preserves the position of point. */) specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list)); specbind (Qstandard_output, tem); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); readevalloop (buf, 0, filename, !NILP (printflag), unibyte, Qnil, Qnil, Qnil); - unbind_to (count, Qnil); - - return Qnil; + return unbind_to (count, Qnil); } DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r", @@ -2193,7 +2234,7 @@ the end of STRING. */) CHECK_STRING (string); /* `read_internal_start' sets `read_from_string_index'. */ ret = read_internal_start (string, start, end); - return Fcons (ret, make_number (read_from_string_index)); + return Fcons (ret, make_fixnum (read_from_string_index)); } /* Function to set up the global context we need in toplevel read @@ -2204,7 +2245,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) Lisp_Object retval; readchar_count = 0; - new_backquote_flag = 0; + new_backquote_flag = force_new_style_backquotes; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -2279,7 +2320,7 @@ read0 (Lisp_Object readcharfun) return val; xsignal1 (Qinvalid_read_syntax, - Fmake_string (make_number (1), make_number (c))); + Fmake_string (make_fixnum (1), make_fixnum (c), Qnil)); } /* Grow a read buffer BUF that contains OFFSET useful bytes of data, @@ -2313,20 +2354,22 @@ character_name_to_code (char const *name, ptrdiff_t name_len) { /* For "U+XXXX", pass the leading '+' to string_to_number to reject monstrosities like "U+-0000". */ + ptrdiff_t len = name_len - 1; Lisp_Object code = (name[0] == 'U' && name[1] == '+' - ? string_to_number (name + 1, 16, false) + ? string_to_number (name + 1, 16, &len) : call2 (Qchar_from_name, make_unibyte_string (name, name_len), Qt)); - if (! RANGED_INTEGERP (0, code, MAX_UNICODE_CHAR) - || char_surrogate_p (XINT (code))) + if (! RANGED_FIXNUMP (0, code, MAX_UNICODE_CHAR) + || len != name_len - 1 + || char_surrogate_p (XFIXNUM (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); + return XFIXNUM (code); } /* Bound on the length of a Unicode character name. As of @@ -2550,7 +2593,7 @@ read_escape (Lisp_Object readcharfun, bool stringp) AUTO_STRING (format, "Invalid character U+%04X in character name"); xsignal1 (Qinvalid_read_syntax, - CALLN (Fformat, format, make_natnum (c))); + CALLN (Fformat, format, make_fixed_natnum (c))); } /* Treat multiple adjacent whitespace characters as a single space character. This makes it easier to use @@ -2602,6 +2645,13 @@ digit_to_number (int character, int base) return digit < base ? digit : -1; } +static void +free_contents (void *p) +{ + void **ptr = (void **) p; + xfree (*ptr); +} + /* Read an integer in radix RADIX using READCHARFUN to read characters. RADIX must be in the interval [2..36]; if it isn't, a read error is signaled . Value is the integer read. Signals an @@ -2613,18 +2663,24 @@ 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 + UINTMAX_WIDTH + 1, - sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT))]; - + size_t len = max (1 + 1 + UINTMAX_WIDTH + 1, + sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT)); + char *buf = NULL; + char *p = buf; int valid = -1; /* 1 if valid, 0 if not, -1 if incomplete. */ + ptrdiff_t count = SPECPDL_INDEX (); + if (radix < 2 || radix > 36) valid = 0; else { - char *p = buf; int c, digit; + buf = xmalloc (len); + record_unwind_protect_ptr (free_contents, &buf); + p = buf; + c = READCHAR; if (c == '-' || c == '+') { @@ -2650,17 +2706,19 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) valid = 0; if (valid < 0) valid = 1; - - if (p < buf + sizeof buf - 1) - *p++ = c; - else - valid = 0; - + /* Allow 1 extra byte for the \0. */ + if (p + 1 == buf + len) + { + ptrdiff_t where = p - buf; + len *= 2; + buf = xrealloc (buf, len); + p = buf + where; + } + *p++ = c; c = READCHAR; } UNREAD (c); - *p = '\0'; } if (valid != 1) @@ -2669,7 +2727,8 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) invalid_syntax (buf); } - return string_to_number (buf, radix, 0); + *p = '\0'; + return unbind_to (count, string_to_number (buf, radix, 0)); } @@ -2734,9 +2793,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (!EQ (head, Qhash_table)) { - ptrdiff_t size = XINT (Flength (tmp)); + ptrdiff_t size = XFIXNUM (Flength (tmp)); Lisp_Object record = Fmake_record (CAR_SAFE (tmp), - make_number (size - 1), + make_fixnum (size - 1), Qnil); for (int i = 1; i < size; i++) { @@ -2821,24 +2880,24 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Sub char-table can't be read as a regular vector because of a two C integer fields. */ Lisp_Object tbl, tmp = read_list (1, readcharfun); - ptrdiff_t size = XINT (Flength (tmp)); + ptrdiff_t size = XFIXNUM (Flength (tmp)); int i, depth, min_char; struct Lisp_Cons *cell; if (size == 0) error ("Zero-sized sub char-table"); - if (! RANGED_INTEGERP (1, XCAR (tmp), 3)) + if (! RANGED_FIXNUMP (1, XCAR (tmp), 3)) error ("Invalid depth in sub char-table"); - depth = XINT (XCAR (tmp)); + depth = XFIXNUM (XCAR (tmp)); if (chartab_size[depth] != size - 2) error ("Invalid size in sub char-table"); cell = XCONS (tmp), tmp = XCDR (tmp), size--; free_cons (cell); - if (! RANGED_INTEGERP (0, XCAR (tmp), MAX_CHAR)) + if (! RANGED_FIXNUMP (0, XCAR (tmp), MAX_CHAR)) error ("Invalid minimum character in sub-char-table"); - min_char = XINT (XCAR (tmp)); + min_char = XFIXNUM (XCAR (tmp)); cell = XCONS (tmp), tmp = XCDR (tmp), size--; free_cons (cell); @@ -2863,7 +2922,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '"') { Lisp_Object tmp, val; - EMACS_INT size_in_chars = bool_vector_bytes (XFASTINT (length)); + EMACS_INT size_in_chars = bool_vector_bytes (XFIXNAT (length)); unsigned char *data; UNREAD (c); @@ -2874,17 +2933,17 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) when the number of bits was a multiple of 8. Accept such input in case it came from an old version. */ - && ! (XFASTINT (length) + && ! (XFIXNAT (length) == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR))) invalid_syntax ("#&..."); - val = make_uninit_bool_vector (XFASTINT (length)); + val = make_uninit_bool_vector (XFIXNAT (length)); data = bool_vector_uchar_data (val); memcpy (data, SDATA (tmp), size_in_chars); /* Clear the extraneous bits in the last byte. */ - if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR) + if (XFIXNUM (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR) data[size_in_chars - 1] - &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; + &= (1 << (XFIXNUM (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; return val; } invalid_syntax ("#&..."); @@ -3097,7 +3156,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map); EMACS_UINT hash; - Lisp_Object number = make_number (n); + Lisp_Object number = make_fixnum (n); ptrdiff_t i = hash_lookup (h, number, &hash); if (i >= 0) @@ -3148,7 +3207,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map); - ptrdiff_t i = hash_lookup (h, make_number (n), NULL); + ptrdiff_t i = hash_lookup (h, make_fixnum (n), NULL); if (i >= 0) return HASH_VALUE (h, i); } @@ -3188,10 +3247,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) first_in_list exception (old-style can still be obtained via "(\`" anyway). */ if (!new_backquote_flag && first_in_list && next_char == ' ') - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); else { Lisp_Object value; @@ -3242,10 +3298,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return list2 (comma_type, value); } else - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); } case '?': { @@ -3262,13 +3315,13 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) Other literal whitespace like NL, CR, and FF are not accepted, as there are well-established escape sequences for these. */ if (c == ' ' || c == '\t') - return make_number (c); + return make_fixnum (c); if (c == '(' || c == ')' || c == '[' || c == ']' || c == '"' || c == ';') { CHECK_LIST (Vlread_unescaped_character_literals); - Lisp_Object char_obj = make_natnum (c); + Lisp_Object char_obj = make_fixed_natnum (c); if (NILP (Fmemq (char_obj, Vlread_unescaped_character_literals))) Vlread_unescaped_character_literals = Fcons (char_obj, Vlread_unescaped_character_literals); @@ -3288,7 +3341,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) && strchr ("\"';()[]#?`,.", next_char) != NULL)); UNREAD (next_char); if (ok) - return make_number (c); + return make_fixnum (c); invalid_syntax ("?"); } @@ -3397,7 +3450,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 unbind_to (count, make_number (0)); + return unbind_to (count, make_fixnum (0)); if (! force_multibyte && force_singlebyte) { @@ -3433,7 +3486,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) row. */ FALLTHROUGH; default: - default_label: if (c <= 040) goto retry; if (c == NO_BREAK_SPACE) goto retry; @@ -3481,17 +3533,25 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) || strchr ("\"';()[]#`,", c) == NULL)); *p = 0; + ptrdiff_t nbytes = p - read_buffer; UNREAD (c); if (!quoted && !uninterned_symbol) { - Lisp_Object result = string_to_number (read_buffer, 10, 0); - if (! NILP (result)) + ptrdiff_t len; + Lisp_Object result = string_to_number (read_buffer, 10, &len); + if (! NILP (result) && len == nbytes) return unbind_to (count, result); } + if (!quoted && multibyte) + { + int ch = STRING_CHAR ((unsigned char *) read_buffer); + if (confusable_symbol_character_p (ch)) + xsignal2 (Qinvalid_read_syntax, build_string ("strange quote"), + CALLN (Fstring, make_fixnum (ch))); + } { Lisp_Object result; - ptrdiff_t nbytes = p - read_buffer; ptrdiff_t nchars = (multibyte ? multibyte_chars_in_text ((unsigned char *) read_buffer, @@ -3530,7 +3590,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, readcharfun)) Vread_symbol_positions_list - = Fcons (Fcons (result, make_number (start_position)), + = Fcons (Fcons (result, make_fixnum (start_position)), Vread_symbol_positions_list); return unbind_to (count, result); } @@ -3571,7 +3631,7 @@ substitute_object_recurse (struct subst *subst, Lisp_Object subtree) return subtree; /* If we've been to this node before, don't explore it again. */ - if (!EQ (Qnil, Fmemq (subtree, subst->seen))) + if (!NILP (Fmemq (subtree, subst->seen))) return subtree; /* If this node can be the entry point to a cycle, remember that @@ -3643,27 +3703,27 @@ substitute_in_interval (INTERVAL interval, void *arg) } -/* Convert STRING to a number, assuming base BASE. Return a fixnum if - STRING has integer syntax and fits in a fixnum, else return the - nearest float if STRING has either floating point or integer syntax - and BASE is 10, else return nil. If IGNORE_TRAILING, consider just - the longest prefix of STRING that has valid floating point syntax. - Signal an overflow if BASE is not 10 and the number has integer - syntax but does not fit. */ +/* Convert the initial prefix of STRING to a number, assuming base BASE. + If the prefix has floating point syntax and BASE is 10, return a + nearest float; otherwise, if the prefix has integer syntax, return + the integer; otherwise, return nil. If PLEN, set *PLEN to the + length of the numeric prefix if there is one, otherwise *PLEN is + unspecified. */ Lisp_Object -string_to_number (char const *string, int base, bool ignore_trailing) +string_to_number (char const *string, int base, ptrdiff_t *plen) { char const *cp = string; - bool float_syntax = 0; + bool float_syntax = false; double value = 0; /* Negate the value ourselves. This treats 0, NaNs, and infinity properly on IEEE floating point hosts, and works around a formerly-common bug where atof ("-0.0") drops the sign. */ bool negative = *cp == '-'; + bool positive = *cp == '+'; - bool signedp = negative || *cp == '+'; + bool signedp = negative | positive; cp += signedp; enum { INTOVERFLOW = 1, LEAD_INT = 2, DOT_CHAR = 4, TRAIL_INT = 8, @@ -3684,6 +3744,7 @@ string_to_number (char const *string, int base, bool ignore_trailing) n += digit; } } + char const *after_digits = cp; if (*cp == '.') { state |= DOT_CHAR; @@ -3712,6 +3773,7 @@ string_to_number (char const *string, int base, bool ignore_trailing) cp++; while ('0' <= *cp && *cp <= '9'); } +#if IEEE_FLOATING_POINT else if (cp[-1] == '+' && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F') { @@ -3724,9 +3786,12 @@ string_to_number (char const *string, int base, bool ignore_trailing) { state |= E_EXP; cp += 3; - /* NAN is a "positive" NaN on all known Emacs hosts. */ - value = NAN; + union ieee754_double u + = { .ieee_nan = { .exponent = -1, .quiet_nan = 1, + .mantissa0 = n >> 31 >> 1, .mantissa1 = n }}; + value = u.d; } +#endif else cp = ecp; } @@ -3735,63 +3800,63 @@ string_to_number (char const *string, int base, bool ignore_trailing) || (state & ~INTOVERFLOW) == (LEAD_INT|E_EXP)); } - /* Return nil if the number uses invalid syntax. If IGNORE_TRAILING, accept - any prefix that matches. Otherwise, the entire string must match. */ - if (! (ignore_trailing - ? ((state & LEAD_INT) != 0 || float_syntax) - : (!*cp && ((state & ~(INTOVERFLOW | DOT_CHAR)) == LEAD_INT - || float_syntax)))) - return Qnil; + if (plen) + *plen = cp - string; - /* If the number uses integer and not float syntax, and is in C-language - range, use its value, preferably as a fixnum. */ - if (leading_digit >= 0 && ! float_syntax) + /* Return a float if the number uses float syntax. */ + if (float_syntax) { - if (state & INTOVERFLOW) - { - /* Unfortunately there's no simple and accurate way to convert - non-base-10 numbers that are out of C-language range. */ - if (base != 10) - xsignal1 (Qoverflow_error, build_string (string)); - } - else if (n <= (negative ? -MOST_NEGATIVE_FIXNUM : MOST_POSITIVE_FIXNUM)) - { - EMACS_INT signed_n = n; - return make_number (negative ? -signed_n : signed_n); - } - else - value = n; + /* Convert to floating point, unless the value is already known + because it is infinite or a NaN. */ + if (! value) + value = atof (string + signedp); + return make_float (negative ? -value : value); } - /* Either the number uses float syntax, or it does not fit into a fixnum. - Convert it from string to floating point, unless the value is already - known because it is an infinity, a NAN, or its absolute value fits in - uintmax_t. */ - if (! value) - value = atof (string + signedp); + /* Return nil if the number uses invalid syntax. */ + if (! (state & LEAD_INT)) + return Qnil; + + /* Fast path if the integer (san sign) fits in uintmax_t. */ + if (! (state & INTOVERFLOW)) + { + if (!negative) + return make_uint (n); + if (-MOST_NEGATIVE_FIXNUM < n) + return make_neg_biguint (n); + EMACS_INT signed_n = n; + return make_fixnum (-signed_n); + } - return make_float (negative ? -value : value); + /* Trim any leading "+" and trailing nondigits, then return a bignum. */ + string += positive; + if (!*after_digits) + return make_bignum_str (string, base); + ptrdiff_t trimmed_len = after_digits - string; + USE_SAFE_ALLOCA; + char *trimmed = SAFE_ALLOCA (trimmed_len + 1); + memcpy (trimmed, string, trimmed_len); + trimmed[trimmed_len] = '\0'; + Lisp_Object result = make_bignum_str (trimmed, base); + SAFE_FREE (); + return result; } static Lisp_Object read_vector (Lisp_Object readcharfun, bool bytecodeflag) { - ptrdiff_t i, size; - Lisp_Object *ptr; - Lisp_Object tem, item, vector; - struct Lisp_Cons *otem; - Lisp_Object len; - - tem = read_list (1, readcharfun); - len = Flength (tem); - vector = Fmake_vector (len, Qnil); - - size = ASIZE (vector); - ptr = XVECTOR (vector)->contents; - for (i = 0; i < size; i++) + Lisp_Object tem = read_list (1, readcharfun); + Lisp_Object len = Flength (tem); + ptrdiff_t size = XFIXNAT (len); + if (bytecodeflag && size <= COMPILED_STACK_DEPTH) + error ("Invalid byte code"); + Lisp_Object vector = make_nil_vector (size); + + Lisp_Object *ptr = XVECTOR (vector)->contents; + for (ptrdiff_t i = 0; i < size; i++) { - item = Fcar (tem); + Lisp_Object item = Fcar (tem); /* If `load-force-doc-strings' is t when reading a lazily-loaded bytecode object, the docstring containing the bytecode and constants values must be treated as unibyte and passed to @@ -3825,7 +3890,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) if (!CONSP (item)) error ("Invalid byte code"); - otem = XCONS (item); + struct Lisp_Cons *otem = XCONS (item); bytestr = XCAR (item); item = XCDR (item); free_cons (otem); @@ -3845,7 +3910,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) } } ASET (vector, i, item); - otem = XCONS (tem); + struct Lisp_Cons *otem = XCONS (tem); tem = Fcdr (tem); free_cons (otem); } @@ -3925,8 +3990,8 @@ read_list (bool flag, Lisp_Object readcharfun) if (ch == ')') { if (doc_reference == 1) - return make_number (0); - if (doc_reference == 2 && INTEGERP (XCDR (val))) + return make_fixnum (0); + if (doc_reference == 2 && FIXNUMP (XCDR (val))) { char *saved = NULL; file_offset saved_position; @@ -3941,7 +4006,7 @@ read_list (bool flag, Lisp_Object readcharfun) multibyte. */ /* Position is negative for user variables. */ - EMACS_INT pos = eabs (XINT (XCDR (val))); + EMACS_INT pos = eabs (XFIXNUM (XCDR (val))); if (pos >= saved_doc_string_position && pos < (saved_doc_string_position + saved_doc_string_length)) @@ -4046,7 +4111,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) SET_SYMBOL_VAL (XSYMBOL (sym), sym); } - ptr = aref_addr (obarray, XINT (index)); + ptr = aref_addr (obarray, XFIXNUM (index)); set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL); *ptr = sym; return sym; @@ -4104,7 +4169,7 @@ define_symbol (Lisp_Object sym, char const *str) if (! EQ (sym, Qunbound)) { Lisp_Object bucket = oblookup (initial_obarray, str, len, len); - eassert (INTEGERP (bucket)); + eassert (FIXNUMP (bucket)); intern_sym (sym, initial_obarray, bucket); } } @@ -4150,7 +4215,7 @@ it defaults to the value of `obarray'. */) string = SYMBOL_NAME (name); tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string)); - if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem))) + if (FIXNUMP (tem) || (SYMBOLP (name) && !EQ (name, tem))) return Qnil; else return tem; @@ -4182,7 +4247,7 @@ usage: (unintern NAME OBARRAY) */) tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string)); - if (INTEGERP (tem)) + if (FIXNUMP (tem)) return Qnil; /* If arg was a symbol, don't delete anything but that symbol itself. */ if (SYMBOLP (name) && !EQ (name, tem)) @@ -4192,7 +4257,7 @@ usage: (unintern NAME OBARRAY) */) session if we unintern them, as well as even more ways to use `setq' or `fset' or whatnot to make the Emacs session unusable. Let's not go down this silly road. --Stef */ - /* if (EQ (tem, Qnil) || EQ (tem, Qt)) + /* if (NILP (tem) || EQ (tem, Qt)) error ("Attempt to unintern t or nil"); */ XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED; @@ -4208,7 +4273,7 @@ usage: (unintern NAME OBARRAY) */) ASET (obarray, hash, sym); } else - ASET (obarray, hash, make_number (0)); + ASET (obarray, hash, make_fixnum (0)); } else { @@ -4251,7 +4316,7 @@ oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff hash = hash_string (ptr, size_byte) % obsize; bucket = AREF (obarray, hash); oblookup_last_bucket_number = hash; - if (EQ (bucket, make_number (0))) + if (EQ (bucket, make_fixnum (0))) ; else if (!SYMBOLP (bucket)) error ("Bad data in guts of obarray"); /* Like CADR error message. */ @@ -4312,7 +4377,7 @@ OBARRAY defaults to the value of `obarray'. */) void init_obarray (void) { - Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0)); + Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0)); initial_obarray = Vobarray; staticpro (&initial_obarray); @@ -4338,8 +4403,9 @@ init_obarray (void) } void -defsubr (struct Lisp_Subr *sname) +defsubr (union Aligned_Lisp_Subr *aname) { + struct Lisp_Subr *sname = &aname->s; Lisp_Object sym, tem; sym = intern_c_string (sname->symbol_name); XSETPVECTYPE (sname, PVEC_SUBR); @@ -4898,7 +4964,7 @@ directory. These file names are converted to absolute at startup. */); If the file loaded had extension `.elc', and the corresponding source file exists, this variable contains the name of source file, suitable for use by functions like `custom-save-all' which edit the init file. -While Emacs loads and evaluates the init file, value is the real name +While Emacs loads and evaluates any init file, value is the real name of the file, regardless of whether or not it has the `.elc' extension. */); Vuser_init_file = Qnil; @@ -4988,12 +5054,6 @@ variables, this must be set in the first line of a file. */); doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); Veval_buffer_list = Qnil; - DEFVAR_LISP ("lread--old-style-backquotes", Vlread_old_style_backquotes, - doc: /* Set to non-nil when `read' encounters an old-style backquote. -For internal use only. */); - Vlread_old_style_backquotes = Qnil; - DEFSYM (Qlread_old_style_backquotes, "lread--old-style-backquotes"); - DEFVAR_LISP ("lread--unescaped-character-literals", Vlread_unescaped_character_literals, doc: /* List of deprecated unescaped character literals encountered by `read'. @@ -5018,6 +5078,17 @@ Note that if you customize this, obviously it will not affect files that are loaded before your customizations are read! */); load_prefer_newer = 0; + DEFVAR_BOOL ("force-new-style-backquotes", force_new_style_backquotes, + doc: /* Non-nil means to always use the current syntax for backquotes. +If nil, `load' and `read' raise errors when encountering some +old-style variants of backquote and comma. If non-nil, these +constructs are always interpreted as described in the Info node +`(elisp)Backquotes', even if that interpretation is incompatible with +previous versions of Emacs. Setting this variable to non-nil makes +Emacs compatible with the behavior planned for Emacs 28. In Emacs 28, +this variable will become obsolete. */); + force_new_style_backquotes = false; + /* Vsource_directory was initialized in init_lread. */ DEFSYM (Qcurrent_load_list, "current-load-list"); diff --git a/src/macfont.m b/src/macfont.m index 42ebfd3d6b7..0e90eb44eeb 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -851,7 +851,7 @@ macfont_store_descriptor_attributes (CTFontDescriptorRef desc, * ((point->y - (point - 1)->y) / (point->x - (point - 1)->x))); FONT_SET_STYLE (spec_or_entity, numeric_traits[i].index, - make_number (lround (floatval))); + make_fixnum (lround (floatval))); } } @@ -864,16 +864,16 @@ macfont_store_descriptor_attributes (CTFontDescriptorRef desc, cfnumber_get_font_symbolic_traits_value (num, &sym_traits); spacing = (sym_traits & kCTFontTraitMonoSpace ? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL); - ASET (spec_or_entity, FONT_SPACING_INDEX, make_number (spacing)); + ASET (spec_or_entity, FONT_SPACING_INDEX, make_fixnum (spacing)); } CFRelease (dict); } num = CTFontDescriptorCopyAttribute (desc, kCTFontSizeAttribute); if (num && CFNumberGetValue (num, kCFNumberCGFloatType, &floatval)) - ASET (spec_or_entity, FONT_SIZE_INDEX, make_number (floatval)); + ASET (spec_or_entity, FONT_SIZE_INDEX, make_fixnum (floatval)); else - ASET (spec_or_entity, FONT_SIZE_INDEX, make_number (0)); + ASET (spec_or_entity, FONT_SIZE_INDEX, make_fixnum (0)); if (num) CFRelease (num); } @@ -903,21 +903,22 @@ macfont_descriptor_entity (CTFontDescriptorRef desc, Lisp_Object extra, cfnumber_get_font_symbolic_traits_value (num, &sym_traits); CFRelease (dict); } - if (EQ (AREF (entity, FONT_SIZE_INDEX), make_number (0))) - ASET (entity, FONT_AVGWIDTH_INDEX, make_number (0)); + if (EQ (AREF (entity, FONT_SIZE_INDEX), make_fixnum (0))) + ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (0)); ASET (entity, FONT_EXTRA_INDEX, Fcopy_sequence (extra)); name = CTFontDescriptorCopyAttribute (desc, kCTFontNameAttribute); font_put_extra (entity, QCfont_entity, - make_save_ptr_int ((void *) name, sym_traits)); + Fcons (make_mint_ptr ((void *) name), + make_fixnum (sym_traits))); if (synth_sym_traits & kCTFontTraitItalic) FONT_SET_STYLE (entity, FONT_SLANT_INDEX, - make_number (FONT_SLANT_SYNTHETIC_ITALIC)); + make_fixnum (FONT_SLANT_SYNTHETIC_ITALIC)); if (synth_sym_traits & kCTFontTraitBold) FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, - make_number (FONT_WEIGHT_SYNTHETIC_BOLD)); + make_fixnum (FONT_WEIGHT_SYNTHETIC_BOLD)); if (synth_sym_traits & kCTFontTraitMonoSpace) ASET (entity, FONT_SPACING_INDEX, - make_number (FONT_SPACING_SYNTHETIC_MONO)); + make_fixnum (FONT_SPACING_SYNTHETIC_MONO)); return entity; } @@ -943,8 +944,8 @@ macfont_invalidate_family_cache (void) { Lisp_Object value = HASH_VALUE (h, i); - if (SAVE_VALUEP (value)) - CFRelease (XSAVE_POINTER (value, 0)); + if (mint_ptrp (value)) + CFRelease (xmint_pointer (value)); } macfont_family_cache = Qnil; } @@ -962,7 +963,7 @@ macfont_get_family_cache_if_present (Lisp_Object symbol, CFStringRef *string) { Lisp_Object value = HASH_VALUE (h, i); - *string = SAVE_VALUEP (value) ? XSAVE_POINTER (value, 0) : NULL; + *string = mint_ptrp (value) ? xmint_pointer (value) : NULL; return true; } @@ -984,13 +985,13 @@ macfont_set_family_cache (Lisp_Object symbol, CFStringRef string) h = XHASH_TABLE (macfont_family_cache); i = hash_lookup (h, symbol, &hash); - value = string ? make_save_ptr ((void *) CFRetain (string)) : Qnil; + value = string ? make_mint_ptr ((void *) CFRetain (string)) : Qnil; if (i >= 0) { Lisp_Object old_value = HASH_VALUE (h, i); - if (SAVE_VALUEP (old_value)) - CFRelease (XSAVE_POINTER (old_value, 0)); + if (mint_ptrp (old_value)) + CFRelease (xmint_pointer (old_value)); set_hash_value_slot (h, i, value); } else @@ -1441,8 +1442,6 @@ macfont_get_glyph_for_character (struct font *font, UTF32Char c) CGGlyph *glyphs; int i, len; int nrows; - dispatch_queue_t queue; - dispatch_group_t group = NULL; int nkeys; if (row != 0) @@ -1799,9 +1798,9 @@ macfont_get_open_type_spec (Lisp_Object otf_spec) continue; len = Flength (val); spec->features[i] = - (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XINT (len) + (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XFIXNUM (len) ? 0 - : malloc (XINT (len) * sizeof *spec->features[i])); + : malloc (XFIXNUM (len) * sizeof *spec->features[i])); if (! spec->features[i]) { if (i > 0 && spec->features[0]) @@ -1941,9 +1940,9 @@ macfont_create_attributes_with_spec (Lisp_Object spec) { UniChar unichars[2]; CFIndex count = - macfont_store_utf32char_to_unichars (XFASTINT (XCAR (chars)), + macfont_store_utf32char_to_unichars (XFIXNAT (XCAR (chars)), unichars); - CFRange range = CFRangeMake (XFASTINT (XCAR (chars)), 1); + CFRange range = CFRangeMake (XFIXNAT (XCAR (chars)), 1); CFStringAppendCharacters (string, unichars, count); CFCharacterSetAddCharactersInRange (cs, range); @@ -1982,10 +1981,10 @@ macfont_create_attributes_with_spec (Lisp_Object spec) for (i = 0; i < ARRAYELTS (numeric_traits); i++) { tmp = AREF (spec, numeric_traits[i].index); - if (INTEGERP (tmp)) + if (FIXNUMP (tmp)) { CGPoint *point = numeric_traits[i].points; - CGFloat floatval = (XINT (tmp) >> 8); // XXX + CGFloat floatval = (XFIXNUM (tmp) >> 8); // XXX CFNumberRef num; while (point->y < floatval) @@ -2070,9 +2069,9 @@ macfont_supports_charset_and_languages_p (CTFontDescriptorRef desc, ptrdiff_t j; for (j = 0; j < ASIZE (chars); j++) - if (TYPE_RANGED_INTEGERP (UTF32Char, AREF (chars, j)) + if (TYPE_RANGED_FIXNUMP (UTF32Char, AREF (chars, j)) && CFCharacterSetIsLongCharacterMember (desc_charset, - XFASTINT (AREF (chars, j)))) + XFIXNAT (AREF (chars, j)))) break; if (j == ASIZE (chars)) result = false; @@ -2162,8 +2161,8 @@ macfont_list (struct frame *f, Lisp_Object spec) languages = CFDictionaryGetValue (attributes, kCTFontLanguagesAttribute); - if (INTEGERP (AREF (spec, FONT_SPACING_INDEX))) - spacing = XINT (AREF (spec, FONT_SPACING_INDEX)); + if (FIXNUMP (AREF (spec, FONT_SPACING_INDEX))) + spacing = XFIXNUM (AREF (spec, FONT_SPACING_INDEX)); traits = ((CFMutableDictionaryRef) CFDictionaryGetValue (attributes, kCTFontTraitsAttribute)); @@ -2507,7 +2506,7 @@ macfont_free_entity (Lisp_Object entity) { Lisp_Object val = assq_no_quit (QCfont_entity, AREF (entity, FONT_EXTRA_INDEX)); - CFStringRef name = XSAVE_POINTER (XCDR (val), 0); + CFStringRef name = xmint_pointer (XCAR (XCDR (val))); block_input (); CFRelease (name); @@ -2530,13 +2529,12 @@ macfont_open (struct frame * f, Lisp_Object entity, int pixel_size) val = assq_no_quit (QCfont_entity, AREF (entity, FONT_EXTRA_INDEX)); if (! CONSP (val) - || XTYPE (XCDR (val)) != Lisp_Misc - || XMISCTYPE (XCDR (val)) != Lisp_Misc_Save_Value) + || ! CONSP (XCDR (val))) return Qnil; - font_name = XSAVE_POINTER (XCDR (val), 0); - sym_traits = XSAVE_INTEGER (XCDR (val), 1); + font_name = xmint_pointer (XCAR (XCDR (val))); + sym_traits = XFIXNUM (XCDR (XCDR (val))); - size = XINT (AREF (entity, FONT_SIZE_INDEX)); + size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); if (size == 0) size = pixel_size; @@ -2565,7 +2563,7 @@ macfont_open (struct frame * f, Lisp_Object entity, int pixel_size) macfont_info->cgfont = CTFontCopyGraphicsFont (macfont, NULL); val = assq_no_quit (QCdestination, AREF (entity, FONT_EXTRA_INDEX)); - if (CONSP (val) && EQ (XCDR (val), make_number (1))) + if (CONSP (val) && EQ (XCDR (val), make_fixnum (1))) macfont_info->screen_font = mac_screen_font_create_with_name (font_name, size); else @@ -2586,8 +2584,8 @@ macfont_open (struct frame * f, Lisp_Object entity, int pixel_size) macfont_info->synthetic_bold_p = 1; if (sym_traits & kCTFontTraitMonoSpace) macfont_info->spacing = MACFONT_SPACING_MONO; - else if (INTEGERP (AREF (entity, FONT_SPACING_INDEX)) - && (XINT (AREF (entity, FONT_SPACING_INDEX)) + else if (FIXNUMP (AREF (entity, FONT_SPACING_INDEX)) + && (XFIXNUM (AREF (entity, FONT_SPACING_INDEX)) == FONT_SPACING_SYNTHETIC_MONO)) macfont_info->spacing = MACFONT_SPACING_SYNTHETIC_MONO; if (macfont_info->synthetic_italic_p || macfont_info->synthetic_bold_p) @@ -2713,7 +2711,7 @@ macfont_has_char (Lisp_Object font, int c) val = assq_no_quit (QCfont_entity, AREF (font, FONT_EXTRA_INDEX)); val = XCDR (val); - name = XSAVE_POINTER (val, 0); + name = xmint_pointer (XCAR (val)); charset = macfont_get_cf_charset_for_name (name); } else @@ -2994,7 +2992,7 @@ macfont_shape (Lisp_Object lgstring) if (NILP (lglyph)) { - lglyph = Fmake_vector (make_number (LGLYPH_SIZE), Qnil); + lglyph = make_nil_vector (LGLYPH_SIZE); LGSTRING_SET_GLYPH (lgstring, i, lglyph); } @@ -3046,19 +3044,17 @@ macfont_shape (Lisp_Object lgstring) wadjust = lround (gl->advance); if (xoff != 0 || yoff != 0 || wadjust != metrics.width) { - Lisp_Object vec; - - vec = Fmake_vector (make_number (3), Qnil); - ASET (vec, 0, make_number (xoff)); - ASET (vec, 1, make_number (yoff)); - ASET (vec, 2, make_number (wadjust)); + Lisp_Object vec = make_uninit_vector (3); + ASET (vec, 0, make_fixnum (xoff)); + ASET (vec, 1, make_fixnum (yoff)); + ASET (vec, 2, make_fixnum (wadjust)); LGLYPH_SET_ADJUSTMENT (lglyph, vec); } } unblock_input (); - return make_number (used); + return make_fixnum (used); } /* Structures for the UVS subtable (format 14) in the cmap table. */ diff --git a/src/macros.c b/src/macros.c index 5f34d4f609c..eaf9c83fb88 100644 --- a/src/macros.c +++ b/src/macros.c @@ -97,9 +97,9 @@ macro before appending to it. */) for (i = 0; i < len; i++) { Lisp_Object c; - c = Faref (KVAR (current_kboard, Vlast_kbd_macro), make_number (i)); - if (cvt && NATNUMP (c) && (XFASTINT (c) & 0x80)) - XSETFASTINT (c, CHAR_META | (XFASTINT (c) & ~0x80)); + c = Faref (KVAR (current_kboard, Vlast_kbd_macro), make_fixnum (i)); + if (cvt && FIXNATP (c) && (XFIXNAT (c) & 0x80)) + XSETFASTINT (c, CHAR_META | (XFIXNAT (c) & ~0x80)); current_kboard->kbd_macro_buffer[i] = c; } @@ -110,7 +110,7 @@ macro before appending to it. */) for consistency of behavior. */ if (NILP (no_exec)) Fexecute_kbd_macro (KVAR (current_kboard, Vlast_kbd_macro), - make_number (1), Qnil); + make_fixnum (1), Qnil); message1 ("Appending to kbd macro..."); } @@ -154,7 +154,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */) if (NILP (repeat)) XSETFASTINT (repeat, 1); else - CHECK_NUMBER (repeat); + CHECK_FIXNUM (repeat); if (!NILP (KVAR (current_kboard, defining_kbd_macro))) { @@ -162,11 +162,11 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */) message1 ("Keyboard macro defined"); } - if (XFASTINT (repeat) == 0) + if (XFIXNAT (repeat) == 0) Fexecute_kbd_macro (KVAR (current_kboard, Vlast_kbd_macro), repeat, loopfunc); - else if (XINT (repeat) > 1) + else if (XFIXNUM (repeat) > 1) { - XSETINT (repeat, XINT (repeat) - 1); + XSETINT (repeat, XFIXNUM (repeat) - 1); Fexecute_kbd_macro (KVAR (current_kboard, Vlast_kbd_macro), repeat, loopfunc); } @@ -267,7 +267,7 @@ pop_kbd_macro (Lisp_Object info) Lisp_Object tem; Vexecuting_kbd_macro = XCAR (info); tem = XCDR (info); - executing_kbd_macro_index = XINT (XCAR (tem)); + executing_kbd_macro_index = XFIXNUM (XCAR (tem)); Vreal_this_command = XCDR (tem); run_hook (Qkbd_macro_termination_hook); } @@ -293,7 +293,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */) if (!NILP (count)) { count = Fprefix_numeric_value (count); - repeat = XINT (count); + repeat = XFIXNUM (count); } final = indirect_function (macro); @@ -301,7 +301,7 @@ each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */) error ("Keyboard macros must be strings or vectors"); tem = Fcons (Vexecuting_kbd_macro, - Fcons (make_number (executing_kbd_macro_index), + Fcons (make_fixnum (executing_kbd_macro_index), Vreal_this_command)); record_unwind_protect (pop_kbd_macro, tem); diff --git a/src/macuvs.h b/src/macuvs.h index 679e8fa457a..e83a372df4c 100644 --- a/src/macuvs.h +++ b/src/macuvs.h @@ -1,4 +1,5 @@ -/* Automatically generated by uvs.el. */ +/* This file was automatically generated from admin/unidata/IVD_Sequences.txt + by the script admin/unidata/uvs.el */ static const unsigned char mac_uvs_table_adobe_japan1_bytes[] = { 0x00, 0x0e, 0x00, 0x01, 0x1f, 0xb2, 0x00, 0x00, diff --git a/src/marker.c b/src/marker.c index 76ec13f01f4..36d6b10c746 100644 --- a/src/marker.c +++ b/src/marker.c @@ -90,7 +90,7 @@ clear_charpos_cache (struct buffer *b) #define CONSIDER(CHARPOS, BYTEPOS) \ { \ ptrdiff_t this_charpos = (CHARPOS); \ - bool changed = 0; \ + bool changed = false; \ \ if (this_charpos == charpos) \ { \ @@ -105,14 +105,14 @@ clear_charpos_cache (struct buffer *b) { \ best_above = this_charpos; \ best_above_byte = (BYTEPOS); \ - changed = 1; \ + changed = true; \ } \ } \ else if (this_charpos > best_below) \ { \ best_below = this_charpos; \ best_below_byte = (BYTEPOS); \ - changed = 1; \ + changed = true; \ } \ \ if (changed) \ @@ -133,6 +133,28 @@ CHECK_MARKER (Lisp_Object x) CHECK_TYPE (MARKERP (x), Qmarkerp, x); } +/* When converting bytes from/to chars, we look through the list of + markers to try and find a good starting point (since markers keep + track of both bytepos and charpos at the same time). + But if there are many markers, it can take too much time to find a "good" + marker from which to start. Worse yet: if it takes a long time and we end + up finding a nearby markers, we won't add a new marker to cache this + result, so next time around we'll have to go through this same long list + to (re)find this best marker. So the further down the list of + markers we go, the less demanding we are w.r.t what is a good marker. + + The previous code used INITIAL=50 and INCREMENT=0 and this lead to + really poor performance when there are many markers. + I haven't tried to tweak INITIAL, but experiments on my trusty Thinkpad + T61 using various artificial test cases seem to suggest that INCREMENT=50 + might be "the best compromise": it significantly improved the + worst case and it was rarely slower and never by much. + + The asymptotic behavior is still poor, tho, so in largish buffers with many + overlays (e.g. 300KB and 30K overlays), it can still be a bottleneck. */ +#define BYTECHAR_DISTANCE_INITIAL 50 +#define BYTECHAR_DISTANCE_INCREMENT 50 + /* Return the byte position corresponding to CHARPOS in B. */ ptrdiff_t @@ -141,6 +163,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) struct Lisp_Marker *tail; ptrdiff_t best_above, best_above_byte; ptrdiff_t best_below, best_below_byte; + ptrdiff_t distance = BYTECHAR_DISTANCE_INITIAL; eassert (BUF_BEG (b) <= charpos && charpos <= BUF_Z (b)); @@ -180,8 +203,11 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) /* If we are down to a range of 50 chars, don't bother checking any other markers; scan the intervening chars directly now. */ - if (best_above - best_below < 50) + if (best_above - charpos < distance + || charpos - best_below < distance) break; + else + distance += BYTECHAR_DISTANCE_INCREMENT; } /* We get here if we did not exactly hit one of the known places. @@ -248,7 +274,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) #define CONSIDER(BYTEPOS, CHARPOS) \ { \ ptrdiff_t this_bytepos = (BYTEPOS); \ - int changed = 0; \ + int changed = false; \ \ if (this_bytepos == bytepos) \ { \ @@ -263,14 +289,14 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) { \ best_above = (CHARPOS); \ best_above_byte = this_bytepos; \ - changed = 1; \ + changed = true; \ } \ } \ else if (this_bytepos > best_below_byte) \ { \ best_below = (CHARPOS); \ best_below_byte = this_bytepos; \ - changed = 1; \ + changed = true; \ } \ \ if (changed) \ @@ -293,6 +319,7 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos) struct Lisp_Marker *tail; ptrdiff_t best_above, best_above_byte; ptrdiff_t best_below, best_below_byte; + ptrdiff_t distance = BYTECHAR_DISTANCE_INITIAL; eassert (BUF_BEG_BYTE (b) <= bytepos && bytepos <= BUF_Z_BYTE (b)); @@ -323,8 +350,11 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos) /* If we are down to a range of 50 chars, don't bother checking any other markers; scan the intervening chars directly now. */ - if (best_above - best_below < 50) + if (best_above - bytepos < distance + || bytepos - best_below < distance) break; + else + distance += BYTECHAR_DISTANCE_INCREMENT; } /* We get here if we did not exactly hit one of the known places. @@ -417,7 +447,7 @@ DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0, { CHECK_MARKER (marker); if (XMARKER (marker)->buffer) - return make_number (XMARKER (marker)->charpos); + return make_fixnum (XMARKER (marker)->charpos); return Qnil; } @@ -491,11 +521,11 @@ set_marker_internal (Lisp_Object marker, Lisp_Object position, { register ptrdiff_t charpos, bytepos; - /* Do not use CHECK_NUMBER_COERCE_MARKER because we + /* Do not use CHECK_FIXNUM_COERCE_MARKER because we don't want to call buf_charpos_to_bytepos if POSITION is a marker and so we know the bytepos already. */ - if (INTEGERP (position)) - charpos = XINT (position), bytepos = -1; + if (FIXNUMP (position)) + charpos = XFIXNUM (position), bytepos = -1; else if (MARKERP (position)) { charpos = XMARKER (position)->charpos; @@ -682,7 +712,7 @@ see `marker-insertion-type'. */) register Lisp_Object new; if (!NILP (marker)) - CHECK_TYPE (INTEGERP (marker) || MARKERP (marker), Qinteger_or_marker_p, marker); + CHECK_TYPE (FIXNUMP (marker) || MARKERP (marker), Qinteger_or_marker_p, marker); new = Fmake_marker (); Fset_marker (new, marker, @@ -722,7 +752,7 @@ DEFUN ("buffer-has-markers-at", Fbuffer_has_markers_at, Sbuffer_has_markers_at, register struct Lisp_Marker *tail; register ptrdiff_t charpos; - charpos = clip_to_bounds (BEG, XINT (position), Z); + charpos = clip_to_bounds (BEG, XFIXNUM (position), Z); for (tail = BUF_MARKERS (current_buffer); tail; tail = tail->next) if (tail->charpos == charpos) @@ -753,8 +783,8 @@ count_markers (struct buffer *buf) ptrdiff_t verify_bytepos (ptrdiff_t charpos) { - ptrdiff_t below = 1; - ptrdiff_t below_byte = 1; + ptrdiff_t below = BEG; + ptrdiff_t below_byte = BEG_BYTE; while (below != charpos) { diff --git a/src/menu.c b/src/menu.c index 2ec82a26cd8..c35d711b314 100644 --- a/src/menu.c +++ b/src/menu.c @@ -86,7 +86,7 @@ init_menu_items (void) if (NILP (menu_items)) { menu_items_allocated = 60; - menu_items = Fmake_vector (make_number (menu_items_allocated), Qnil); + menu_items = make_nil_vector (menu_items_allocated); } menu_items_inuse = Qt; @@ -134,11 +134,11 @@ restore_menu_items (Lisp_Object saved) menu_items_inuse = (! NILP (menu_items) ? Qt : Qnil); menu_items_allocated = (VECTORP (menu_items) ? ASIZE (menu_items) : 0); saved = XCDR (saved); - menu_items_used = XINT (XCAR (saved)); + menu_items_used = XFIXNUM (XCAR (saved)); saved = XCDR (saved); - menu_items_n_panes = XINT (XCAR (saved)); + menu_items_n_panes = XFIXNUM (XCAR (saved)); saved = XCDR (saved); - menu_items_submenu_depth = XINT (XCAR (saved)); + menu_items_submenu_depth = XFIXNUM (XCAR (saved)); } /* Push the whole state of menu_items processing onto the specpdl. @@ -148,9 +148,9 @@ void save_menu_items (void) { Lisp_Object saved = list4 (!NILP (menu_items_inuse) ? menu_items : Qnil, - make_number (menu_items_used), - make_number (menu_items_n_panes), - make_number (menu_items_submenu_depth)); + make_fixnum (menu_items_used), + make_fixnum (menu_items_n_panes), + make_fixnum (menu_items_submenu_depth)); record_unwind_protect (restore_menu_items, saved); menu_items_inuse = Qnil; menu_items = Qnil; @@ -532,7 +532,7 @@ parse_single_submenu (Lisp_Object item_key, Lisp_Object item_name, USE_SAFE_ALLOCA; length = Flength (maps); - len = XINT (length); + len = XFIXNUM (length); /* Convert the list MAPS into a vector MAPVEC. */ SAFE_ALLOCA_LISP (mapvec, len); @@ -647,7 +647,7 @@ digest_single_submenu (int start, int end, bool top_level_items) i = start; while (i < end) { - if (EQ (AREF (menu_items, i), Qnil)) + if (NILP (AREF (menu_items, i))) { submenu_stack[submenu_depth++] = save_wv; save_wv = prev_wv; @@ -900,7 +900,7 @@ find_and_call_menu_selection (struct frame *f, int menu_bar_items_used, while (i < menu_bar_items_used) { - if (EQ (AREF (vector, i), Qnil)) + if (NILP (AREF (vector, i))) { subprefix_stack[submenu_depth++] = prefix; prefix = entry; @@ -985,7 +985,7 @@ find_and_return_menu_selection (struct frame *f, bool keymaps, void *client_data while (i < menu_items_used) { - if (EQ (AREF (menu_items, i), Qnil)) + if (NILP (AREF (menu_items, i))) { subprefix_stack[submenu_depth++] = prefix; prefix = entry; @@ -1079,7 +1079,7 @@ into menu items. */) if (!FRAME_LIVE_P (f)) return Qnil; - pixel_to_glyph_coords (f, XINT (x), XINT (y), &col, &row, NULL, 1); + pixel_to_glyph_coords (f, XFIXNUM (x), XFIXNUM (y), &col, &row, NULL, 1); if (0 <= row && row < FRAME_MENU_BAR_LINES (f)) { Lisp_Object items, item; @@ -1099,10 +1099,10 @@ into menu items. */) pos = AREF (items, i + 3); if (NILP (str)) return item; - if (XINT (pos) <= col + if (XFIXNUM (pos) <= col /* We use <= so the blank between 2 items on a TTY is considered part of the previous item. */ - && col <= XINT (pos) + menu_item_width (SDATA (str))) + && col <= XFIXNUM (pos) + menu_item_width (SDATA (str))) { item = AREF (items, i); return item; @@ -1112,51 +1112,8 @@ into menu items. */) return Qnil; } - -DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0, - doc: /* Pop up a deck-of-cards menu and return user's selection. -POSITION is a position specification. This is either a mouse button event -or a list ((XOFFSET YOFFSET) WINDOW) -where XOFFSET and YOFFSET are positions in pixels from the top left -corner of WINDOW. (WINDOW may be a window or a frame object.) -This controls the position of the top left of the menu as a whole. -If POSITION is t, it means to use the current mouse position. - -MENU is a specifier for a menu. For the simplest case, MENU is a keymap. -The menu items come from key bindings that have a menu string as well as -a definition; actually, the "definition" in such a key binding looks like -\(STRING . REAL-DEFINITION). To give the menu a title, put a string into -the keymap as a top-level element. - -If REAL-DEFINITION is nil, that puts a nonselectable string in the menu. -Otherwise, REAL-DEFINITION should be a valid key binding definition. - -You can also use a list of keymaps as MENU. - Then each keymap makes a separate pane. - -When MENU is a keymap or a list of keymaps, the return value is the -list of events corresponding to the user's choice. Note that -`x-popup-menu' does not actually execute the command bound to that -sequence of events. - -Alternatively, you can specify a menu of multiple panes - with a list of the form (TITLE PANE1 PANE2...), -where each pane is a list of form (TITLE ITEM1 ITEM2...). -Each ITEM is normally a cons cell (STRING . VALUE); -but a string can appear as an item--that makes a nonselectable line -in the menu. -With this form of menu, the return value is VALUE from the chosen item. - -If POSITION is nil, don't display the menu at all, just precalculate the -cached information about equivalent key sequences. - -If the user gets rid of the menu without making a valid choice, for -instance by clicking the mouse away from a valid choice or by typing -keyboard input, then this normally results in a quit and -`x-popup-menu' does not return. But if POSITION is a mouse button -event (indicating that the user invoked the menu with the mouse) then -no quit occurs and `x-popup-menu' returns nil. */) - (Lisp_Object position, Lisp_Object menu) +Lisp_Object +x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) { Lisp_Object keymap, tem, tem2; int xpos = 0, ypos = 0; @@ -1195,7 +1152,7 @@ no quit occurs and `x-popup-menu' returns nil. */) else { menuflags |= MENU_FOR_CLICK; - tem = Fcar (Fcdr (position)); /* EVENT_START (position) */ + tem = Fcar (XCDR (position)); /* EVENT_START (position) */ window = Fcar (tem); /* POSN_WINDOW (tem) */ tem2 = Fcar (Fcdr (tem)); /* POSN_POSN (tem) */ /* The MENU_KBD_NAVIGATION field is set when the menu @@ -1211,7 +1168,7 @@ no quit occurs and `x-popup-menu' returns nil. */) event. */ if (!EQ (POSN_POSN (last_nonmenu_event), POSN_POSN (position)) - && CONSP (tem2) && EQ (Fcar (tem2), Qmenu_bar)) + && CONSP (tem2) && EQ (XCAR (tem2), Qmenu_bar)) menuflags |= MENU_KBD_NAVIGATION; tem = Fcar (Fcdr (Fcdr (tem))); /* POSN_WINDOW_POSN (tem) */ x = Fcar (tem); @@ -1245,9 +1202,9 @@ no quit occurs and `x-popup-menu' returns nil. */) int cur_x, cur_y; x_relative_mouse_position (new_f, &cur_x, &cur_y); - /* cur_x/y may be negative, so use make_number. */ - x = make_number (cur_x); - y = make_number (cur_y); + /* cur_x/y may be negative, so use make_fixnum. */ + x = make_fixnum (cur_x); + y = make_fixnum (cur_y); } } else @@ -1311,8 +1268,8 @@ no quit occurs and `x-popup-menu' returns nil. */) ? (EMACS_INT) INT_MIN - ypos : MOST_NEGATIVE_FIXNUM), INT_MAX - ypos); - xpos += XINT (x); - ypos += XINT (y); + xpos += XFIXNUM (x); + ypos += XFIXNUM (y); XSETFRAME (Vmenu_updating_frame, f); } @@ -1352,7 +1309,7 @@ no quit occurs and `x-popup-menu' returns nil. */) else if (CONSP (menu) && KEYMAPP (XCAR (menu))) { /* We were given a list of keymaps. */ - EMACS_INT nmaps = XFASTINT (Flength (menu)); + EMACS_INT nmaps = XFIXNAT (Flength (menu)); Lisp_Object *maps; ptrdiff_t i; USE_SAFE_ALLOCA; @@ -1443,6 +1400,55 @@ no quit occurs and `x-popup-menu' returns nil. */) return selection; } +DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0, + doc: /* Pop up a deck-of-cards menu and return user's selection. +POSITION is a position specification. This is either a mouse button event +or a list ((XOFFSET YOFFSET) WINDOW) +where XOFFSET and YOFFSET are positions in pixels from the top left +corner of WINDOW. (WINDOW may be a window or a frame object.) +This controls the position of the top left of the menu as a whole. +If POSITION is t, it means to use the current mouse position. + +MENU is a specifier for a menu. For the simplest case, MENU is a keymap. +The menu items come from key bindings that have a menu string as well as +a definition; actually, the "definition" in such a key binding looks like +\(STRING . REAL-DEFINITION). To give the menu a title, put a string into +the keymap as a top-level element. + +If REAL-DEFINITION is nil, that puts a nonselectable string in the menu. +Otherwise, REAL-DEFINITION should be a valid key binding definition. + +You can also use a list of keymaps as MENU. + Then each keymap makes a separate pane. + +When MENU is a keymap or a list of keymaps, the return value is the +list of events corresponding to the user's choice. Note that +`x-popup-menu' does not actually execute the command bound to that +sequence of events. + +Alternatively, you can specify a menu of multiple panes + with a list of the form (TITLE PANE1 PANE2...), +where each pane is a list of form (TITLE ITEM1 ITEM2...). +Each ITEM is normally a cons cell (STRING . VALUE); +but a string can appear as an item--that makes a nonselectable line +in the menu. +With this form of menu, the return value is VALUE from the chosen item. + +If POSITION is nil, don't display the menu at all, just precalculate the +cached information about equivalent key sequences. + +If the user gets rid of the menu without making a valid choice, for +instance by clicking the mouse away from a valid choice or by typing +keyboard input, then this normally results in a quit and +`x-popup-menu' does not return. But if POSITION is a mouse button +event (indicating that the user invoked the menu with the mouse) then +no quit occurs and `x-popup-menu' returns nil. */) + (Lisp_Object position, Lisp_Object menu) +{ + init_raw_keybuf_count (); + return x_popup_menu_1 (position, menu); +} + /* If F's terminal is not capable of displaying a popup dialog, emulate it with a menu. */ diff --git a/src/menu.h b/src/menu.h index 3b39de2d6e0..d425cdf0109 100644 --- a/src/menu.h +++ b/src/menu.h @@ -60,4 +60,5 @@ extern Lisp_Object ns_menu_show (struct frame *, int, int, int, extern Lisp_Object tty_menu_show (struct frame *, int, int, int, Lisp_Object, const char **); extern ptrdiff_t menu_item_width (const unsigned char *); +extern Lisp_Object x_popup_menu_1 (Lisp_Object position, Lisp_Object menu); #endif /* MENU_H */ diff --git a/src/mini-gmp-emacs.c b/src/mini-gmp-emacs.c new file mode 100644 index 00000000000..7a1b7ab5de5 --- /dev/null +++ b/src/mini-gmp-emacs.c @@ -0,0 +1,32 @@ +/* Tailor mini-gmp.c for GNU Emacs + +Copyright 2018 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <stddef.h> + +/* Pacify GCC -Wsuggest-attribute=malloc. */ +static void *gmp_default_alloc (size_t) ATTRIBUTE_MALLOC; + +/* Pacify GCC -Wunused-variable for variables used only in 'assert' calls. */ +#if defined NDEBUG && GNUC_PREREQ (4, 6, 0) +# pragma GCC diagnostic ignored "-Wunused-variable" +#endif + +#include "mini-gmp.c" diff --git a/src/mini-gmp.c b/src/mini-gmp.c new file mode 100644 index 00000000000..c0d5b879a83 --- /dev/null +++ b/src/mini-gmp.c @@ -0,0 +1,4452 @@ +/* mini-gmp, a minimalistic implementation of a GNU GMP subset. + + Contributed to the GNU project by Niels Möller + +Copyright 1991-1997, 1999-2018 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of either: + + * the GNU Lesser General Public License as published by the Free + Software Foundation; either version 3 of the License, or (at your + option) any later version. + +or + + * the GNU General Public License as published by the Free Software + Foundation; either version 2 of the License, or (at your option) any + later version. + +or both in parallel, as here. + +The GNU MP Library 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 copies of the GNU General Public License and the +GNU Lesser General Public License along with the GNU MP Library. If not, +see https://www.gnu.org/licenses/. */ + +/* NOTE: All functions in this file which are not declared in + mini-gmp.h are internal, and are not intended to be compatible + neither with GMP nor with future versions of mini-gmp. */ + +/* Much of the material copied from GMP files, including: gmp-impl.h, + longlong.h, mpn/generic/add_n.c, mpn/generic/addmul_1.c, + mpn/generic/lshift.c, mpn/generic/mul_1.c, + mpn/generic/mul_basecase.c, mpn/generic/rshift.c, + mpn/generic/sbpi1_div_qr.c, mpn/generic/sub_n.c, + mpn/generic/submul_1.c. */ + +#include <assert.h> +#include <ctype.h> +#include <limits.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include "mini-gmp.h" + +#if !defined(MINI_GMP_DONT_USE_FLOAT_H) +#include <float.h> +#endif + + +/* Macros */ +#define GMP_LIMB_BITS (sizeof(mp_limb_t) * CHAR_BIT) + +#define GMP_LIMB_MAX (~ (mp_limb_t) 0) +#define GMP_LIMB_HIGHBIT ((mp_limb_t) 1 << (GMP_LIMB_BITS - 1)) + +#define GMP_HLIMB_BIT ((mp_limb_t) 1 << (GMP_LIMB_BITS / 2)) +#define GMP_LLIMB_MASK (GMP_HLIMB_BIT - 1) + +#define GMP_ULONG_BITS (sizeof(unsigned long) * CHAR_BIT) +#define GMP_ULONG_HIGHBIT ((unsigned long) 1 << (GMP_ULONG_BITS - 1)) + +#define GMP_ABS(x) ((x) >= 0 ? (x) : -(x)) +#define GMP_NEG_CAST(T,x) (-((T)((x) + 1) - 1)) + +#define GMP_MIN(a, b) ((a) < (b) ? (a) : (b)) +#define GMP_MAX(a, b) ((a) > (b) ? (a) : (b)) + +#define GMP_CMP(a,b) (((a) > (b)) - ((a) < (b))) + +#if defined(DBL_MANT_DIG) && FLT_RADIX == 2 +#define GMP_DBL_MANT_BITS DBL_MANT_DIG +#else +#define GMP_DBL_MANT_BITS (53) +#endif + +/* Return non-zero if xp,xsize and yp,ysize overlap. + If xp+xsize<=yp there's no overlap, or if yp+ysize<=xp there's no + overlap. If both these are false, there's an overlap. */ +#define GMP_MPN_OVERLAP_P(xp, xsize, yp, ysize) \ + ((xp) + (xsize) > (yp) && (yp) + (ysize) > (xp)) + +#define gmp_assert_nocarry(x) do { \ + mp_limb_t __cy = (x); \ + assert (__cy == 0); \ + } while (0) + +#define gmp_clz(count, x) do { \ + mp_limb_t __clz_x = (x); \ + unsigned __clz_c; \ + for (__clz_c = 0; \ + (__clz_x & ((mp_limb_t) 0xff << (GMP_LIMB_BITS - 8))) == 0; \ + __clz_c += 8) \ + __clz_x <<= 8; \ + for (; (__clz_x & GMP_LIMB_HIGHBIT) == 0; __clz_c++) \ + __clz_x <<= 1; \ + (count) = __clz_c; \ + } while (0) + +#define gmp_ctz(count, x) do { \ + mp_limb_t __ctz_x = (x); \ + unsigned __ctz_c = 0; \ + gmp_clz (__ctz_c, __ctz_x & - __ctz_x); \ + (count) = GMP_LIMB_BITS - 1 - __ctz_c; \ + } while (0) + +#define gmp_add_ssaaaa(sh, sl, ah, al, bh, bl) \ + do { \ + mp_limb_t __x; \ + __x = (al) + (bl); \ + (sh) = (ah) + (bh) + (__x < (al)); \ + (sl) = __x; \ + } while (0) + +#define gmp_sub_ddmmss(sh, sl, ah, al, bh, bl) \ + do { \ + mp_limb_t __x; \ + __x = (al) - (bl); \ + (sh) = (ah) - (bh) - ((al) < (bl)); \ + (sl) = __x; \ + } while (0) + +#define gmp_umul_ppmm(w1, w0, u, v) \ + do { \ + mp_limb_t __x0, __x1, __x2, __x3; \ + unsigned __ul, __vl, __uh, __vh; \ + mp_limb_t __u = (u), __v = (v); \ + \ + __ul = __u & GMP_LLIMB_MASK; \ + __uh = __u >> (GMP_LIMB_BITS / 2); \ + __vl = __v & GMP_LLIMB_MASK; \ + __vh = __v >> (GMP_LIMB_BITS / 2); \ + \ + __x0 = (mp_limb_t) __ul * __vl; \ + __x1 = (mp_limb_t) __ul * __vh; \ + __x2 = (mp_limb_t) __uh * __vl; \ + __x3 = (mp_limb_t) __uh * __vh; \ + \ + __x1 += __x0 >> (GMP_LIMB_BITS / 2);/* this can't give carry */ \ + __x1 += __x2; /* but this indeed can */ \ + if (__x1 < __x2) /* did we get it? */ \ + __x3 += GMP_HLIMB_BIT; /* yes, add it in the proper pos. */ \ + \ + (w1) = __x3 + (__x1 >> (GMP_LIMB_BITS / 2)); \ + (w0) = (__x1 << (GMP_LIMB_BITS / 2)) + (__x0 & GMP_LLIMB_MASK); \ + } while (0) + +#define gmp_udiv_qrnnd_preinv(q, r, nh, nl, d, di) \ + do { \ + mp_limb_t _qh, _ql, _r, _mask; \ + gmp_umul_ppmm (_qh, _ql, (nh), (di)); \ + gmp_add_ssaaaa (_qh, _ql, _qh, _ql, (nh) + 1, (nl)); \ + _r = (nl) - _qh * (d); \ + _mask = -(mp_limb_t) (_r > _ql); /* both > and >= are OK */ \ + _qh += _mask; \ + _r += _mask & (d); \ + if (_r >= (d)) \ + { \ + _r -= (d); \ + _qh++; \ + } \ + \ + (r) = _r; \ + (q) = _qh; \ + } while (0) + +#define gmp_udiv_qr_3by2(q, r1, r0, n2, n1, n0, d1, d0, dinv) \ + do { \ + mp_limb_t _q0, _t1, _t0, _mask; \ + gmp_umul_ppmm ((q), _q0, (n2), (dinv)); \ + gmp_add_ssaaaa ((q), _q0, (q), _q0, (n2), (n1)); \ + \ + /* Compute the two most significant limbs of n - q'd */ \ + (r1) = (n1) - (d1) * (q); \ + gmp_sub_ddmmss ((r1), (r0), (r1), (n0), (d1), (d0)); \ + gmp_umul_ppmm (_t1, _t0, (d0), (q)); \ + gmp_sub_ddmmss ((r1), (r0), (r1), (r0), _t1, _t0); \ + (q)++; \ + \ + /* Conditionally adjust q and the remainders */ \ + _mask = - (mp_limb_t) ((r1) >= _q0); \ + (q) += _mask; \ + gmp_add_ssaaaa ((r1), (r0), (r1), (r0), _mask & (d1), _mask & (d0)); \ + if ((r1) >= (d1)) \ + { \ + if ((r1) > (d1) || (r0) >= (d0)) \ + { \ + (q)++; \ + gmp_sub_ddmmss ((r1), (r0), (r1), (r0), (d1), (d0)); \ + } \ + } \ + } while (0) + +/* Swap macros. */ +#define MP_LIMB_T_SWAP(x, y) \ + do { \ + mp_limb_t __mp_limb_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_limb_t_swap__tmp; \ + } while (0) +#define MP_SIZE_T_SWAP(x, y) \ + do { \ + mp_size_t __mp_size_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_size_t_swap__tmp; \ + } while (0) +#define MP_BITCNT_T_SWAP(x,y) \ + do { \ + mp_bitcnt_t __mp_bitcnt_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_bitcnt_t_swap__tmp; \ + } while (0) +#define MP_PTR_SWAP(x, y) \ + do { \ + mp_ptr __mp_ptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_ptr_swap__tmp; \ + } while (0) +#define MP_SRCPTR_SWAP(x, y) \ + do { \ + mp_srcptr __mp_srcptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_srcptr_swap__tmp; \ + } while (0) + +#define MPN_PTR_SWAP(xp,xs, yp,ys) \ + do { \ + MP_PTR_SWAP (xp, yp); \ + MP_SIZE_T_SWAP (xs, ys); \ + } while(0) +#define MPN_SRCPTR_SWAP(xp,xs, yp,ys) \ + do { \ + MP_SRCPTR_SWAP (xp, yp); \ + MP_SIZE_T_SWAP (xs, ys); \ + } while(0) + +#define MPZ_PTR_SWAP(x, y) \ + do { \ + mpz_ptr __mpz_ptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mpz_ptr_swap__tmp; \ + } while (0) +#define MPZ_SRCPTR_SWAP(x, y) \ + do { \ + mpz_srcptr __mpz_srcptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mpz_srcptr_swap__tmp; \ + } while (0) + +const int mp_bits_per_limb = GMP_LIMB_BITS; + + +/* Memory allocation and other helper functions. */ +static void +gmp_die (const char *msg) +{ + fprintf (stderr, "%s\n", msg); + abort(); +} + +static void * +gmp_default_alloc (size_t size) +{ + void *p; + + assert (size > 0); + + p = malloc (size); + if (!p) + gmp_die("gmp_default_alloc: Virtual memory exhausted."); + + return p; +} + +static void * +gmp_default_realloc (void *old, size_t old_size, size_t new_size) +{ + void * p; + + p = realloc (old, new_size); + + if (!p) + gmp_die("gmp_default_realloc: Virtual memory exhausted."); + + return p; +} + +static void +gmp_default_free (void *p, size_t size) +{ + free (p); +} + +static void * (*gmp_allocate_func) (size_t) = gmp_default_alloc; +static void * (*gmp_reallocate_func) (void *, size_t, size_t) = gmp_default_realloc; +static void (*gmp_free_func) (void *, size_t) = gmp_default_free; + +void +mp_get_memory_functions (void *(**alloc_func) (size_t), + void *(**realloc_func) (void *, size_t, size_t), + void (**free_func) (void *, size_t)) +{ + if (alloc_func) + *alloc_func = gmp_allocate_func; + + if (realloc_func) + *realloc_func = gmp_reallocate_func; + + if (free_func) + *free_func = gmp_free_func; +} + +void +mp_set_memory_functions (void *(*alloc_func) (size_t), + void *(*realloc_func) (void *, size_t, size_t), + void (*free_func) (void *, size_t)) +{ + if (!alloc_func) + alloc_func = gmp_default_alloc; + if (!realloc_func) + realloc_func = gmp_default_realloc; + if (!free_func) + free_func = gmp_default_free; + + gmp_allocate_func = alloc_func; + gmp_reallocate_func = realloc_func; + gmp_free_func = free_func; +} + +#define gmp_xalloc(size) ((*gmp_allocate_func)((size))) +#define gmp_free(p) ((*gmp_free_func) ((p), 0)) + +static mp_ptr +gmp_xalloc_limbs (mp_size_t size) +{ + return (mp_ptr) gmp_xalloc (size * sizeof (mp_limb_t)); +} + +static mp_ptr +gmp_xrealloc_limbs (mp_ptr old, mp_size_t size) +{ + assert (size > 0); + return (mp_ptr) (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t)); +} + + +/* MPN interface */ + +void +mpn_copyi (mp_ptr d, mp_srcptr s, mp_size_t n) +{ + mp_size_t i; + for (i = 0; i < n; i++) + d[i] = s[i]; +} + +void +mpn_copyd (mp_ptr d, mp_srcptr s, mp_size_t n) +{ + while (--n >= 0) + d[n] = s[n]; +} + +int +mpn_cmp (mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + while (--n >= 0) + { + if (ap[n] != bp[n]) + return ap[n] > bp[n] ? 1 : -1; + } + return 0; +} + +static int +mpn_cmp4 (mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + if (an != bn) + return an < bn ? -1 : 1; + else + return mpn_cmp (ap, bp, an); +} + +static mp_size_t +mpn_normalized_size (mp_srcptr xp, mp_size_t n) +{ + while (n > 0 && xp[n-1] == 0) + --n; + return n; +} + +int +mpn_zero_p(mp_srcptr rp, mp_size_t n) +{ + return mpn_normalized_size (rp, n) == 0; +} + +void +mpn_zero (mp_ptr rp, mp_size_t n) +{ + while (--n >= 0) + rp[n] = 0; +} + +mp_limb_t +mpn_add_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) +{ + mp_size_t i; + + assert (n > 0); + i = 0; + do + { + mp_limb_t r = ap[i] + b; + /* Carry out */ + b = (r < b); + rp[i] = r; + } + while (++i < n); + + return b; +} + +mp_limb_t +mpn_add_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mp_size_t i; + mp_limb_t cy; + + for (i = 0, cy = 0; i < n; i++) + { + mp_limb_t a, b, r; + a = ap[i]; b = bp[i]; + r = a + cy; + cy = (r < cy); + r += b; + cy += (r < b); + rp[i] = r; + } + return cy; +} + +mp_limb_t +mpn_add (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + mp_limb_t cy; + + assert (an >= bn); + + cy = mpn_add_n (rp, ap, bp, bn); + if (an > bn) + cy = mpn_add_1 (rp + bn, ap + bn, an - bn, cy); + return cy; +} + +mp_limb_t +mpn_sub_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) +{ + mp_size_t i; + + assert (n > 0); + + i = 0; + do + { + mp_limb_t a = ap[i]; + /* Carry out */ + mp_limb_t cy = a < b; + rp[i] = a - b; + b = cy; + } + while (++i < n); + + return b; +} + +mp_limb_t +mpn_sub_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mp_size_t i; + mp_limb_t cy; + + for (i = 0, cy = 0; i < n; i++) + { + mp_limb_t a, b; + a = ap[i]; b = bp[i]; + b += cy; + cy = (b < cy); + cy += (a < b); + rp[i] = a - b; + } + return cy; +} + +mp_limb_t +mpn_sub (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + mp_limb_t cy; + + assert (an >= bn); + + cy = mpn_sub_n (rp, ap, bp, bn); + if (an > bn) + cy = mpn_sub_1 (rp + bn, ap + bn, an - bn, cy); + return cy; +} + +mp_limb_t +mpn_mul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_addmul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl, rl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + rl = *rp; + lpl = rl + lpl; + cl += lpl < rl; + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_submul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl, rl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + rl = *rp; + lpl = rl - lpl; + cl += lpl > rl; + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_mul (mp_ptr rp, mp_srcptr up, mp_size_t un, mp_srcptr vp, mp_size_t vn) +{ + assert (un >= vn); + assert (vn >= 1); + assert (!GMP_MPN_OVERLAP_P(rp, un + vn, up, un)); + assert (!GMP_MPN_OVERLAP_P(rp, un + vn, vp, vn)); + + /* We first multiply by the low order limb. This result can be + stored, not added, to rp. We also avoid a loop for zeroing this + way. */ + + rp[un] = mpn_mul_1 (rp, up, un, vp[0]); + + /* Now accumulate the product of up[] and the next higher limb from + vp[]. */ + + while (--vn >= 1) + { + rp += 1, vp += 1; + rp[un] = mpn_addmul_1 (rp, up, un, vp[0]); + } + return rp[un]; +} + +void +mpn_mul_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mpn_mul (rp, ap, n, bp, n); +} + +void +mpn_sqr (mp_ptr rp, mp_srcptr ap, mp_size_t n) +{ + mpn_mul (rp, ap, n, ap, n); +} + +mp_limb_t +mpn_lshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) +{ + mp_limb_t high_limb, low_limb; + unsigned int tnc; + mp_limb_t retval; + + assert (n >= 1); + assert (cnt >= 1); + assert (cnt < GMP_LIMB_BITS); + + up += n; + rp += n; + + tnc = GMP_LIMB_BITS - cnt; + low_limb = *--up; + retval = low_limb >> tnc; + high_limb = (low_limb << cnt); + + while (--n != 0) + { + low_limb = *--up; + *--rp = high_limb | (low_limb >> tnc); + high_limb = (low_limb << cnt); + } + *--rp = high_limb; + + return retval; +} + +mp_limb_t +mpn_rshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) +{ + mp_limb_t high_limb, low_limb; + unsigned int tnc; + mp_limb_t retval; + + assert (n >= 1); + assert (cnt >= 1); + assert (cnt < GMP_LIMB_BITS); + + tnc = GMP_LIMB_BITS - cnt; + high_limb = *up++; + retval = (high_limb << tnc); + low_limb = high_limb >> cnt; + + while (--n != 0) + { + high_limb = *up++; + *rp++ = low_limb | (high_limb << tnc); + low_limb = high_limb >> cnt; + } + *rp = low_limb; + + return retval; +} + +static mp_bitcnt_t +mpn_common_scan (mp_limb_t limb, mp_size_t i, mp_srcptr up, mp_size_t un, + mp_limb_t ux) +{ + unsigned cnt; + + assert (ux == 0 || ux == GMP_LIMB_MAX); + assert (0 <= i && i <= un ); + + while (limb == 0) + { + i++; + if (i == un) + return (ux == 0 ? ~(mp_bitcnt_t) 0 : un * GMP_LIMB_BITS); + limb = ux ^ up[i]; + } + gmp_ctz (cnt, limb); + return (mp_bitcnt_t) i * GMP_LIMB_BITS + cnt; +} + +mp_bitcnt_t +mpn_scan1 (mp_srcptr ptr, mp_bitcnt_t bit) +{ + mp_size_t i; + i = bit / GMP_LIMB_BITS; + + return mpn_common_scan ( ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), + i, ptr, i, 0); +} + +mp_bitcnt_t +mpn_scan0 (mp_srcptr ptr, mp_bitcnt_t bit) +{ + mp_size_t i; + i = bit / GMP_LIMB_BITS; + + return mpn_common_scan (~ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), + i, ptr, i, GMP_LIMB_MAX); +} + +void +mpn_com (mp_ptr rp, mp_srcptr up, mp_size_t n) +{ + while (--n >= 0) + *rp++ = ~ *up++; +} + +mp_limb_t +mpn_neg (mp_ptr rp, mp_srcptr up, mp_size_t n) +{ + while (*up == 0) + { + *rp = 0; + if (!--n) + return 0; + ++up; ++rp; + } + *rp = - *up; + mpn_com (++rp, ++up, --n); + return 1; +} + + +/* MPN division interface. */ + +/* The 3/2 inverse is defined as + + m = floor( (B^3-1) / (B u1 + u0)) - B +*/ +mp_limb_t +mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0) +{ + mp_limb_t r, p, m, ql; + unsigned ul, uh, qh; + + assert (u1 >= GMP_LIMB_HIGHBIT); + + /* For notation, let b denote the half-limb base, so that B = b^2. + Split u1 = b uh + ul. */ + ul = u1 & GMP_LLIMB_MASK; + uh = u1 >> (GMP_LIMB_BITS / 2); + + /* Approximation of the high half of quotient. Differs from the 2/1 + inverse of the half limb uh, since we have already subtracted + u0. */ + qh = ~u1 / uh; + + /* Adjust to get a half-limb 3/2 inverse, i.e., we want + + qh' = floor( (b^3 - 1) / u) - b = floor ((b^3 - b u - 1) / u + = floor( (b (~u) + b-1) / u), + + and the remainder + + r = b (~u) + b-1 - qh (b uh + ul) + = b (~u - qh uh) + b-1 - qh ul + + Subtraction of qh ul may underflow, which implies adjustments. + But by normalization, 2 u >= B > qh ul, so we need to adjust by + at most 2. + */ + + r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK; + + p = (mp_limb_t) qh * ul; + /* Adjustment steps taken from udiv_qrnnd_c */ + if (r < p) + { + qh--; + r += u1; + if (r >= u1) /* i.e. we didn't get carry when adding to r */ + if (r < p) + { + qh--; + r += u1; + } + } + r -= p; + + /* Low half of the quotient is + + ql = floor ( (b r + b-1) / u1). + + This is a 3/2 division (on half-limbs), for which qh is a + suitable inverse. */ + + p = (r >> (GMP_LIMB_BITS / 2)) * qh + r; + /* Unlike full-limb 3/2, we can add 1 without overflow. For this to + work, it is essential that ql is a full mp_limb_t. */ + ql = (p >> (GMP_LIMB_BITS / 2)) + 1; + + /* By the 3/2 trick, we don't need the high half limb. */ + r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1; + + if (r >= (p << (GMP_LIMB_BITS / 2))) + { + ql--; + r += u1; + } + m = ((mp_limb_t) qh << (GMP_LIMB_BITS / 2)) + ql; + if (r >= u1) + { + m++; + r -= u1; + } + + /* Now m is the 2/1 invers of u1. If u0 > 0, adjust it to become a + 3/2 inverse. */ + if (u0 > 0) + { + mp_limb_t th, tl; + r = ~r; + r += u0; + if (r < u0) + { + m--; + if (r >= u1) + { + m--; + r -= u1; + } + r -= u1; + } + gmp_umul_ppmm (th, tl, u0, m); + r += th; + if (r < th) + { + m--; + m -= ((r > u1) | ((r == u1) & (tl > u0))); + } + } + + return m; +} + +struct gmp_div_inverse +{ + /* Normalization shift count. */ + unsigned shift; + /* Normalized divisor (d0 unused for mpn_div_qr_1) */ + mp_limb_t d1, d0; + /* Inverse, for 2/1 or 3/2. */ + mp_limb_t di; +}; + +static void +mpn_div_qr_1_invert (struct gmp_div_inverse *inv, mp_limb_t d) +{ + unsigned shift; + + assert (d > 0); + gmp_clz (shift, d); + inv->shift = shift; + inv->d1 = d << shift; + inv->di = mpn_invert_limb (inv->d1); +} + +static void +mpn_div_qr_2_invert (struct gmp_div_inverse *inv, + mp_limb_t d1, mp_limb_t d0) +{ + unsigned shift; + + assert (d1 > 0); + gmp_clz (shift, d1); + inv->shift = shift; + if (shift > 0) + { + d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); + d0 <<= shift; + } + inv->d1 = d1; + inv->d0 = d0; + inv->di = mpn_invert_3by2 (d1, d0); +} + +static void +mpn_div_qr_invert (struct gmp_div_inverse *inv, + mp_srcptr dp, mp_size_t dn) +{ + assert (dn > 0); + + if (dn == 1) + mpn_div_qr_1_invert (inv, dp[0]); + else if (dn == 2) + mpn_div_qr_2_invert (inv, dp[1], dp[0]); + else + { + unsigned shift; + mp_limb_t d1, d0; + + d1 = dp[dn-1]; + d0 = dp[dn-2]; + assert (d1 > 0); + gmp_clz (shift, d1); + inv->shift = shift; + if (shift > 0) + { + d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); + d0 = (d0 << shift) | (dp[dn-3] >> (GMP_LIMB_BITS - shift)); + } + inv->d1 = d1; + inv->d0 = d0; + inv->di = mpn_invert_3by2 (d1, d0); + } +} + +/* Not matching current public gmp interface, rather corresponding to + the sbpi1_div_* functions. */ +static mp_limb_t +mpn_div_qr_1_preinv (mp_ptr qp, mp_srcptr np, mp_size_t nn, + const struct gmp_div_inverse *inv) +{ + mp_limb_t d, di; + mp_limb_t r; + mp_ptr tp = NULL; + + if (inv->shift > 0) + { + /* Shift, reusing qp area if possible. In-place shift if qp == np. */ + tp = qp ? qp : gmp_xalloc_limbs (nn); + r = mpn_lshift (tp, np, nn, inv->shift); + np = tp; + } + else + r = 0; + + d = inv->d1; + di = inv->di; + while (--nn >= 0) + { + mp_limb_t q; + + gmp_udiv_qrnnd_preinv (q, r, r, np[nn], d, di); + if (qp) + qp[nn] = q; + } + if ((inv->shift > 0) && (tp != qp)) + gmp_free (tp); + + return r >> inv->shift; +} + +static mp_limb_t +mpn_div_qr_1 (mp_ptr qp, mp_srcptr np, mp_size_t nn, mp_limb_t d) +{ + assert (d > 0); + + /* Special case for powers of two. */ + if ((d & (d-1)) == 0) + { + mp_limb_t r = np[0] & (d-1); + if (qp) + { + if (d <= 1) + mpn_copyi (qp, np, nn); + else + { + unsigned shift; + gmp_ctz (shift, d); + mpn_rshift (qp, np, nn, shift); + } + } + return r; + } + else + { + struct gmp_div_inverse inv; + mpn_div_qr_1_invert (&inv, d); + return mpn_div_qr_1_preinv (qp, np, nn, &inv); + } +} + +static void +mpn_div_qr_2_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn, + const struct gmp_div_inverse *inv) +{ + unsigned shift; + mp_size_t i; + mp_limb_t d1, d0, di, r1, r0; + + assert (nn >= 2); + shift = inv->shift; + d1 = inv->d1; + d0 = inv->d0; + di = inv->di; + + if (shift > 0) + r1 = mpn_lshift (np, np, nn, shift); + else + r1 = 0; + + r0 = np[nn - 1]; + + i = nn - 2; + do + { + mp_limb_t n0, q; + n0 = np[i]; + gmp_udiv_qr_3by2 (q, r1, r0, r1, r0, n0, d1, d0, di); + + if (qp) + qp[i] = q; + } + while (--i >= 0); + + if (shift > 0) + { + assert ((r0 << (GMP_LIMB_BITS - shift)) == 0); + r0 = (r0 >> shift) | (r1 << (GMP_LIMB_BITS - shift)); + r1 >>= shift; + } + + np[1] = r1; + np[0] = r0; +} + +static void +mpn_div_qr_pi1 (mp_ptr qp, + mp_ptr np, mp_size_t nn, mp_limb_t n1, + mp_srcptr dp, mp_size_t dn, + mp_limb_t dinv) +{ + mp_size_t i; + + mp_limb_t d1, d0; + mp_limb_t cy, cy1; + mp_limb_t q; + + assert (dn > 2); + assert (nn >= dn); + + d1 = dp[dn - 1]; + d0 = dp[dn - 2]; + + assert ((d1 & GMP_LIMB_HIGHBIT) != 0); + /* Iteration variable is the index of the q limb. + * + * We divide <n1, np[dn-1+i], np[dn-2+i], np[dn-3+i],..., np[i]> + * by <d1, d0, dp[dn-3], ..., dp[0] > + */ + + i = nn - dn; + do + { + mp_limb_t n0 = np[dn-1+i]; + + if (n1 == d1 && n0 == d0) + { + q = GMP_LIMB_MAX; + mpn_submul_1 (np+i, dp, dn, q); + n1 = np[dn-1+i]; /* update n1, last loop's value will now be invalid */ + } + else + { + gmp_udiv_qr_3by2 (q, n1, n0, n1, n0, np[dn-2+i], d1, d0, dinv); + + cy = mpn_submul_1 (np + i, dp, dn-2, q); + + cy1 = n0 < cy; + n0 = n0 - cy; + cy = n1 < cy1; + n1 = n1 - cy1; + np[dn-2+i] = n0; + + if (cy != 0) + { + n1 += d1 + mpn_add_n (np + i, np + i, dp, dn - 1); + q--; + } + } + + if (qp) + qp[i] = q; + } + while (--i >= 0); + + np[dn - 1] = n1; +} + +static void +mpn_div_qr_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn, + mp_srcptr dp, mp_size_t dn, + const struct gmp_div_inverse *inv) +{ + assert (dn > 0); + assert (nn >= dn); + + if (dn == 1) + np[0] = mpn_div_qr_1_preinv (qp, np, nn, inv); + else if (dn == 2) + mpn_div_qr_2_preinv (qp, np, nn, inv); + else + { + mp_limb_t nh; + unsigned shift; + + assert (inv->d1 == dp[dn-1]); + assert (inv->d0 == dp[dn-2]); + assert ((inv->d1 & GMP_LIMB_HIGHBIT) != 0); + + shift = inv->shift; + if (shift > 0) + nh = mpn_lshift (np, np, nn, shift); + else + nh = 0; + + mpn_div_qr_pi1 (qp, np, nn, nh, dp, dn, inv->di); + + if (shift > 0) + gmp_assert_nocarry (mpn_rshift (np, np, dn, shift)); + } +} + +static void +mpn_div_qr (mp_ptr qp, mp_ptr np, mp_size_t nn, mp_srcptr dp, mp_size_t dn) +{ + struct gmp_div_inverse inv; + mp_ptr tp = NULL; + + assert (dn > 0); + assert (nn >= dn); + + mpn_div_qr_invert (&inv, dp, dn); + if (dn > 2 && inv.shift > 0) + { + tp = gmp_xalloc_limbs (dn); + gmp_assert_nocarry (mpn_lshift (tp, dp, dn, inv.shift)); + dp = tp; + } + mpn_div_qr_preinv (qp, np, nn, dp, dn, &inv); + if (tp) + gmp_free (tp); +} + + +/* MPN base conversion. */ +static unsigned +mpn_base_power_of_two_p (unsigned b) +{ + switch (b) + { + case 2: return 1; + case 4: return 2; + case 8: return 3; + case 16: return 4; + case 32: return 5; + case 64: return 6; + case 128: return 7; + case 256: return 8; + default: return 0; + } +} + +struct mpn_base_info +{ + /* bb is the largest power of the base which fits in one limb, and + exp is the corresponding exponent. */ + unsigned exp; + mp_limb_t bb; +}; + +static void +mpn_get_base_info (struct mpn_base_info *info, mp_limb_t b) +{ + mp_limb_t m; + mp_limb_t p; + unsigned exp; + + m = GMP_LIMB_MAX / b; + for (exp = 1, p = b; p <= m; exp++) + p *= b; + + info->exp = exp; + info->bb = p; +} + +static mp_bitcnt_t +mpn_limb_size_in_base_2 (mp_limb_t u) +{ + unsigned shift; + + assert (u > 0); + gmp_clz (shift, u); + return GMP_LIMB_BITS - shift; +} + +static size_t +mpn_get_str_bits (unsigned char *sp, unsigned bits, mp_srcptr up, mp_size_t un) +{ + unsigned char mask; + size_t sn, j; + mp_size_t i; + unsigned shift; + + sn = ((un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]) + + bits - 1) / bits; + + mask = (1U << bits) - 1; + + for (i = 0, j = sn, shift = 0; j-- > 0;) + { + unsigned char digit = up[i] >> shift; + + shift += bits; + + if (shift >= GMP_LIMB_BITS && ++i < un) + { + shift -= GMP_LIMB_BITS; + digit |= up[i] << (bits - shift); + } + sp[j] = digit & mask; + } + return sn; +} + +/* We generate digits from the least significant end, and reverse at + the end. */ +static size_t +mpn_limb_get_str (unsigned char *sp, mp_limb_t w, + const struct gmp_div_inverse *binv) +{ + mp_size_t i; + for (i = 0; w > 0; i++) + { + mp_limb_t h, l, r; + + h = w >> (GMP_LIMB_BITS - binv->shift); + l = w << binv->shift; + + gmp_udiv_qrnnd_preinv (w, r, h, l, binv->d1, binv->di); + assert ( (r << (GMP_LIMB_BITS - binv->shift)) == 0); + r >>= binv->shift; + + sp[i] = r; + } + return i; +} + +static size_t +mpn_get_str_other (unsigned char *sp, + int base, const struct mpn_base_info *info, + mp_ptr up, mp_size_t un) +{ + struct gmp_div_inverse binv; + size_t sn; + size_t i; + + mpn_div_qr_1_invert (&binv, base); + + sn = 0; + + if (un > 1) + { + struct gmp_div_inverse bbinv; + mpn_div_qr_1_invert (&bbinv, info->bb); + + do + { + mp_limb_t w; + size_t done; + w = mpn_div_qr_1_preinv (up, up, un, &bbinv); + un -= (up[un-1] == 0); + done = mpn_limb_get_str (sp + sn, w, &binv); + + for (sn += done; done < info->exp; done++) + sp[sn++] = 0; + } + while (un > 1); + } + sn += mpn_limb_get_str (sp + sn, up[0], &binv); + + /* Reverse order */ + for (i = 0; 2*i + 1 < sn; i++) + { + unsigned char t = sp[i]; + sp[i] = sp[sn - i - 1]; + sp[sn - i - 1] = t; + } + + return sn; +} + +size_t +mpn_get_str (unsigned char *sp, int base, mp_ptr up, mp_size_t un) +{ + unsigned bits; + + assert (un > 0); + assert (up[un-1] > 0); + + bits = mpn_base_power_of_two_p (base); + if (bits) + return mpn_get_str_bits (sp, bits, up, un); + else + { + struct mpn_base_info info; + + mpn_get_base_info (&info, base); + return mpn_get_str_other (sp, base, &info, up, un); + } +} + +static mp_size_t +mpn_set_str_bits (mp_ptr rp, const unsigned char *sp, size_t sn, + unsigned bits) +{ + mp_size_t rn; + size_t j; + unsigned shift; + + for (j = sn, rn = 0, shift = 0; j-- > 0; ) + { + if (shift == 0) + { + rp[rn++] = sp[j]; + shift += bits; + } + else + { + rp[rn-1] |= (mp_limb_t) sp[j] << shift; + shift += bits; + if (shift >= GMP_LIMB_BITS) + { + shift -= GMP_LIMB_BITS; + if (shift > 0) + rp[rn++] = (mp_limb_t) sp[j] >> (bits - shift); + } + } + } + rn = mpn_normalized_size (rp, rn); + return rn; +} + +/* Result is usually normalized, except for all-zero input, in which + case a single zero limb is written at *RP, and 1 is returned. */ +static mp_size_t +mpn_set_str_other (mp_ptr rp, const unsigned char *sp, size_t sn, + mp_limb_t b, const struct mpn_base_info *info) +{ + mp_size_t rn; + mp_limb_t w; + unsigned k; + size_t j; + + assert (sn > 0); + + k = 1 + (sn - 1) % info->exp; + + j = 0; + w = sp[j++]; + while (--k != 0) + w = w * b + sp[j++]; + + rp[0] = w; + + for (rn = 1; j < sn;) + { + mp_limb_t cy; + + w = sp[j++]; + for (k = 1; k < info->exp; k++) + w = w * b + sp[j++]; + + cy = mpn_mul_1 (rp, rp, rn, info->bb); + cy += mpn_add_1 (rp, rp, rn, w); + if (cy > 0) + rp[rn++] = cy; + } + assert (j == sn); + + return rn; +} + +mp_size_t +mpn_set_str (mp_ptr rp, const unsigned char *sp, size_t sn, int base) +{ + unsigned bits; + + if (sn == 0) + return 0; + + bits = mpn_base_power_of_two_p (base); + if (bits) + return mpn_set_str_bits (rp, sp, sn, bits); + else + { + struct mpn_base_info info; + + mpn_get_base_info (&info, base); + return mpn_set_str_other (rp, sp, sn, base, &info); + } +} + + +/* MPZ interface */ +void +mpz_init (mpz_t r) +{ + static const mp_limb_t dummy_limb = 0xc1a0; + + r->_mp_alloc = 0; + r->_mp_size = 0; + r->_mp_d = (mp_ptr) &dummy_limb; +} + +/* The utility of this function is a bit limited, since many functions + assigns the result variable using mpz_swap. */ +void +mpz_init2 (mpz_t r, mp_bitcnt_t bits) +{ + mp_size_t rn; + + bits -= (bits != 0); /* Round down, except if 0 */ + rn = 1 + bits / GMP_LIMB_BITS; + + r->_mp_alloc = rn; + r->_mp_size = 0; + r->_mp_d = gmp_xalloc_limbs (rn); +} + +void +mpz_clear (mpz_t r) +{ + if (r->_mp_alloc) + gmp_free (r->_mp_d); +} + +static mp_ptr +mpz_realloc (mpz_t r, mp_size_t size) +{ + size = GMP_MAX (size, 1); + + if (r->_mp_alloc) + r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size); + else + r->_mp_d = gmp_xalloc_limbs (size); + r->_mp_alloc = size; + + if (GMP_ABS (r->_mp_size) > size) + r->_mp_size = 0; + + return r->_mp_d; +} + +/* Realloc for an mpz_t WHAT if it has less than NEEDED limbs. */ +#define MPZ_REALLOC(z,n) ((n) > (z)->_mp_alloc \ + ? mpz_realloc(z,n) \ + : (z)->_mp_d) + +/* MPZ assignment and basic conversions. */ +void +mpz_set_si (mpz_t r, signed long int x) +{ + if (x >= 0) + mpz_set_ui (r, x); + else /* (x < 0) */ + { + r->_mp_size = -1; + MPZ_REALLOC (r, 1)[0] = GMP_NEG_CAST (unsigned long int, x); + } +} + +void +mpz_set_ui (mpz_t r, unsigned long int x) +{ + if (x > 0) + { + r->_mp_size = 1; + MPZ_REALLOC (r, 1)[0] = x; + } + else + r->_mp_size = 0; +} + +void +mpz_set (mpz_t r, const mpz_t x) +{ + /* Allow the NOP r == x */ + if (r != x) + { + mp_size_t n; + mp_ptr rp; + + n = GMP_ABS (x->_mp_size); + rp = MPZ_REALLOC (r, n); + + mpn_copyi (rp, x->_mp_d, n); + r->_mp_size = x->_mp_size; + } +} + +void +mpz_init_set_si (mpz_t r, signed long int x) +{ + mpz_init (r); + mpz_set_si (r, x); +} + +void +mpz_init_set_ui (mpz_t r, unsigned long int x) +{ + mpz_init (r); + mpz_set_ui (r, x); +} + +void +mpz_init_set (mpz_t r, const mpz_t x) +{ + mpz_init (r); + mpz_set (r, x); +} + +int +mpz_fits_slong_p (const mpz_t u) +{ + mp_size_t us = u->_mp_size; + + if (us == 1) + return u->_mp_d[0] < GMP_LIMB_HIGHBIT; + else if (us == -1) + return u->_mp_d[0] <= GMP_LIMB_HIGHBIT; + else + return (us == 0); +} + +int +mpz_fits_ulong_p (const mpz_t u) +{ + mp_size_t us = u->_mp_size; + + return (us == (us > 0)); +} + +long int +mpz_get_si (const mpz_t u) +{ + if (u->_mp_size < 0) + /* This expression is necessary to properly handle 0x80000000 */ + return -1 - (long) ((u->_mp_d[0] - 1) & ~GMP_LIMB_HIGHBIT); + else + return (long) (mpz_get_ui (u) & ~GMP_LIMB_HIGHBIT); +} + +unsigned long int +mpz_get_ui (const mpz_t u) +{ + return u->_mp_size == 0 ? 0 : u->_mp_d[0]; +} + +size_t +mpz_size (const mpz_t u) +{ + return GMP_ABS (u->_mp_size); +} + +mp_limb_t +mpz_getlimbn (const mpz_t u, mp_size_t n) +{ + if (n >= 0 && n < GMP_ABS (u->_mp_size)) + return u->_mp_d[n]; + else + return 0; +} + +void +mpz_realloc2 (mpz_t x, mp_bitcnt_t n) +{ + mpz_realloc (x, 1 + (n - (n != 0)) / GMP_LIMB_BITS); +} + +mp_srcptr +mpz_limbs_read (mpz_srcptr x) +{ + return x->_mp_d; +} + +mp_ptr +mpz_limbs_modify (mpz_t x, mp_size_t n) +{ + assert (n > 0); + return MPZ_REALLOC (x, n); +} + +mp_ptr +mpz_limbs_write (mpz_t x, mp_size_t n) +{ + return mpz_limbs_modify (x, n); +} + +void +mpz_limbs_finish (mpz_t x, mp_size_t xs) +{ + mp_size_t xn; + xn = mpn_normalized_size (x->_mp_d, GMP_ABS (xs)); + x->_mp_size = xs < 0 ? -xn : xn; +} + +static mpz_srcptr +mpz_roinit_normal_n (mpz_t x, mp_srcptr xp, mp_size_t xs) +{ + x->_mp_alloc = 0; + x->_mp_d = (mp_ptr) xp; + x->_mp_size = xs; + return x; +} + +mpz_srcptr +mpz_roinit_n (mpz_t x, mp_srcptr xp, mp_size_t xs) +{ + mpz_roinit_normal_n (x, xp, xs); + mpz_limbs_finish (x, xs); + return x; +} + + +/* Conversions and comparison to double. */ +void +mpz_set_d (mpz_t r, double x) +{ + int sign; + mp_ptr rp; + mp_size_t rn, i; + double B; + double Bi; + mp_limb_t f; + + /* x != x is true when x is a NaN, and x == x * 0.5 is true when x is + zero or infinity. */ + if (x != x || x == x * 0.5) + { + r->_mp_size = 0; + return; + } + + sign = x < 0.0 ; + if (sign) + x = - x; + + if (x < 1.0) + { + r->_mp_size = 0; + return; + } + B = 2.0 * (double) GMP_LIMB_HIGHBIT; + Bi = 1.0 / B; + for (rn = 1; x >= B; rn++) + x *= Bi; + + rp = MPZ_REALLOC (r, rn); + + f = (mp_limb_t) x; + x -= f; + assert (x < 1.0); + i = rn-1; + rp[i] = f; + while (--i >= 0) + { + x = B * x; + f = (mp_limb_t) x; + x -= f; + assert (x < 1.0); + rp[i] = f; + } + + r->_mp_size = sign ? - rn : rn; +} + +void +mpz_init_set_d (mpz_t r, double x) +{ + mpz_init (r); + mpz_set_d (r, x); +} + +double +mpz_get_d (const mpz_t u) +{ + int m; + mp_limb_t l; + mp_size_t un; + double x; + double B = 2.0 * (double) GMP_LIMB_HIGHBIT; + + un = GMP_ABS (u->_mp_size); + + if (un == 0) + return 0.0; + + l = u->_mp_d[--un]; + gmp_clz (m, l); + m = m + GMP_DBL_MANT_BITS - GMP_LIMB_BITS; + if (m < 0) + l &= GMP_LIMB_MAX << -m; + + for (x = l; --un >= 0;) + { + x = B*x; + if (m > 0) { + l = u->_mp_d[un]; + m -= GMP_LIMB_BITS; + if (m < 0) + l &= GMP_LIMB_MAX << -m; + x += l; + } + } + + if (u->_mp_size < 0) + x = -x; + + return x; +} + +int +mpz_cmpabs_d (const mpz_t x, double d) +{ + mp_size_t xn; + double B, Bi; + mp_size_t i; + + xn = x->_mp_size; + d = GMP_ABS (d); + + if (xn != 0) + { + xn = GMP_ABS (xn); + + B = 2.0 * (double) GMP_LIMB_HIGHBIT; + Bi = 1.0 / B; + + /* Scale d so it can be compared with the top limb. */ + for (i = 1; i < xn; i++) + d *= Bi; + + if (d >= B) + return -1; + + /* Compare floor(d) to top limb, subtract and cancel when equal. */ + for (i = xn; i-- > 0;) + { + mp_limb_t f, xl; + + f = (mp_limb_t) d; + xl = x->_mp_d[i]; + if (xl > f) + return 1; + else if (xl < f) + return -1; + d = B * (d - f); + } + } + return - (d > 0.0); +} + +int +mpz_cmp_d (const mpz_t x, double d) +{ + if (x->_mp_size < 0) + { + if (d >= 0.0) + return -1; + else + return -mpz_cmpabs_d (x, d); + } + else + { + if (d < 0.0) + return 1; + else + return mpz_cmpabs_d (x, d); + } +} + + +/* MPZ comparisons and the like. */ +int +mpz_sgn (const mpz_t u) +{ + return GMP_CMP (u->_mp_size, 0); +} + +int +mpz_cmp_si (const mpz_t u, long v) +{ + mp_size_t usize = u->_mp_size; + + if (usize < -1) + return -1; + else if (v >= 0) + return mpz_cmp_ui (u, v); + else if (usize >= 0) + return 1; + else /* usize == -1 */ + return GMP_CMP (GMP_NEG_CAST (mp_limb_t, v), u->_mp_d[0]); +} + +int +mpz_cmp_ui (const mpz_t u, unsigned long v) +{ + mp_size_t usize = u->_mp_size; + + if (usize > 1) + return 1; + else if (usize < 0) + return -1; + else + return GMP_CMP (mpz_get_ui (u), v); +} + +int +mpz_cmp (const mpz_t a, const mpz_t b) +{ + mp_size_t asize = a->_mp_size; + mp_size_t bsize = b->_mp_size; + + if (asize != bsize) + return (asize < bsize) ? -1 : 1; + else if (asize >= 0) + return mpn_cmp (a->_mp_d, b->_mp_d, asize); + else + return mpn_cmp (b->_mp_d, a->_mp_d, -asize); +} + +int +mpz_cmpabs_ui (const mpz_t u, unsigned long v) +{ + if (GMP_ABS (u->_mp_size) > 1) + return 1; + else + return GMP_CMP (mpz_get_ui (u), v); +} + +int +mpz_cmpabs (const mpz_t u, const mpz_t v) +{ + return mpn_cmp4 (u->_mp_d, GMP_ABS (u->_mp_size), + v->_mp_d, GMP_ABS (v->_mp_size)); +} + +void +mpz_abs (mpz_t r, const mpz_t u) +{ + mpz_set (r, u); + r->_mp_size = GMP_ABS (r->_mp_size); +} + +void +mpz_neg (mpz_t r, const mpz_t u) +{ + mpz_set (r, u); + r->_mp_size = -r->_mp_size; +} + +void +mpz_swap (mpz_t u, mpz_t v) +{ + MP_SIZE_T_SWAP (u->_mp_size, v->_mp_size); + MP_SIZE_T_SWAP (u->_mp_alloc, v->_mp_alloc); + MP_PTR_SWAP (u->_mp_d, v->_mp_d); +} + + +/* MPZ addition and subtraction */ + +/* Adds to the absolute value. Returns new size, but doesn't store it. */ +static mp_size_t +mpz_abs_add_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + mp_size_t an; + mp_ptr rp; + mp_limb_t cy; + + an = GMP_ABS (a->_mp_size); + if (an == 0) + { + MPZ_REALLOC (r, 1)[0] = b; + return b > 0; + } + + rp = MPZ_REALLOC (r, an + 1); + + cy = mpn_add_1 (rp, a->_mp_d, an, b); + rp[an] = cy; + an += cy; + + return an; +} + +/* Subtract from the absolute value. Returns new size, (or -1 on underflow), + but doesn't store it. */ +static mp_size_t +mpz_abs_sub_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_ptr rp; + + if (an == 0) + { + MPZ_REALLOC (r, 1)[0] = b; + return -(b > 0); + } + rp = MPZ_REALLOC (r, an); + if (an == 1 && a->_mp_d[0] < b) + { + rp[0] = b - a->_mp_d[0]; + return -1; + } + else + { + gmp_assert_nocarry (mpn_sub_1 (rp, a->_mp_d, an, b)); + return mpn_normalized_size (rp, an); + } +} + +void +mpz_add_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + if (a->_mp_size >= 0) + r->_mp_size = mpz_abs_add_ui (r, a, b); + else + r->_mp_size = -mpz_abs_sub_ui (r, a, b); +} + +void +mpz_sub_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + if (a->_mp_size < 0) + r->_mp_size = -mpz_abs_add_ui (r, a, b); + else + r->_mp_size = mpz_abs_sub_ui (r, a, b); +} + +void +mpz_ui_sub (mpz_t r, unsigned long a, const mpz_t b) +{ + if (b->_mp_size < 0) + r->_mp_size = mpz_abs_add_ui (r, b, a); + else + r->_mp_size = -mpz_abs_sub_ui (r, b, a); +} + +static mp_size_t +mpz_abs_add (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_size_t bn = GMP_ABS (b->_mp_size); + mp_ptr rp; + mp_limb_t cy; + + if (an < bn) + { + MPZ_SRCPTR_SWAP (a, b); + MP_SIZE_T_SWAP (an, bn); + } + + rp = MPZ_REALLOC (r, an + 1); + cy = mpn_add (rp, a->_mp_d, an, b->_mp_d, bn); + + rp[an] = cy; + + return an + cy; +} + +static mp_size_t +mpz_abs_sub (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_size_t bn = GMP_ABS (b->_mp_size); + int cmp; + mp_ptr rp; + + cmp = mpn_cmp4 (a->_mp_d, an, b->_mp_d, bn); + if (cmp > 0) + { + rp = MPZ_REALLOC (r, an); + gmp_assert_nocarry (mpn_sub (rp, a->_mp_d, an, b->_mp_d, bn)); + return mpn_normalized_size (rp, an); + } + else if (cmp < 0) + { + rp = MPZ_REALLOC (r, bn); + gmp_assert_nocarry (mpn_sub (rp, b->_mp_d, bn, a->_mp_d, an)); + return -mpn_normalized_size (rp, bn); + } + else + return 0; +} + +void +mpz_add (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t rn; + + if ( (a->_mp_size ^ b->_mp_size) >= 0) + rn = mpz_abs_add (r, a, b); + else + rn = mpz_abs_sub (r, a, b); + + r->_mp_size = a->_mp_size >= 0 ? rn : - rn; +} + +void +mpz_sub (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t rn; + + if ( (a->_mp_size ^ b->_mp_size) >= 0) + rn = mpz_abs_sub (r, a, b); + else + rn = mpz_abs_add (r, a, b); + + r->_mp_size = a->_mp_size >= 0 ? rn : - rn; +} + + +/* MPZ multiplication */ +void +mpz_mul_si (mpz_t r, const mpz_t u, long int v) +{ + if (v < 0) + { + mpz_mul_ui (r, u, GMP_NEG_CAST (unsigned long int, v)); + mpz_neg (r, r); + } + else + mpz_mul_ui (r, u, (unsigned long int) v); +} + +void +mpz_mul_ui (mpz_t r, const mpz_t u, unsigned long int v) +{ + mp_size_t un, us; + mp_ptr tp; + mp_limb_t cy; + + us = u->_mp_size; + + if (us == 0 || v == 0) + { + r->_mp_size = 0; + return; + } + + un = GMP_ABS (us); + + tp = MPZ_REALLOC (r, un + 1); + cy = mpn_mul_1 (tp, u->_mp_d, un, v); + tp[un] = cy; + + un += (cy > 0); + r->_mp_size = (us < 0) ? - un : un; +} + +void +mpz_mul (mpz_t r, const mpz_t u, const mpz_t v) +{ + int sign; + mp_size_t un, vn, rn; + mpz_t t; + mp_ptr tp; + + un = u->_mp_size; + vn = v->_mp_size; + + if (un == 0 || vn == 0) + { + r->_mp_size = 0; + return; + } + + sign = (un ^ vn) < 0; + + un = GMP_ABS (un); + vn = GMP_ABS (vn); + + mpz_init2 (t, (un + vn) * GMP_LIMB_BITS); + + tp = t->_mp_d; + if (un >= vn) + mpn_mul (tp, u->_mp_d, un, v->_mp_d, vn); + else + mpn_mul (tp, v->_mp_d, vn, u->_mp_d, un); + + rn = un + vn; + rn -= tp[rn-1] == 0; + + t->_mp_size = sign ? - rn : rn; + mpz_swap (r, t); + mpz_clear (t); +} + +void +mpz_mul_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bits) +{ + mp_size_t un, rn; + mp_size_t limbs; + unsigned shift; + mp_ptr rp; + + un = GMP_ABS (u->_mp_size); + if (un == 0) + { + r->_mp_size = 0; + return; + } + + limbs = bits / GMP_LIMB_BITS; + shift = bits % GMP_LIMB_BITS; + + rn = un + limbs + (shift > 0); + rp = MPZ_REALLOC (r, rn); + if (shift > 0) + { + mp_limb_t cy = mpn_lshift (rp + limbs, u->_mp_d, un, shift); + rp[rn-1] = cy; + rn -= (cy == 0); + } + else + mpn_copyd (rp + limbs, u->_mp_d, un); + + mpn_zero (rp, limbs); + + r->_mp_size = (u->_mp_size < 0) ? - rn : rn; +} + +void +mpz_addmul_ui (mpz_t r, const mpz_t u, unsigned long int v) +{ + mpz_t t; + mpz_init (t); + mpz_mul_ui (t, u, v); + mpz_add (r, r, t); + mpz_clear (t); +} + +void +mpz_submul_ui (mpz_t r, const mpz_t u, unsigned long int v) +{ + mpz_t t; + mpz_init (t); + mpz_mul_ui (t, u, v); + mpz_sub (r, r, t); + mpz_clear (t); +} + +void +mpz_addmul (mpz_t r, const mpz_t u, const mpz_t v) +{ + mpz_t t; + mpz_init (t); + mpz_mul (t, u, v); + mpz_add (r, r, t); + mpz_clear (t); +} + +void +mpz_submul (mpz_t r, const mpz_t u, const mpz_t v) +{ + mpz_t t; + mpz_init (t); + mpz_mul (t, u, v); + mpz_sub (r, r, t); + mpz_clear (t); +} + + +/* MPZ division */ +enum mpz_div_round_mode { GMP_DIV_FLOOR, GMP_DIV_CEIL, GMP_DIV_TRUNC }; + +/* Allows q or r to be zero. Returns 1 iff remainder is non-zero. */ +static int +mpz_div_qr (mpz_t q, mpz_t r, + const mpz_t n, const mpz_t d, enum mpz_div_round_mode mode) +{ + mp_size_t ns, ds, nn, dn, qs; + ns = n->_mp_size; + ds = d->_mp_size; + + if (ds == 0) + gmp_die("mpz_div_qr: Divide by zero."); + + if (ns == 0) + { + if (q) + q->_mp_size = 0; + if (r) + r->_mp_size = 0; + return 0; + } + + nn = GMP_ABS (ns); + dn = GMP_ABS (ds); + + qs = ds ^ ns; + + if (nn < dn) + { + if (mode == GMP_DIV_CEIL && qs >= 0) + { + /* q = 1, r = n - d */ + if (r) + mpz_sub (r, n, d); + if (q) + mpz_set_ui (q, 1); + } + else if (mode == GMP_DIV_FLOOR && qs < 0) + { + /* q = -1, r = n + d */ + if (r) + mpz_add (r, n, d); + if (q) + mpz_set_si (q, -1); + } + else + { + /* q = 0, r = d */ + if (r) + mpz_set (r, n); + if (q) + q->_mp_size = 0; + } + return 1; + } + else + { + mp_ptr np, qp; + mp_size_t qn, rn; + mpz_t tq, tr; + + mpz_init_set (tr, n); + np = tr->_mp_d; + + qn = nn - dn + 1; + + if (q) + { + mpz_init2 (tq, qn * GMP_LIMB_BITS); + qp = tq->_mp_d; + } + else + qp = NULL; + + mpn_div_qr (qp, np, nn, d->_mp_d, dn); + + if (qp) + { + qn -= (qp[qn-1] == 0); + + tq->_mp_size = qs < 0 ? -qn : qn; + } + rn = mpn_normalized_size (np, dn); + tr->_mp_size = ns < 0 ? - rn : rn; + + if (mode == GMP_DIV_FLOOR && qs < 0 && rn != 0) + { + if (q) + mpz_sub_ui (tq, tq, 1); + if (r) + mpz_add (tr, tr, d); + } + else if (mode == GMP_DIV_CEIL && qs >= 0 && rn != 0) + { + if (q) + mpz_add_ui (tq, tq, 1); + if (r) + mpz_sub (tr, tr, d); + } + + if (q) + { + mpz_swap (tq, q); + mpz_clear (tq); + } + if (r) + mpz_swap (tr, r); + + mpz_clear (tr); + + return rn != 0; + } +} + +void +mpz_cdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_TRUNC); +} + +void +mpz_mod (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, d->_mp_size >= 0 ? GMP_DIV_FLOOR : GMP_DIV_CEIL); +} + +static void +mpz_div_q_2exp (mpz_t q, const mpz_t u, mp_bitcnt_t bit_index, + enum mpz_div_round_mode mode) +{ + mp_size_t un, qn; + mp_size_t limb_cnt; + mp_ptr qp; + int adjust; + + un = u->_mp_size; + if (un == 0) + { + q->_mp_size = 0; + return; + } + limb_cnt = bit_index / GMP_LIMB_BITS; + qn = GMP_ABS (un) - limb_cnt; + bit_index %= GMP_LIMB_BITS; + + if (mode == ((un > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* un != 0 here. */ + /* Note: Below, the final indexing at limb_cnt is valid because at + that point we have qn > 0. */ + adjust = (qn <= 0 + || !mpn_zero_p (u->_mp_d, limb_cnt) + || (u->_mp_d[limb_cnt] + & (((mp_limb_t) 1 << bit_index) - 1))); + else + adjust = 0; + + if (qn <= 0) + qn = 0; + else + { + qp = MPZ_REALLOC (q, qn); + + if (bit_index != 0) + { + mpn_rshift (qp, u->_mp_d + limb_cnt, qn, bit_index); + qn -= qp[qn - 1] == 0; + } + else + { + mpn_copyi (qp, u->_mp_d + limb_cnt, qn); + } + } + + q->_mp_size = qn; + + if (adjust) + mpz_add_ui (q, q, 1); + if (un < 0) + mpz_neg (q, q); +} + +static void +mpz_div_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bit_index, + enum mpz_div_round_mode mode) +{ + mp_size_t us, un, rn; + mp_ptr rp; + mp_limb_t mask; + + us = u->_mp_size; + if (us == 0 || bit_index == 0) + { + r->_mp_size = 0; + return; + } + rn = (bit_index + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + assert (rn > 0); + + rp = MPZ_REALLOC (r, rn); + un = GMP_ABS (us); + + mask = GMP_LIMB_MAX >> (rn * GMP_LIMB_BITS - bit_index); + + if (rn > un) + { + /* Quotient (with truncation) is zero, and remainder is + non-zero */ + if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ + { + /* Have to negate and sign extend. */ + mp_size_t i; + + gmp_assert_nocarry (! mpn_neg (rp, u->_mp_d, un)); + for (i = un; i < rn - 1; i++) + rp[i] = GMP_LIMB_MAX; + + rp[rn-1] = mask; + us = -us; + } + else + { + /* Just copy */ + if (r != u) + mpn_copyi (rp, u->_mp_d, un); + + rn = un; + } + } + else + { + if (r != u) + mpn_copyi (rp, u->_mp_d, rn - 1); + + rp[rn-1] = u->_mp_d[rn-1] & mask; + + if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ + { + /* If r != 0, compute 2^{bit_count} - r. */ + mpn_neg (rp, rp, rn); + + rp[rn-1] &= mask; + + /* us is not used for anything else, so we can modify it + here to indicate flipped sign. */ + us = -us; + } + } + rn = mpn_normalized_size (rp, rn); + r->_mp_size = us < 0 ? -rn : rn; +} + +void +mpz_cdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_CEIL); +} + +void +mpz_fdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_CEIL); +} + +void +mpz_fdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_TRUNC); +} + +void +mpz_divexact (mpz_t q, const mpz_t n, const mpz_t d) +{ + gmp_assert_nocarry (mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC)); +} + +int +mpz_divisible_p (const mpz_t n, const mpz_t d) +{ + return mpz_div_qr (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; +} + +int +mpz_congruent_p (const mpz_t a, const mpz_t b, const mpz_t m) +{ + mpz_t t; + int res; + + /* a == b (mod 0) iff a == b */ + if (mpz_sgn (m) == 0) + return (mpz_cmp (a, b) == 0); + + mpz_init (t); + mpz_sub (t, a, b); + res = mpz_divisible_p (t, m); + mpz_clear (t); + + return res; +} + +static unsigned long +mpz_div_qr_ui (mpz_t q, mpz_t r, + const mpz_t n, unsigned long d, enum mpz_div_round_mode mode) +{ + mp_size_t ns, qn; + mp_ptr qp; + mp_limb_t rl; + mp_size_t rs; + + ns = n->_mp_size; + if (ns == 0) + { + if (q) + q->_mp_size = 0; + if (r) + r->_mp_size = 0; + return 0; + } + + qn = GMP_ABS (ns); + if (q) + qp = MPZ_REALLOC (q, qn); + else + qp = NULL; + + rl = mpn_div_qr_1 (qp, n->_mp_d, qn, d); + assert (rl < d); + + rs = rl > 0; + rs = (ns < 0) ? -rs : rs; + + if (rl > 0 && ( (mode == GMP_DIV_FLOOR && ns < 0) + || (mode == GMP_DIV_CEIL && ns >= 0))) + { + if (q) + gmp_assert_nocarry (mpn_add_1 (qp, qp, qn, 1)); + rl = d - rl; + rs = -rs; + } + + if (r) + { + MPZ_REALLOC (r, 1)[0] = rl; + r->_mp_size = rs; + } + if (q) + { + qn -= (qp[qn-1] == 0); + assert (qn == 0 || qp[qn-1] > 0); + + q->_mp_size = (ns < 0) ? - qn : qn; + } + + return rl; +} + +unsigned long +mpz_cdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_CEIL); +} +unsigned long +mpz_fdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); +} +unsigned long +mpz_tdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_mod_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_divexact_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + gmp_assert_nocarry (mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC)); +} + +int +mpz_divisible_ui_p (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; +} + + +/* GCD */ +static mp_limb_t +mpn_gcd_11 (mp_limb_t u, mp_limb_t v) +{ + unsigned shift; + + assert ( (u | v) > 0); + + if (u == 0) + return v; + else if (v == 0) + return u; + + gmp_ctz (shift, u | v); + + u >>= shift; + v >>= shift; + + if ( (u & 1) == 0) + MP_LIMB_T_SWAP (u, v); + + while ( (v & 1) == 0) + v >>= 1; + + while (u != v) + { + if (u > v) + { + u -= v; + do + u >>= 1; + while ( (u & 1) == 0); + } + else + { + v -= u; + do + v >>= 1; + while ( (v & 1) == 0); + } + } + return u << shift; +} + +unsigned long +mpz_gcd_ui (mpz_t g, const mpz_t u, unsigned long v) +{ + mp_size_t un; + + if (v == 0) + { + if (g) + mpz_abs (g, u); + } + else + { + un = GMP_ABS (u->_mp_size); + if (un != 0) + v = mpn_gcd_11 (mpn_div_qr_1 (NULL, u->_mp_d, un, v), v); + + if (g) + mpz_set_ui (g, v); + } + + return v; +} + +static mp_bitcnt_t +mpz_make_odd (mpz_t r) +{ + mp_bitcnt_t shift; + + assert (r->_mp_size > 0); + /* Count trailing zeros, equivalent to mpn_scan1, because we know that there is a 1 */ + shift = mpn_common_scan (r->_mp_d[0], 0, r->_mp_d, 0, 0); + mpz_tdiv_q_2exp (r, r, shift); + + return shift; +} + +void +mpz_gcd (mpz_t g, const mpz_t u, const mpz_t v) +{ + mpz_t tu, tv; + mp_bitcnt_t uz, vz, gz; + + if (u->_mp_size == 0) + { + mpz_abs (g, v); + return; + } + if (v->_mp_size == 0) + { + mpz_abs (g, u); + return; + } + + mpz_init (tu); + mpz_init (tv); + + mpz_abs (tu, u); + uz = mpz_make_odd (tu); + mpz_abs (tv, v); + vz = mpz_make_odd (tv); + gz = GMP_MIN (uz, vz); + + if (tu->_mp_size < tv->_mp_size) + mpz_swap (tu, tv); + + mpz_tdiv_r (tu, tu, tv); + if (tu->_mp_size == 0) + { + mpz_swap (g, tv); + } + else + for (;;) + { + int c; + + mpz_make_odd (tu); + c = mpz_cmp (tu, tv); + if (c == 0) + { + mpz_swap (g, tu); + break; + } + if (c < 0) + mpz_swap (tu, tv); + + if (tv->_mp_size == 1) + { + mp_limb_t vl = tv->_mp_d[0]; + mp_limb_t ul = mpz_tdiv_ui (tu, vl); + mpz_set_ui (g, mpn_gcd_11 (ul, vl)); + break; + } + mpz_sub (tu, tu, tv); + } + mpz_clear (tu); + mpz_clear (tv); + mpz_mul_2exp (g, g, gz); +} + +void +mpz_gcdext (mpz_t g, mpz_t s, mpz_t t, const mpz_t u, const mpz_t v) +{ + mpz_t tu, tv, s0, s1, t0, t1; + mp_bitcnt_t uz, vz, gz; + mp_bitcnt_t power; + + if (u->_mp_size == 0) + { + /* g = 0 u + sgn(v) v */ + signed long sign = mpz_sgn (v); + mpz_abs (g, v); + if (s) + mpz_set_ui (s, 0); + if (t) + mpz_set_si (t, sign); + return; + } + + if (v->_mp_size == 0) + { + /* g = sgn(u) u + 0 v */ + signed long sign = mpz_sgn (u); + mpz_abs (g, u); + if (s) + mpz_set_si (s, sign); + if (t) + mpz_set_ui (t, 0); + return; + } + + mpz_init (tu); + mpz_init (tv); + mpz_init (s0); + mpz_init (s1); + mpz_init (t0); + mpz_init (t1); + + mpz_abs (tu, u); + uz = mpz_make_odd (tu); + mpz_abs (tv, v); + vz = mpz_make_odd (tv); + gz = GMP_MIN (uz, vz); + + uz -= gz; + vz -= gz; + + /* Cofactors corresponding to odd gcd. gz handled later. */ + if (tu->_mp_size < tv->_mp_size) + { + mpz_swap (tu, tv); + MPZ_SRCPTR_SWAP (u, v); + MPZ_PTR_SWAP (s, t); + MP_BITCNT_T_SWAP (uz, vz); + } + + /* Maintain + * + * u = t0 tu + t1 tv + * v = s0 tu + s1 tv + * + * where u and v denote the inputs with common factors of two + * eliminated, and det (s0, t0; s1, t1) = 2^p. Then + * + * 2^p tu = s1 u - t1 v + * 2^p tv = -s0 u + t0 v + */ + + /* After initial division, tu = q tv + tu', we have + * + * u = 2^uz (tu' + q tv) + * v = 2^vz tv + * + * or + * + * t0 = 2^uz, t1 = 2^uz q + * s0 = 0, s1 = 2^vz + */ + + mpz_setbit (t0, uz); + mpz_tdiv_qr (t1, tu, tu, tv); + mpz_mul_2exp (t1, t1, uz); + + mpz_setbit (s1, vz); + power = uz + vz; + + if (tu->_mp_size > 0) + { + mp_bitcnt_t shift; + shift = mpz_make_odd (tu); + mpz_mul_2exp (t0, t0, shift); + mpz_mul_2exp (s0, s0, shift); + power += shift; + + for (;;) + { + int c; + c = mpz_cmp (tu, tv); + if (c == 0) + break; + + if (c < 0) + { + /* tv = tv' + tu + * + * u = t0 tu + t1 (tv' + tu) = (t0 + t1) tu + t1 tv' + * v = s0 tu + s1 (tv' + tu) = (s0 + s1) tu + s1 tv' */ + + mpz_sub (tv, tv, tu); + mpz_add (t0, t0, t1); + mpz_add (s0, s0, s1); + + shift = mpz_make_odd (tv); + mpz_mul_2exp (t1, t1, shift); + mpz_mul_2exp (s1, s1, shift); + } + else + { + mpz_sub (tu, tu, tv); + mpz_add (t1, t0, t1); + mpz_add (s1, s0, s1); + + shift = mpz_make_odd (tu); + mpz_mul_2exp (t0, t0, shift); + mpz_mul_2exp (s0, s0, shift); + } + power += shift; + } + } + + /* Now tv = odd part of gcd, and -s0 and t0 are corresponding + cofactors. */ + + mpz_mul_2exp (tv, tv, gz); + mpz_neg (s0, s0); + + /* 2^p g = s0 u + t0 v. Eliminate one factor of two at a time. To + adjust cofactors, we need u / g and v / g */ + + mpz_divexact (s1, v, tv); + mpz_abs (s1, s1); + mpz_divexact (t1, u, tv); + mpz_abs (t1, t1); + + while (power-- > 0) + { + /* s0 u + t0 v = (s0 - v/g) u - (t0 + u/g) v */ + if (mpz_odd_p (s0) || mpz_odd_p (t0)) + { + mpz_sub (s0, s0, s1); + mpz_add (t0, t0, t1); + } + mpz_divexact_ui (s0, s0, 2); + mpz_divexact_ui (t0, t0, 2); + } + + /* Arrange so that |s| < |u| / 2g */ + mpz_add (s1, s0, s1); + if (mpz_cmpabs (s0, s1) > 0) + { + mpz_swap (s0, s1); + mpz_sub (t0, t0, t1); + } + if (u->_mp_size < 0) + mpz_neg (s0, s0); + if (v->_mp_size < 0) + mpz_neg (t0, t0); + + mpz_swap (g, tv); + if (s) + mpz_swap (s, s0); + if (t) + mpz_swap (t, t0); + + mpz_clear (tu); + mpz_clear (tv); + mpz_clear (s0); + mpz_clear (s1); + mpz_clear (t0); + mpz_clear (t1); +} + +void +mpz_lcm (mpz_t r, const mpz_t u, const mpz_t v) +{ + mpz_t g; + + if (u->_mp_size == 0 || v->_mp_size == 0) + { + r->_mp_size = 0; + return; + } + + mpz_init (g); + + mpz_gcd (g, u, v); + mpz_divexact (g, u, g); + mpz_mul (r, g, v); + + mpz_clear (g); + mpz_abs (r, r); +} + +void +mpz_lcm_ui (mpz_t r, const mpz_t u, unsigned long v) +{ + if (v == 0 || u->_mp_size == 0) + { + r->_mp_size = 0; + return; + } + + v /= mpz_gcd_ui (NULL, u, v); + mpz_mul_ui (r, u, v); + + mpz_abs (r, r); +} + +int +mpz_invert (mpz_t r, const mpz_t u, const mpz_t m) +{ + mpz_t g, tr; + int invertible; + + if (u->_mp_size == 0 || mpz_cmpabs_ui (m, 1) <= 0) + return 0; + + mpz_init (g); + mpz_init (tr); + + mpz_gcdext (g, tr, NULL, u, m); + invertible = (mpz_cmp_ui (g, 1) == 0); + + if (invertible) + { + if (tr->_mp_size < 0) + { + if (m->_mp_size >= 0) + mpz_add (tr, tr, m); + else + mpz_sub (tr, tr, m); + } + mpz_swap (r, tr); + } + + mpz_clear (g); + mpz_clear (tr); + return invertible; +} + + +/* Higher level operations (sqrt, pow and root) */ + +void +mpz_pow_ui (mpz_t r, const mpz_t b, unsigned long e) +{ + unsigned long bit; + mpz_t tr; + mpz_init_set_ui (tr, 1); + + bit = GMP_ULONG_HIGHBIT; + do + { + mpz_mul (tr, tr, tr); + if (e & bit) + mpz_mul (tr, tr, b); + bit >>= 1; + } + while (bit > 0); + + mpz_swap (r, tr); + mpz_clear (tr); +} + +void +mpz_ui_pow_ui (mpz_t r, unsigned long blimb, unsigned long e) +{ + mpz_t b; + mpz_pow_ui (r, mpz_roinit_normal_n (b, &blimb, blimb != 0), e); +} + +void +mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m) +{ + mpz_t tr; + mpz_t base; + mp_size_t en, mn; + mp_srcptr mp; + struct gmp_div_inverse minv; + unsigned shift; + mp_ptr tp = NULL; + + en = GMP_ABS (e->_mp_size); + mn = GMP_ABS (m->_mp_size); + if (mn == 0) + gmp_die ("mpz_powm: Zero modulo."); + + if (en == 0) + { + mpz_set_ui (r, 1); + return; + } + + mp = m->_mp_d; + mpn_div_qr_invert (&minv, mp, mn); + shift = minv.shift; + + if (shift > 0) + { + /* To avoid shifts, we do all our reductions, except the final + one, using a *normalized* m. */ + minv.shift = 0; + + tp = gmp_xalloc_limbs (mn); + gmp_assert_nocarry (mpn_lshift (tp, mp, mn, shift)); + mp = tp; + } + + mpz_init (base); + + if (e->_mp_size < 0) + { + if (!mpz_invert (base, b, m)) + gmp_die ("mpz_powm: Negative exponent and non-invertible base."); + } + else + { + mp_size_t bn; + mpz_abs (base, b); + + bn = base->_mp_size; + if (bn >= mn) + { + mpn_div_qr_preinv (NULL, base->_mp_d, base->_mp_size, mp, mn, &minv); + bn = mn; + } + + /* We have reduced the absolute value. Now take care of the + sign. Note that we get zero represented non-canonically as + m. */ + if (b->_mp_size < 0) + { + mp_ptr bp = MPZ_REALLOC (base, mn); + gmp_assert_nocarry (mpn_sub (bp, mp, mn, bp, bn)); + bn = mn; + } + base->_mp_size = mpn_normalized_size (base->_mp_d, bn); + } + mpz_init_set_ui (tr, 1); + + while (--en >= 0) + { + mp_limb_t w = e->_mp_d[en]; + mp_limb_t bit; + + bit = GMP_LIMB_HIGHBIT; + do + { + mpz_mul (tr, tr, tr); + if (w & bit) + mpz_mul (tr, tr, base); + if (tr->_mp_size > mn) + { + mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); + tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); + } + bit >>= 1; + } + while (bit > 0); + } + + /* Final reduction */ + if (tr->_mp_size >= mn) + { + minv.shift = shift; + mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); + tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); + } + if (tp) + gmp_free (tp); + + mpz_swap (r, tr); + mpz_clear (tr); + mpz_clear (base); +} + +void +mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m) +{ + mpz_t e; + mpz_powm (r, b, mpz_roinit_normal_n (e, &elimb, elimb != 0), m); +} + +/* x=trunc(y^(1/z)), r=y-x^z */ +void +mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, unsigned long z) +{ + int sgn; + mpz_t t, u; + + sgn = y->_mp_size < 0; + if ((~z & sgn) != 0) + gmp_die ("mpz_rootrem: Negative argument, with even root."); + if (z == 0) + gmp_die ("mpz_rootrem: Zeroth root."); + + if (mpz_cmpabs_ui (y, 1) <= 0) { + if (x) + mpz_set (x, y); + if (r) + r->_mp_size = 0; + return; + } + + mpz_init (u); + mpz_init (t); + mpz_setbit (t, mpz_sizeinbase (y, 2) / z + 1); + + if (z == 2) /* simplify sqrt loop: z-1 == 1 */ + do { + mpz_swap (u, t); /* u = x */ + mpz_tdiv_q (t, y, u); /* t = y/x */ + mpz_add (t, t, u); /* t = y/x + x */ + mpz_tdiv_q_2exp (t, t, 1); /* x'= (y/x + x)/2 */ + } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ + else /* z != 2 */ { + mpz_t v; + + mpz_init (v); + if (sgn) + mpz_neg (t, t); + + do { + mpz_swap (u, t); /* u = x */ + mpz_pow_ui (t, u, z - 1); /* t = x^(z-1) */ + mpz_tdiv_q (t, y, t); /* t = y/x^(z-1) */ + mpz_mul_ui (v, u, z - 1); /* v = x*(z-1) */ + mpz_add (t, t, v); /* t = y/x^(z-1) + x*(z-1) */ + mpz_tdiv_q_ui (t, t, z); /* x'=(y/x^(z-1) + x*(z-1))/z */ + } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ + + mpz_clear (v); + } + + if (r) { + mpz_pow_ui (t, u, z); + mpz_sub (r, y, t); + } + if (x) + mpz_swap (x, u); + mpz_clear (u); + mpz_clear (t); +} + +int +mpz_root (mpz_t x, const mpz_t y, unsigned long z) +{ + int res; + mpz_t r; + + mpz_init (r); + mpz_rootrem (x, r, y, z); + res = r->_mp_size == 0; + mpz_clear (r); + + return res; +} + +/* Compute s = floor(sqrt(u)) and r = u - s^2. Allows r == NULL */ +void +mpz_sqrtrem (mpz_t s, mpz_t r, const mpz_t u) +{ + mpz_rootrem (s, r, u, 2); +} + +void +mpz_sqrt (mpz_t s, const mpz_t u) +{ + mpz_rootrem (s, NULL, u, 2); +} + +int +mpz_perfect_square_p (const mpz_t u) +{ + if (u->_mp_size <= 0) + return (u->_mp_size == 0); + else + return mpz_root (NULL, u, 2); +} + +int +mpn_perfect_square_p (mp_srcptr p, mp_size_t n) +{ + mpz_t t; + + assert (n > 0); + assert (p [n-1] != 0); + return mpz_root (NULL, mpz_roinit_normal_n (t, p, n), 2); +} + +mp_size_t +mpn_sqrtrem (mp_ptr sp, mp_ptr rp, mp_srcptr p, mp_size_t n) +{ + mpz_t s, r, u; + mp_size_t res; + + assert (n > 0); + assert (p [n-1] != 0); + + mpz_init (r); + mpz_init (s); + mpz_rootrem (s, r, mpz_roinit_normal_n (u, p, n), 2); + + assert (s->_mp_size == (n+1)/2); + mpn_copyd (sp, s->_mp_d, s->_mp_size); + mpz_clear (s); + res = r->_mp_size; + if (rp) + mpn_copyd (rp, r->_mp_d, res); + mpz_clear (r); + return res; +} + +/* Combinatorics */ + +void +mpz_mfac_uiui (mpz_t x, unsigned long n, unsigned long m) +{ + mpz_set_ui (x, n + (n == 0)); + if (m + 1 < 2) return; + while (n > m + 1) + mpz_mul_ui (x, x, n -= m); +} + +void +mpz_2fac_ui (mpz_t x, unsigned long n) +{ + mpz_mfac_uiui (x, n, 2); +} + +void +mpz_fac_ui (mpz_t x, unsigned long n) +{ + mpz_mfac_uiui (x, n, 1); +} + +void +mpz_bin_uiui (mpz_t r, unsigned long n, unsigned long k) +{ + mpz_t t; + + mpz_set_ui (r, k <= n); + + if (k > (n >> 1)) + k = (k <= n) ? n - k : 0; + + mpz_init (t); + mpz_fac_ui (t, k); + + for (; k > 0; --k) + mpz_mul_ui (r, r, n--); + + mpz_divexact (r, r, t); + mpz_clear (t); +} + + +/* Primality testing */ +static int +gmp_millerrabin (const mpz_t n, const mpz_t nm1, mpz_t y, + const mpz_t q, mp_bitcnt_t k) +{ + assert (k > 0); + + /* Caller must initialize y to the base. */ + mpz_powm (y, y, q, n); + + if (mpz_cmp_ui (y, 1) == 0 || mpz_cmp (y, nm1) == 0) + return 1; + + while (--k > 0) + { + mpz_powm_ui (y, y, 2, n); + if (mpz_cmp (y, nm1) == 0) + return 1; + /* y == 1 means that the previous y was a non-trivial square root + of 1 (mod n). y == 0 means that n is a power of the base. + In either case, n is not prime. */ + if (mpz_cmp_ui (y, 1) <= 0) + return 0; + } + return 0; +} + +/* This product is 0xc0cfd797, and fits in 32 bits. */ +#define GMP_PRIME_PRODUCT \ + (3UL*5UL*7UL*11UL*13UL*17UL*19UL*23UL*29UL) + +/* Bit (p+1)/2 is set, for each odd prime <= 61 */ +#define GMP_PRIME_MASK 0xc96996dcUL + +int +mpz_probab_prime_p (const mpz_t n, int reps) +{ + mpz_t nm1; + mpz_t q; + mpz_t y; + mp_bitcnt_t k; + int is_prime; + int j; + + /* Note that we use the absolute value of n only, for compatibility + with the real GMP. */ + if (mpz_even_p (n)) + return (mpz_cmpabs_ui (n, 2) == 0) ? 2 : 0; + + /* Above test excludes n == 0 */ + assert (n->_mp_size != 0); + + if (mpz_cmpabs_ui (n, 64) < 0) + return (GMP_PRIME_MASK >> (n->_mp_d[0] >> 1)) & 2; + + if (mpz_gcd_ui (NULL, n, GMP_PRIME_PRODUCT) != 1) + return 0; + + /* All prime factors are >= 31. */ + if (mpz_cmpabs_ui (n, 31*31) < 0) + return 2; + + /* Use Miller-Rabin, with a deterministic sequence of bases, a[j] = + j^2 + j + 41 using Euler's polynomial. We potentially stop early, + if a[j] >= n - 1. Since n >= 31*31, this can happen only if reps > + 30 (a[30] == 971 > 31*31 == 961). */ + + mpz_init (nm1); + mpz_init (q); + mpz_init (y); + + /* Find q and k, where q is odd and n = 1 + 2**k * q. */ + nm1->_mp_size = mpz_abs_sub_ui (nm1, n, 1); + k = mpz_scan1 (nm1, 0); + mpz_tdiv_q_2exp (q, nm1, k); + + for (j = 0, is_prime = 1; is_prime & (j < reps); j++) + { + mpz_set_ui (y, (unsigned long) j*j+j+41); + if (mpz_cmp (y, nm1) >= 0) + { + /* Don't try any further bases. This "early" break does not affect + the result for any reasonable reps value (<=5000 was tested) */ + assert (j >= 30); + break; + } + is_prime = gmp_millerrabin (n, nm1, y, q, k); + } + mpz_clear (nm1); + mpz_clear (q); + mpz_clear (y); + + return is_prime; +} + + +/* Logical operations and bit manipulation. */ + +/* Numbers are treated as if represented in two's complement (and + infinitely sign extended). For a negative values we get the two's + complement from -x = ~x + 1, where ~ is bitwise complement. + Negation transforms + + xxxx10...0 + + into + + yyyy10...0 + + where yyyy is the bitwise complement of xxxx. So least significant + bits, up to and including the first one bit, are unchanged, and + the more significant bits are all complemented. + + To change a bit from zero to one in a negative number, subtract the + corresponding power of two from the absolute value. This can never + underflow. To change a bit from one to zero, add the corresponding + power of two, and this might overflow. E.g., if x = -001111, the + two's complement is 110001. Clearing the least significant bit, we + get two's complement 110000, and -010000. */ + +int +mpz_tstbit (const mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t limb_index; + unsigned shift; + mp_size_t ds; + mp_size_t dn; + mp_limb_t w; + int bit; + + ds = d->_mp_size; + dn = GMP_ABS (ds); + limb_index = bit_index / GMP_LIMB_BITS; + if (limb_index >= dn) + return ds < 0; + + shift = bit_index % GMP_LIMB_BITS; + w = d->_mp_d[limb_index]; + bit = (w >> shift) & 1; + + if (ds < 0) + { + /* d < 0. Check if any of the bits below is set: If so, our bit + must be complemented. */ + if (shift > 0 && (w << (GMP_LIMB_BITS - shift)) > 0) + return bit ^ 1; + while (--limb_index >= 0) + if (d->_mp_d[limb_index] > 0) + return bit ^ 1; + } + return bit; +} + +static void +mpz_abs_add_bit (mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t dn, limb_index; + mp_limb_t bit; + mp_ptr dp; + + dn = GMP_ABS (d->_mp_size); + + limb_index = bit_index / GMP_LIMB_BITS; + bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); + + if (limb_index >= dn) + { + mp_size_t i; + /* The bit should be set outside of the end of the number. + We have to increase the size of the number. */ + dp = MPZ_REALLOC (d, limb_index + 1); + + dp[limb_index] = bit; + for (i = dn; i < limb_index; i++) + dp[i] = 0; + dn = limb_index + 1; + } + else + { + mp_limb_t cy; + + dp = d->_mp_d; + + cy = mpn_add_1 (dp + limb_index, dp + limb_index, dn - limb_index, bit); + if (cy > 0) + { + dp = MPZ_REALLOC (d, dn + 1); + dp[dn++] = cy; + } + } + + d->_mp_size = (d->_mp_size < 0) ? - dn : dn; +} + +static void +mpz_abs_sub_bit (mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t dn, limb_index; + mp_ptr dp; + mp_limb_t bit; + + dn = GMP_ABS (d->_mp_size); + dp = d->_mp_d; + + limb_index = bit_index / GMP_LIMB_BITS; + bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); + + assert (limb_index < dn); + + gmp_assert_nocarry (mpn_sub_1 (dp + limb_index, dp + limb_index, + dn - limb_index, bit)); + dn = mpn_normalized_size (dp, dn); + d->_mp_size = (d->_mp_size < 0) ? - dn : dn; +} + +void +mpz_setbit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (!mpz_tstbit (d, bit_index)) + { + if (d->_mp_size >= 0) + mpz_abs_add_bit (d, bit_index); + else + mpz_abs_sub_bit (d, bit_index); + } +} + +void +mpz_clrbit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (mpz_tstbit (d, bit_index)) + { + if (d->_mp_size >= 0) + mpz_abs_sub_bit (d, bit_index); + else + mpz_abs_add_bit (d, bit_index); + } +} + +void +mpz_combit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (mpz_tstbit (d, bit_index) ^ (d->_mp_size < 0)) + mpz_abs_sub_bit (d, bit_index); + else + mpz_abs_add_bit (d, bit_index); +} + +void +mpz_com (mpz_t r, const mpz_t u) +{ + mpz_neg (r, u); + mpz_sub_ui (r, r, 1); +} + +void +mpz_and (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, rn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + r->_mp_size = 0; + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc & vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + /* If the smaller input is positive, higher limbs don't matter. */ + rn = vx ? un : vn; + + rp = MPZ_REALLOC (r, rn + (mp_size_t) rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = ( (ul & vl) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < rn; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = ( (ul & vx) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[rn++] = rc; + else + rn = mpn_normalized_size (rp, rn); + + r->_mp_size = rx ? -rn : rn; +} + +void +mpz_ior (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, rn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + mpz_set (r, u); + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc | vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + /* If the smaller input is negative, by sign extension higher limbs + don't matter. */ + rn = vx ? vn : un; + + rp = MPZ_REALLOC (r, rn + (mp_size_t) rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = ( (ul | vl) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < rn; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = ( (ul | vx) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[rn++] = rc; + else + rn = mpn_normalized_size (rp, rn); + + r->_mp_size = rx ? -rn : rn; +} + +void +mpz_xor (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + mpz_set (r, u); + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc ^ vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + rp = MPZ_REALLOC (r, un + (mp_size_t) rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = (ul ^ vl ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < un; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = (ul ^ ux) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[un++] = rc; + else + un = mpn_normalized_size (rp, un); + + r->_mp_size = rx ? -un : un; +} + +static unsigned +gmp_popcount_limb (mp_limb_t x) +{ + unsigned c; + + /* Do 16 bits at a time, to avoid limb-sized constants. */ + for (c = 0; x > 0; x >>= 16) + { + unsigned w = x - ((x >> 1) & 0x5555); + w = ((w >> 2) & 0x3333) + (w & 0x3333); + w = (w >> 4) + w; + w = ((w >> 8) & 0x000f) + (w & 0x000f); + c += w; + } + return c; +} + +mp_bitcnt_t +mpn_popcount (mp_srcptr p, mp_size_t n) +{ + mp_size_t i; + mp_bitcnt_t c; + + for (c = 0, i = 0; i < n; i++) + c += gmp_popcount_limb (p[i]); + + return c; +} + +mp_bitcnt_t +mpz_popcount (const mpz_t u) +{ + mp_size_t un; + + un = u->_mp_size; + + if (un < 0) + return ~(mp_bitcnt_t) 0; + + return mpn_popcount (u->_mp_d, un); +} + +mp_bitcnt_t +mpz_hamdist (const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, i; + mp_limb_t uc, vc, ul, vl, comp; + mp_srcptr up, vp; + mp_bitcnt_t c; + + un = u->_mp_size; + vn = v->_mp_size; + + if ( (un ^ vn) < 0) + return ~(mp_bitcnt_t) 0; + + comp = - (uc = vc = (un < 0)); + if (uc) + { + assert (vn < 0); + un = -un; + vn = -vn; + } + + up = u->_mp_d; + vp = v->_mp_d; + + if (un < vn) + MPN_SRCPTR_SWAP (up, un, vp, vn); + + for (i = 0, c = 0; i < vn; i++) + { + ul = (up[i] ^ comp) + uc; + uc = ul < uc; + + vl = (vp[i] ^ comp) + vc; + vc = vl < vc; + + c += gmp_popcount_limb (ul ^ vl); + } + assert (vc == 0); + + for (; i < un; i++) + { + ul = (up[i] ^ comp) + uc; + uc = ul < uc; + + c += gmp_popcount_limb (ul ^ comp); + } + + return c; +} + +mp_bitcnt_t +mpz_scan1 (const mpz_t u, mp_bitcnt_t starting_bit) +{ + mp_ptr up; + mp_size_t us, un, i; + mp_limb_t limb, ux; + + us = u->_mp_size; + un = GMP_ABS (us); + i = starting_bit / GMP_LIMB_BITS; + + /* Past the end there's no 1 bits for u>=0, or an immediate 1 bit + for u<0. Notice this test picks up any u==0 too. */ + if (i >= un) + return (us >= 0 ? ~(mp_bitcnt_t) 0 : starting_bit); + + up = u->_mp_d; + ux = 0; + limb = up[i]; + + if (starting_bit != 0) + { + if (us < 0) + { + ux = mpn_zero_p (up, i); + limb = ~ limb + ux; + ux = - (mp_limb_t) (limb >= ux); + } + + /* Mask to 0 all bits before starting_bit, thus ignoring them. */ + limb &= (GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS)); + } + + return mpn_common_scan (limb, i, up, un, ux); +} + +mp_bitcnt_t +mpz_scan0 (const mpz_t u, mp_bitcnt_t starting_bit) +{ + mp_ptr up; + mp_size_t us, un, i; + mp_limb_t limb, ux; + + us = u->_mp_size; + ux = - (mp_limb_t) (us >= 0); + un = GMP_ABS (us); + i = starting_bit / GMP_LIMB_BITS; + + /* When past end, there's an immediate 0 bit for u>=0, or no 0 bits for + u<0. Notice this test picks up all cases of u==0 too. */ + if (i >= un) + return (ux ? starting_bit : ~(mp_bitcnt_t) 0); + + up = u->_mp_d; + limb = up[i] ^ ux; + + if (ux == 0) + limb -= mpn_zero_p (up, i); /* limb = ~(~limb + zero_p) */ + + /* Mask all bits before starting_bit, thus ignoring them. */ + limb &= (GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS)); + + return mpn_common_scan (limb, i, up, un, ux); +} + + +/* MPZ base conversion. */ + +size_t +mpz_sizeinbase (const mpz_t u, int base) +{ + mp_size_t un; + mp_srcptr up; + mp_ptr tp; + mp_bitcnt_t bits; + struct gmp_div_inverse bi; + size_t ndigits; + + assert (base >= 2); + assert (base <= 62); + + un = GMP_ABS (u->_mp_size); + if (un == 0) + return 1; + + up = u->_mp_d; + + bits = (un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]); + switch (base) + { + case 2: + return bits; + case 4: + return (bits + 1) / 2; + case 8: + return (bits + 2) / 3; + case 16: + return (bits + 3) / 4; + case 32: + return (bits + 4) / 5; + /* FIXME: Do something more clever for the common case of base + 10. */ + } + + tp = gmp_xalloc_limbs (un); + mpn_copyi (tp, up, un); + mpn_div_qr_1_invert (&bi, base); + + ndigits = 0; + do + { + ndigits++; + mpn_div_qr_1_preinv (tp, tp, un, &bi); + un -= (tp[un-1] == 0); + } + while (un > 0); + + gmp_free (tp); + return ndigits; +} + +char * +mpz_get_str (char *sp, int base, const mpz_t u) +{ + unsigned bits; + const char *digits; + mp_size_t un; + size_t i, sn; + + digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; + if (base > 1) + { + if (base <= 36) + digits = "0123456789abcdefghijklmnopqrstuvwxyz"; + else if (base > 62) + return NULL; + } + else if (base >= -1) + base = 10; + else + { + base = -base; + if (base > 36) + return NULL; + } + + sn = 1 + mpz_sizeinbase (u, base); + if (!sp) + sp = (char *) gmp_xalloc (1 + sn); + + un = GMP_ABS (u->_mp_size); + + if (un == 0) + { + sp[0] = '0'; + sp[1] = '\0'; + return sp; + } + + i = 0; + + if (u->_mp_size < 0) + sp[i++] = '-'; + + bits = mpn_base_power_of_two_p (base); + + if (bits) + /* Not modified in this case. */ + sn = i + mpn_get_str_bits ((unsigned char *) sp + i, bits, u->_mp_d, un); + else + { + struct mpn_base_info info; + mp_ptr tp; + + mpn_get_base_info (&info, base); + tp = gmp_xalloc_limbs (un); + mpn_copyi (tp, u->_mp_d, un); + + sn = i + mpn_get_str_other ((unsigned char *) sp + i, base, &info, tp, un); + gmp_free (tp); + } + + for (; i < sn; i++) + sp[i] = digits[(unsigned char) sp[i]]; + + sp[sn] = '\0'; + return sp; +} + +int +mpz_set_str (mpz_t r, const char *sp, int base) +{ + unsigned bits, value_of_a; + mp_size_t rn, alloc; + mp_ptr rp; + size_t dn; + int sign; + unsigned char *dp; + + assert (base == 0 || (base >= 2 && base <= 62)); + + while (isspace( (unsigned char) *sp)) + sp++; + + sign = (*sp == '-'); + sp += sign; + + if (base == 0) + { + if (sp[0] == '0') + { + if (sp[1] == 'x' || sp[1] == 'X') + { + base = 16; + sp += 2; + } + else if (sp[1] == 'b' || sp[1] == 'B') + { + base = 2; + sp += 2; + } + else + base = 8; + } + else + base = 10; + } + + if (!*sp) + { + r->_mp_size = 0; + return -1; + } + dp = (unsigned char *) gmp_xalloc (strlen (sp)); + + value_of_a = (base > 36) ? 36 : 10; + for (dn = 0; *sp; sp++) + { + unsigned digit; + + if (isspace ((unsigned char) *sp)) + continue; + else if (*sp >= '0' && *sp <= '9') + digit = *sp - '0'; + else if (*sp >= 'a' && *sp <= 'z') + digit = *sp - 'a' + value_of_a; + else if (*sp >= 'A' && *sp <= 'Z') + digit = *sp - 'A' + 10; + else + digit = base; /* fail */ + + if (digit >= (unsigned) base) + { + gmp_free (dp); + r->_mp_size = 0; + return -1; + } + + dp[dn++] = digit; + } + + if (!dn) + { + gmp_free (dp); + r->_mp_size = 0; + return -1; + } + bits = mpn_base_power_of_two_p (base); + + if (bits > 0) + { + alloc = (dn * bits + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + rp = MPZ_REALLOC (r, alloc); + rn = mpn_set_str_bits (rp, dp, dn, bits); + } + else + { + struct mpn_base_info info; + mpn_get_base_info (&info, base); + alloc = (dn + info.exp - 1) / info.exp; + rp = MPZ_REALLOC (r, alloc); + rn = mpn_set_str_other (rp, dp, dn, base, &info); + /* Normalization, needed for all-zero input. */ + assert (rn > 0); + rn -= rp[rn-1] == 0; + } + assert (rn <= alloc); + gmp_free (dp); + + r->_mp_size = sign ? - rn : rn; + + return 0; +} + +int +mpz_init_set_str (mpz_t r, const char *sp, int base) +{ + mpz_init (r); + return mpz_set_str (r, sp, base); +} + +size_t +mpz_out_str (FILE *stream, int base, const mpz_t x) +{ + char *str; + size_t len; + + str = mpz_get_str (NULL, base, x); + len = strlen (str); + len = fwrite (str, 1, len, stream); + gmp_free (str); + return len; +} + + +static int +gmp_detect_endian (void) +{ + static const int i = 2; + const unsigned char *p = (const unsigned char *) &i; + return 1 - *p; +} + +/* Import and export. Does not support nails. */ +void +mpz_import (mpz_t r, size_t count, int order, size_t size, int endian, + size_t nails, const void *src) +{ + const unsigned char *p; + ptrdiff_t word_step; + mp_ptr rp; + mp_size_t rn; + + /* The current (partial) limb. */ + mp_limb_t limb; + /* The number of bytes already copied to this limb (starting from + the low end). */ + size_t bytes; + /* The index where the limb should be stored, when completed. */ + mp_size_t i; + + if (nails != 0) + gmp_die ("mpz_import: Nails not supported."); + + assert (order == 1 || order == -1); + assert (endian >= -1 && endian <= 1); + + if (endian == 0) + endian = gmp_detect_endian (); + + p = (unsigned char *) src; + + word_step = (order != endian) ? 2 * size : 0; + + /* Process bytes from the least significant end, so point p at the + least significant word. */ + if (order == 1) + { + p += size * (count - 1); + word_step = - word_step; + } + + /* And at least significant byte of that word. */ + if (endian == 1) + p += (size - 1); + + rn = (size * count + sizeof(mp_limb_t) - 1) / sizeof(mp_limb_t); + rp = MPZ_REALLOC (r, rn); + + for (limb = 0, bytes = 0, i = 0; count > 0; count--, p += word_step) + { + size_t j; + for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) + { + limb |= (mp_limb_t) *p << (bytes++ * CHAR_BIT); + if (bytes == sizeof(mp_limb_t)) + { + rp[i++] = limb; + bytes = 0; + limb = 0; + } + } + } + assert (i + (bytes > 0) == rn); + if (limb != 0) + rp[i++] = limb; + else + i = mpn_normalized_size (rp, i); + + r->_mp_size = i; +} + +void * +mpz_export (void *r, size_t *countp, int order, size_t size, int endian, + size_t nails, const mpz_t u) +{ + size_t count; + mp_size_t un; + + if (nails != 0) + gmp_die ("mpz_import: Nails not supported."); + + assert (order == 1 || order == -1); + assert (endian >= -1 && endian <= 1); + assert (size > 0 || u->_mp_size == 0); + + un = u->_mp_size; + count = 0; + if (un != 0) + { + size_t k; + unsigned char *p; + ptrdiff_t word_step; + /* The current (partial) limb. */ + mp_limb_t limb; + /* The number of bytes left to to in this limb. */ + size_t bytes; + /* The index where the limb was read. */ + mp_size_t i; + + un = GMP_ABS (un); + + /* Count bytes in top limb. */ + limb = u->_mp_d[un-1]; + assert (limb != 0); + + k = 0; + do { + k++; limb >>= CHAR_BIT; + } while (limb != 0); + + count = (k + (un-1) * sizeof (mp_limb_t) + size - 1) / size; + + if (!r) + r = gmp_xalloc (count * size); + + if (endian == 0) + endian = gmp_detect_endian (); + + p = (unsigned char *) r; + + word_step = (order != endian) ? 2 * size : 0; + + /* Process bytes from the least significant end, so point p at the + least significant word. */ + if (order == 1) + { + p += size * (count - 1); + word_step = - word_step; + } + + /* And at least significant byte of that word. */ + if (endian == 1) + p += (size - 1); + + for (bytes = 0, i = 0, k = 0; k < count; k++, p += word_step) + { + size_t j; + for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) + { + if (bytes == 0) + { + if (i < un) + limb = u->_mp_d[i++]; + bytes = sizeof (mp_limb_t); + } + *p = limb; + limb >>= CHAR_BIT; + bytes--; + } + } + assert (i == un); + assert (k == count); + } + + if (countp) + *countp = count; + + return r; +} diff --git a/src/mini-gmp.h b/src/mini-gmp.h new file mode 100644 index 00000000000..27e0c0671a2 --- /dev/null +++ b/src/mini-gmp.h @@ -0,0 +1,300 @@ +/* mini-gmp, a minimalistic implementation of a GNU GMP subset. + +Copyright 2011-2015, 2017 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of either: + + * the GNU Lesser General Public License as published by the Free + Software Foundation; either version 3 of the License, or (at your + option) any later version. + +or + + * the GNU General Public License as published by the Free Software + Foundation; either version 2 of the License, or (at your option) any + later version. + +or both in parallel, as here. + +The GNU MP Library 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 copies of the GNU General Public License and the +GNU Lesser General Public License along with the GNU MP Library. If not, +see https://www.gnu.org/licenses/. */ + +/* About mini-gmp: This is a minimal implementation of a subset of the + GMP interface. It is intended for inclusion into applications which + have modest bignums needs, as a fallback when the real GMP library + is not installed. + + This file defines the public interface. */ + +#ifndef __MINI_GMP_H__ +#define __MINI_GMP_H__ + +/* For size_t */ +#include <stddef.h> + +#if defined (__cplusplus) +extern "C" { +#endif + +void mp_set_memory_functions (void *(*) (size_t), + void *(*) (void *, size_t, size_t), + void (*) (void *, size_t)); + +void mp_get_memory_functions (void *(**) (size_t), + void *(**) (void *, size_t, size_t), + void (**) (void *, size_t)); + +typedef unsigned long mp_limb_t; +typedef long mp_size_t; +typedef unsigned long mp_bitcnt_t; + +typedef mp_limb_t *mp_ptr; +typedef const mp_limb_t *mp_srcptr; + +typedef struct +{ + int _mp_alloc; /* Number of *limbs* allocated and pointed + to by the _mp_d field. */ + int _mp_size; /* abs(_mp_size) is the number of limbs the + last field points to. If _mp_size is + negative this is a negative number. */ + mp_limb_t *_mp_d; /* Pointer to the limbs. */ +} __mpz_struct; + +typedef __mpz_struct mpz_t[1]; + +typedef __mpz_struct *mpz_ptr; +typedef const __mpz_struct *mpz_srcptr; + +extern const int mp_bits_per_limb; + +void mpn_copyi (mp_ptr, mp_srcptr, mp_size_t); +void mpn_copyd (mp_ptr, mp_srcptr, mp_size_t); +void mpn_zero (mp_ptr, mp_size_t); + +int mpn_cmp (mp_srcptr, mp_srcptr, mp_size_t); +int mpn_zero_p (mp_srcptr, mp_size_t); + +mp_limb_t mpn_add_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_add_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_add (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); + +mp_limb_t mpn_sub_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_sub_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_sub (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); + +mp_limb_t mpn_mul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_addmul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_submul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); + +mp_limb_t mpn_mul (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); +void mpn_mul_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +void mpn_sqr (mp_ptr, mp_srcptr, mp_size_t); +int mpn_perfect_square_p (mp_srcptr, mp_size_t); +mp_size_t mpn_sqrtrem (mp_ptr, mp_ptr, mp_srcptr, mp_size_t); + +mp_limb_t mpn_lshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); +mp_limb_t mpn_rshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); + +mp_bitcnt_t mpn_scan0 (mp_srcptr, mp_bitcnt_t); +mp_bitcnt_t mpn_scan1 (mp_srcptr, mp_bitcnt_t); + +void mpn_com (mp_ptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_neg (mp_ptr, mp_srcptr, mp_size_t); + +mp_bitcnt_t mpn_popcount (mp_srcptr, mp_size_t); + +mp_limb_t mpn_invert_3by2 (mp_limb_t, mp_limb_t); +#define mpn_invert_limb(x) mpn_invert_3by2 ((x), 0) + +size_t mpn_get_str (unsigned char *, int, mp_ptr, mp_size_t); +mp_size_t mpn_set_str (mp_ptr, const unsigned char *, size_t, int); + +void mpz_init (mpz_t); +void mpz_init2 (mpz_t, mp_bitcnt_t); +void mpz_clear (mpz_t); + +#define mpz_odd_p(z) (((z)->_mp_size != 0) & (int) (z)->_mp_d[0]) +#define mpz_even_p(z) (! mpz_odd_p (z)) + +int mpz_sgn (const mpz_t); +int mpz_cmp_si (const mpz_t, long); +int mpz_cmp_ui (const mpz_t, unsigned long); +int mpz_cmp (const mpz_t, const mpz_t); +int mpz_cmpabs_ui (const mpz_t, unsigned long); +int mpz_cmpabs (const mpz_t, const mpz_t); +int mpz_cmp_d (const mpz_t, double); +int mpz_cmpabs_d (const mpz_t, double); + +void mpz_abs (mpz_t, const mpz_t); +void mpz_neg (mpz_t, const mpz_t); +void mpz_swap (mpz_t, mpz_t); + +void mpz_add_ui (mpz_t, const mpz_t, unsigned long); +void mpz_add (mpz_t, const mpz_t, const mpz_t); +void mpz_sub_ui (mpz_t, const mpz_t, unsigned long); +void mpz_ui_sub (mpz_t, unsigned long, const mpz_t); +void mpz_sub (mpz_t, const mpz_t, const mpz_t); + +void mpz_mul_si (mpz_t, const mpz_t, long int); +void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int); +void mpz_mul (mpz_t, const mpz_t, const mpz_t); +void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_addmul_ui (mpz_t, const mpz_t, unsigned long int); +void mpz_addmul (mpz_t, const mpz_t, const mpz_t); +void mpz_submul_ui (mpz_t, const mpz_t, unsigned long int); +void mpz_submul (mpz_t, const mpz_t, const mpz_t); + +void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_cdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_cdiv_r (mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_r (mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_r (mpz_t, const mpz_t, const mpz_t); + +void mpz_cdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_fdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_tdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_cdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_fdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_tdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); + +void mpz_mod (mpz_t, const mpz_t, const mpz_t); + +void mpz_divexact (mpz_t, const mpz_t, const mpz_t); + +int mpz_divisible_p (const mpz_t, const mpz_t); +int mpz_congruent_p (const mpz_t, const mpz_t, const mpz_t); + +unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_ui (const mpz_t, unsigned long); +unsigned long mpz_fdiv_ui (const mpz_t, unsigned long); +unsigned long mpz_tdiv_ui (const mpz_t, unsigned long); + +unsigned long mpz_mod_ui (mpz_t, const mpz_t, unsigned long); + +void mpz_divexact_ui (mpz_t, const mpz_t, unsigned long); + +int mpz_divisible_ui_p (const mpz_t, unsigned long); + +unsigned long mpz_gcd_ui (mpz_t, const mpz_t, unsigned long); +void mpz_gcd (mpz_t, const mpz_t, const mpz_t); +void mpz_gcdext (mpz_t, mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_lcm_ui (mpz_t, const mpz_t, unsigned long); +void mpz_lcm (mpz_t, const mpz_t, const mpz_t); +int mpz_invert (mpz_t, const mpz_t, const mpz_t); + +void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t); +void mpz_sqrt (mpz_t, const mpz_t); +int mpz_perfect_square_p (const mpz_t); + +void mpz_pow_ui (mpz_t, const mpz_t, unsigned long); +void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long); +void mpz_powm (mpz_t, const mpz_t, const mpz_t, const mpz_t); +void mpz_powm_ui (mpz_t, const mpz_t, unsigned long, const mpz_t); + +void mpz_rootrem (mpz_t, mpz_t, const mpz_t, unsigned long); +int mpz_root (mpz_t, const mpz_t, unsigned long); + +void mpz_fac_ui (mpz_t, unsigned long); +void mpz_2fac_ui (mpz_t, unsigned long); +void mpz_mfac_uiui (mpz_t, unsigned long, unsigned long); +void mpz_bin_uiui (mpz_t, unsigned long, unsigned long); + +int mpz_probab_prime_p (const mpz_t, int); + +int mpz_tstbit (const mpz_t, mp_bitcnt_t); +void mpz_setbit (mpz_t, mp_bitcnt_t); +void mpz_clrbit (mpz_t, mp_bitcnt_t); +void mpz_combit (mpz_t, mp_bitcnt_t); + +void mpz_com (mpz_t, const mpz_t); +void mpz_and (mpz_t, const mpz_t, const mpz_t); +void mpz_ior (mpz_t, const mpz_t, const mpz_t); +void mpz_xor (mpz_t, const mpz_t, const mpz_t); + +mp_bitcnt_t mpz_popcount (const mpz_t); +mp_bitcnt_t mpz_hamdist (const mpz_t, const mpz_t); +mp_bitcnt_t mpz_scan0 (const mpz_t, mp_bitcnt_t); +mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t); + +int mpz_fits_slong_p (const mpz_t); +int mpz_fits_ulong_p (const mpz_t); +long int mpz_get_si (const mpz_t); +unsigned long int mpz_get_ui (const mpz_t); +double mpz_get_d (const mpz_t); +size_t mpz_size (const mpz_t); +mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t); + +void mpz_realloc2 (mpz_t, mp_bitcnt_t); +mp_srcptr mpz_limbs_read (mpz_srcptr); +mp_ptr mpz_limbs_modify (mpz_t, mp_size_t); +mp_ptr mpz_limbs_write (mpz_t, mp_size_t); +void mpz_limbs_finish (mpz_t, mp_size_t); +mpz_srcptr mpz_roinit_n (mpz_t, mp_srcptr, mp_size_t); + +#define MPZ_ROINIT_N(xp, xs) {{0, (xs),(xp) }} + +void mpz_set_si (mpz_t, signed long int); +void mpz_set_ui (mpz_t, unsigned long int); +void mpz_set (mpz_t, const mpz_t); +void mpz_set_d (mpz_t, double); + +void mpz_init_set_si (mpz_t, signed long int); +void mpz_init_set_ui (mpz_t, unsigned long int); +void mpz_init_set (mpz_t, const mpz_t); +void mpz_init_set_d (mpz_t, double); + +size_t mpz_sizeinbase (const mpz_t, int); +char *mpz_get_str (char *, int, const mpz_t); +int mpz_set_str (mpz_t, const char *, int); +int mpz_init_set_str (mpz_t, const char *, int); + +/* This long list taken from gmp.h. */ +/* For reference, "defined(EOF)" cannot be used here. In g++ 2.95.4, + <iostream> defines EOF but not FILE. */ +#if defined (FILE) \ + || defined (H_STDIO) \ + || defined (_H_STDIO) /* AIX */ \ + || defined (_STDIO_H) /* glibc, Sun, SCO */ \ + || defined (_STDIO_H_) /* BSD, OSF */ \ + || defined (__STDIO_H) /* Borland */ \ + || defined (__STDIO_H__) /* IRIX */ \ + || defined (_STDIO_INCLUDED) /* HPUX */ \ + || defined (__dj_include_stdio_h_) /* DJGPP */ \ + || defined (_FILE_DEFINED) /* Microsoft */ \ + || defined (__STDIO__) /* Apple MPW MrC */ \ + || defined (_MSL_STDIO_H) /* Metrowerks */ \ + || defined (_STDIO_H_INCLUDED) /* QNX4 */ \ + || defined (_ISO_STDIO_ISO_H) /* Sun C++ */ \ + || defined (__STDIO_LOADED) /* VMS */ +size_t mpz_out_str (FILE *, int, const mpz_t); +#endif + +void mpz_import (mpz_t, size_t, int, size_t, int, size_t, const void *); +void *mpz_export (void *, size_t *, int, size_t, int, size_t, const mpz_t); + +#if defined (__cplusplus) +} +#endif +#endif /* __MINI_GMP_H__ */ diff --git a/src/minibuf.c b/src/minibuf.c index e3510105d0f..8017da194b0 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -157,7 +157,7 @@ string_to_object (Lisp_Object val, Lisp_Object defalt) } expr_and_pos = Fread_from_string (val, Qnil, Qnil); - pos = XINT (Fcdr (expr_and_pos)); + pos = XFIXNUM (Fcdr (expr_and_pos)); if (pos != SCHARS (val)) { /* Ignore trailing whitespace; any other trailing junk @@ -181,12 +181,8 @@ string_to_object (Lisp_Object val, Lisp_Object defalt) from read_minibuf to do the job if noninteractive. */ static Lisp_Object -read_minibuf_noninteractive (Lisp_Object map, Lisp_Object initial, - Lisp_Object prompt, Lisp_Object backup_n, - bool expflag, - Lisp_Object histvar, Lisp_Object histpos, - Lisp_Object defalt, - bool allow_props, bool inherit_input_method) +read_minibuf_noninteractive (Lisp_Object prompt, bool expflag, + Lisp_Object defalt) { ptrdiff_t size, len; char *line; @@ -198,7 +194,7 @@ read_minibuf_noninteractive (Lisp_Object map, Lisp_Object initial, /* Check, whether we need to suppress echoing. */ if (CHARACTERP (Vread_hide_char)) - hide_char = XFASTINT (Vread_hide_char); + hide_char = XFIXNAT (Vread_hide_char); /* Manipulate tty. */ if (hide_char) @@ -291,7 +287,7 @@ Return (point-min) if current buffer is not a minibuffer. */) { /* This function is written to be most efficient when there's a prompt. */ Lisp_Object beg, end, tem; - beg = make_number (BEGV); + beg = make_fixnum (BEGV); tem = Fmemq (Fcurrent_buffer (), Vminibuffer_list); if (NILP (tem)) @@ -299,7 +295,7 @@ Return (point-min) if current buffer is not a minibuffer. */) end = Ffield_end (beg, Qnil, Qnil); - if (XINT (end) == ZV && NILP (Fget_char_property (beg, Qfield, Qnil))) + if (XFIXNUM (end) == ZV && NILP (Fget_char_property (beg, Qfield, Qnil))) return beg; else return end; @@ -311,7 +307,7 @@ DEFUN ("minibuffer-contents", Fminibuffer_contents, If the current buffer is not a minibuffer, return its entire contents. */) (void) { - ptrdiff_t prompt_end = XINT (Fminibuffer_prompt_end ()); + ptrdiff_t prompt_end = XFIXNUM (Fminibuffer_prompt_end ()); return make_buffer_string (prompt_end, ZV, 1); } @@ -321,23 +317,10 @@ DEFUN ("minibuffer-contents-no-properties", Fminibuffer_contents_no_properties, If the current buffer is not a minibuffer, return its entire contents. */) (void) { - ptrdiff_t prompt_end = XINT (Fminibuffer_prompt_end ()); + ptrdiff_t prompt_end = XFIXNUM (Fminibuffer_prompt_end ()); return make_buffer_string (prompt_end, ZV, 0); } -DEFUN ("minibuffer-completion-contents", Fminibuffer_completion_contents, - Sminibuffer_completion_contents, 0, 0, 0, - doc: /* Return the user input in a minibuffer before point as a string. -That is what completion commands operate on. -If the current buffer is not a minibuffer, return its entire contents. */) - (void) -{ - ptrdiff_t prompt_end = XINT (Fminibuffer_prompt_end ()); - if (PT < prompt_end) - error ("Cannot do completion in the prompt"); - return make_buffer_string (prompt_end, PT, 1); -} - /* Read from the minibuffer using keymap MAP and initial contents INITIAL, putting point minus BACKUP_N bytes from the end of INITIAL, @@ -406,13 +389,13 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, CHECK_STRING (initial); if (!NILP (backup_n)) { - CHECK_NUMBER (backup_n); + CHECK_FIXNUM (backup_n); /* Convert to distance from end of input. */ - if (XINT (backup_n) < 1) + if (XFIXNUM (backup_n) < 1) /* A number too small means the beginning of the string. */ pos = - SCHARS (initial); else - pos = XINT (backup_n) - 1 - SCHARS (initial); + pos = XFIXNUM (backup_n) - 1 - SCHARS (initial); } } else @@ -443,10 +426,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, || (IS_DAEMON && DAEMON_RUNNING)) && NILP (Vexecuting_kbd_macro)) { - val = read_minibuf_noninteractive (map, initial, prompt, - make_number (pos), - expflag, histvar, histpos, defalt, - allow_props, inherit_input_method); + val = read_minibuf_noninteractive (prompt, expflag, defalt); return unbind_to (count, val); } @@ -491,7 +471,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, minibuf_save_list)); minibuf_save_list = Fcons (minibuf_prompt, - Fcons (make_number (minibuf_prompt_width), + Fcons (make_fixnum (minibuf_prompt_width), Fcons (Vhelp_form, Fcons (Vcurrent_prefix_arg, Fcons (Vminibuffer_history_position, @@ -608,9 +588,6 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, XWINDOW (minibuf_window)->hscroll = 0; XWINDOW (minibuf_window)->suspend_auto_hscroll = 0; - Fmake_local_variable (Qprint_escape_newlines); - print_escape_newlines = 1; - /* Erase the buffer. */ { ptrdiff_t count1 = SPECPDL_INDEX (); @@ -626,11 +603,11 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, Finsert (1, &minibuf_prompt); if (PT > BEG) { - Fput_text_property (make_number (BEG), make_number (PT), + Fput_text_property (make_fixnum (BEG), make_fixnum (PT), Qfront_sticky, Qt, Qnil); - Fput_text_property (make_number (BEG), make_number (PT), + Fput_text_property (make_fixnum (BEG), make_fixnum (PT), Qrear_nonsticky, Qt, Qnil); - Fput_text_property (make_number (BEG), make_number (PT), + Fput_text_property (make_fixnum (BEG), make_fixnum (PT), Qfield, Qt, Qnil); if (CONSP (Vminibuffer_prompt_properties)) { @@ -649,10 +626,10 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, 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); + Fadd_face_text_property (make_fixnum (BEG), + make_fixnum (PT), val, Qt, Qnil); else - Fput_text_property (make_number (BEG), make_number (PT), + Fput_text_property (make_fixnum (BEG), make_fixnum (PT), key, val, Qnil); } } @@ -667,7 +644,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, if (!NILP (initial)) { Finsert (1, &initial); - Fforward_char (make_number (pos)); + Fforward_char (make_fixnum (pos)); } clear_message (1, 1); @@ -718,44 +695,8 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, histstring = Qnil; /* Add the value to the appropriate history list, if any. */ - if (!NILP (Vhistory_add_new_input) - && SYMBOLP (Vminibuffer_history_variable) - && !NILP (histstring)) - { - /* If the caller wanted to save the value read on a history list, - then do so if the value is not already the front of the list. */ - - /* The value of the history variable must be a cons or nil. Other - values are unacceptable. We silently ignore these values. */ - - if (NILP (histval) - || (CONSP (histval) - /* Don't duplicate the most recent entry in the history. */ - && (NILP (Fequal (histstring, Fcar (histval)))))) - { - Lisp_Object length; - - if (history_delete_duplicates) Fdelete (histstring, histval); - histval = Fcons (histstring, histval); - Fset (Vminibuffer_history_variable, histval); - - /* Truncate if requested. */ - length = Fget (Vminibuffer_history_variable, Qhistory_length); - if (NILP (length)) length = Vhistory_length; - if (INTEGERP (length)) - { - if (XINT (length) <= 0) - Fset (Vminibuffer_history_variable, Qnil); - else - { - Lisp_Object temp; - - temp = Fnthcdr (Fsub1 (length), histval); - if (CONSP (temp)) Fsetcdr (temp, Qnil); - } - } - } - } + if (! (NILP (Vhistory_add_new_input) || NILP (histstring))) + call2 (intern ("add-to-history"), Vminibuffer_history_variable, histstring); /* If Lisp form desired instead of string, parse it. */ if (expflag) @@ -773,7 +714,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, Lisp_Object get_minibuffer (EMACS_INT depth) { - Lisp_Object tail = Fnthcdr (make_number (depth), Vminibuffer_list); + Lisp_Object tail = Fnthcdr (make_fixnum (depth), Vminibuffer_list); if (NILP (tail)) { tail = list1 (Qnil); @@ -807,7 +748,7 @@ get_minibuffer (EMACS_INT depth) call0 (intern ("minibuffer-inactive-mode")); else Fkill_all_local_variables (); - unbind_to (count, Qnil); + buf = unbind_to (count, buf); } return buf; @@ -840,12 +781,12 @@ read_minibuf_unwind (void) /* Restore prompt, etc, from outer minibuffer level. */ Lisp_Object key_vec = Fcar (minibuf_save_list); eassert (VECTORP (key_vec)); - this_command_key_count = XFASTINT (Flength (key_vec)); + this_command_key_count = XFIXNAT (Flength (key_vec)); this_command_keys = key_vec; minibuf_save_list = Fcdr (minibuf_save_list); minibuf_prompt = Fcar (minibuf_save_list); minibuf_save_list = Fcdr (minibuf_save_list); - minibuf_prompt_width = XFASTINT (Fcar (minibuf_save_list)); + minibuf_prompt_width = XFIXNAT (Fcar (minibuf_save_list)); minibuf_save_list = Fcdr (minibuf_save_list); Vhelp_form = Fcar (minibuf_save_list); minibuf_save_list = Fcdr (minibuf_save_list); @@ -1047,7 +988,7 @@ the current input method and the setting of`enable-multibyte-characters'. */) { CHECK_STRING (prompt); return read_minibuf (Vminibuffer_local_ns_map, initial, prompt, - 0, Qminibuffer_history, make_number (0), Qnil, 0, + 0, Qminibuffer_history, make_fixnum (0), Qnil, 0, !NILP (inherit_input_method)); } @@ -1103,7 +1044,8 @@ A user option, or customizable variable, is one for which name = Fcompleting_read (prompt, Vobarray, Qcustom_variable_p, Qt, - Qnil, Qnil, default_string, Qnil); + Qnil, Qcustom_variable_history, + default_string, Qnil); if (NILP (name)) return name; return Fintern (name, Qnil); @@ -1246,7 +1188,7 @@ is used to further constrain the set of candidates. */) return call3 (collection, string, predicate, Qnil); bestmatch = bucket = Qnil; - zero = make_number (0); + zero = make_fixnum (0); /* If COLLECTION is not a list, set TAIL just for gc pro. */ tail = collection; @@ -1312,7 +1254,7 @@ is used to further constrain the set of candidates. */) if (STRINGP (eltstring) && SCHARS (string) <= SCHARS (eltstring) && (tem = Fcompare_strings (eltstring, zero, - make_number (SCHARS (string)), + make_fixnum (SCHARS (string)), string, zero, Qnil, completion_ignore_case ? Qt : Qnil), EQ (Qt, tem))) @@ -1325,11 +1267,12 @@ is used to further constrain the set of candidates. */) for (regexps = Vcompletion_regexp_list; CONSP (regexps); regexps = XCDR (regexps)) { - if (bindcount < 0) { - bindcount = SPECPDL_INDEX (); - specbind (Qcase_fold_search, - completion_ignore_case ? Qt : Qnil); - } + if (bindcount < 0) + { + bindcount = SPECPDL_INDEX (); + specbind (Qcase_fold_search, + completion_ignore_case ? Qt : Qnil); + } tem = Fstring_match (XCAR (regexps), eltstring, zero); if (NILP (tem)) break; @@ -1373,11 +1316,11 @@ is used to further constrain the set of candidates. */) { compare = min (bestmatchsize, SCHARS (eltstring)); tem = Fcompare_strings (bestmatch, zero, - make_number (compare), + make_fixnum (compare), eltstring, zero, - make_number (compare), + make_fixnum (compare), completion_ignore_case ? Qt : Qnil); - matchsize = EQ (tem, Qt) ? compare : eabs (XINT (tem)) - 1; + matchsize = EQ (tem, Qt) ? compare : eabs (XFIXNUM (tem)) - 1; if (completion_ignore_case) { @@ -1398,13 +1341,13 @@ is used to further constrain the set of candidates. */) == (matchsize == SCHARS (bestmatch)) && (tem = Fcompare_strings (eltstring, zero, - make_number (SCHARS (string)), + make_fixnum (SCHARS (string)), string, zero, Qnil, Qnil), EQ (Qt, tem)) && (tem = Fcompare_strings (bestmatch, zero, - make_number (SCHARS (string)), + make_fixnum (SCHARS (string)), string, zero, Qnil, Qnil), @@ -1428,10 +1371,8 @@ is used to further constrain the set of candidates. */) } } - if (bindcount >= 0) { + if (bindcount >= 0) unbind_to (bindcount, Qnil); - bindcount = -1; - } if (NILP (bestmatch)) return Qnil; /* No completions found. */ @@ -1499,7 +1440,7 @@ with a space are ignored unless STRING itself starts with a space. */) if (type == 0) return call3 (collection, string, predicate, Qt); allmatches = bucket = Qnil; - zero = make_number (0); + zero = make_fixnum (0); /* If COLLECTION is not a list, set TAIL just for gc pro. */ tail = collection; @@ -1571,9 +1512,9 @@ with a space are ignored unless STRING itself starts with a space. */) && SREF (string, 0) == ' ') || SREF (eltstring, 0) != ' ') && (tem = Fcompare_strings (eltstring, zero, - make_number (SCHARS (string)), + make_fixnum (SCHARS (string)), string, zero, - make_number (SCHARS (string)), + make_fixnum (SCHARS (string)), completion_ignore_case ? Qt : Qnil), EQ (Qt, tem))) { @@ -1585,11 +1526,12 @@ with a space are ignored unless STRING itself starts with a space. */) for (regexps = Vcompletion_regexp_list; CONSP (regexps); regexps = XCDR (regexps)) { - if (bindcount < 0) { - bindcount = SPECPDL_INDEX (); - specbind (Qcase_fold_search, - completion_ignore_case ? Qt : Qnil); - } + if (bindcount < 0) + { + bindcount = SPECPDL_INDEX (); + specbind (Qcase_fold_search, + completion_ignore_case ? Qt : Qnil); + } tem = Fstring_match (XCAR (regexps), eltstring, zero); if (NILP (tem)) break; @@ -1607,10 +1549,11 @@ with a space are ignored unless STRING itself starts with a space. */) tem = Fcommandp (elt, Qnil); else { - if (bindcount >= 0) { - unbind_to (bindcount, Qnil); - bindcount = -1; - } + if (bindcount >= 0) + { + unbind_to (bindcount, Qnil); + bindcount = -1; + } tem = type == 3 ? call2 (predicate, elt, HASH_VALUE (XHASH_TABLE (collection), idx - 1)) @@ -1623,10 +1566,8 @@ with a space are ignored unless STRING itself starts with a space. */) } } - if (bindcount >= 0) { + if (bindcount >= 0) unbind_to (bindcount, Qnil); - bindcount = -1; - } return Fnreverse (allmatches); } @@ -1746,9 +1687,9 @@ the values STRING, PREDICATE and `lambda'. */) if (SYMBOLP (tail)) while (1) { - if (EQ (Fcompare_strings (string, make_number (0), Qnil, + if (EQ (Fcompare_strings (string, make_fixnum (0), Qnil, Fsymbol_name (tail), - make_number (0) , Qnil, Qt), + make_fixnum (0) , Qnil, Qt), Qt)) { tem = tail; @@ -1891,8 +1832,8 @@ single string, rather than a cons cell whose car is a string. */) thiscar = Fsymbol_name (thiscar); else if (!STRINGP (thiscar)) continue; - tem = Fcompare_strings (thiscar, make_number (0), Qnil, - key, make_number (0), Qnil, + tem = Fcompare_strings (thiscar, make_fixnum (0), Qnil, + key, make_fixnum (0), Qnil, case_fold); if (EQ (tem, Qt)) return elt; @@ -1906,7 +1847,7 @@ DEFUN ("minibuffer-depth", Fminibuffer_depth, Sminibuffer_depth, 0, 0, 0, doc: /* Return current depth of activations of minibuffer, a nonnegative integer. */) (void) { - return make_number (minibuf_level); + return make_fixnum (minibuf_level); } DEFUN ("minibuffer-prompt", Fminibuffer_prompt, Sminibuffer_prompt, 0, 0, 0, @@ -1944,6 +1885,9 @@ syms_of_minibuf (void) staticpro (&last_minibuf_string); last_minibuf_string = Qnil; + DEFSYM (Qcustom_variable_history, "custom-variable-history"); + Fset (Qcustom_variable_history, Qnil); + DEFSYM (Qminibuffer_history, "minibuffer-history"); DEFSYM (Qbuffer_name_history, "buffer-name-history"); Fset (Qbuffer_name_history, Qnil); @@ -2130,7 +2074,6 @@ uses to hide passwords. */); defsubr (&Sminibuffer_prompt_end); defsubr (&Sminibuffer_contents); defsubr (&Sminibuffer_contents_no_properties); - defsubr (&Sminibuffer_completion_contents); defsubr (&Stry_completion); defsubr (&Sall_completions); diff --git a/src/msdos.c b/src/msdos.c index 3645dc8bb30..7dd5f5747aa 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -223,8 +223,8 @@ them. This happens with wheeled mice on Windows 9X, for example. */) { int n; - CHECK_NUMBER (nbuttons); - n = XINT (nbuttons); + CHECK_FIXNUM (nbuttons); + n = XFIXNUM (nbuttons); if (n < 2 || n > 3) xsignal2 (Qargs_out_of_range, build_string ("only 2 or 3 mouse buttons are supported"), @@ -322,8 +322,8 @@ mouse_get_pos (struct frame **f, int insist, Lisp_Object *bar_window, *bar_window = Qnil; mouse_get_xy (&ix, &iy); *time = event_timestamp (); - *x = make_number (mouse_last_x = ix); - *y = make_number (mouse_last_y = iy); + *x = make_fixnum (mouse_last_x = ix); + *y = make_fixnum (mouse_last_y = iy); } static void @@ -539,8 +539,8 @@ dos_set_window_size (int *rows, int *cols) (video_name, "screen-dimensions-%dx%d", *rows, *cols), Qnil)); - if (INTEGERP (video_mode) - && (video_mode_value = XINT (video_mode)) > 0) + if (FIXNUMP (video_mode) + && (video_mode_value = XFIXNUM (video_mode)) > 0) { regs.x.ax = video_mode_value; int86 (0x10, ®s, ®s); @@ -742,21 +742,21 @@ IT_set_cursor_type (struct frame *f, Lisp_Object cursor_type) Lisp_Object bar_parms = XCDR (cursor_type); int width; - if (INTEGERP (bar_parms)) + if (FIXNUMP (bar_parms)) { /* Feature: negative WIDTH means cursor at the top of the character cell, zero means invisible cursor. */ - width = XINT (bar_parms); + width = XFIXNUM (bar_parms); msdos_set_cursor_shape (f, width >= 0 ? DEFAULT_CURSOR_START : 0, width); } else if (CONSP (bar_parms) - && INTEGERP (XCAR (bar_parms)) - && INTEGERP (XCDR (bar_parms))) + && FIXNUMP (XCAR (bar_parms)) + && FIXNUMP (XCDR (bar_parms))) { - int start_line = XINT (XCDR (bar_parms)); + int start_line = XFIXNUM (XCDR (bar_parms)); - width = XINT (XCAR (bar_parms)); + width = XFIXNUM (XCAR (bar_parms)); msdos_set_cursor_shape (f, start_line, width); } } @@ -1321,7 +1321,7 @@ IT_frame_up_to_date (struct frame *f) if (EQ (BVAR (b,cursor_type), Qt)) new_cursor = frame_desired_cursor; else if (NILP (BVAR (b, cursor_type))) /* nil means no cursor */ - new_cursor = Fcons (Qbar, make_number (0)); + new_cursor = Fcons (Qbar, make_fixnum (0)); else new_cursor = BVAR (b, cursor_type); } @@ -1564,7 +1564,7 @@ void IT_set_frame_parameters (struct frame *f, Lisp_Object alist) { Lisp_Object tail; - int i, j, length = XINT (Flength (alist)); + int i, j, length = XFIXNUM (Flength (alist)); Lisp_Object *parms = (Lisp_Object *) alloca (length * word_size); Lisp_Object *values @@ -1791,7 +1791,7 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_number (26); /* RE Emacs version */ + Vwindow_system_version = make_fixnum (27); /* RE Emacs version */ tty->terminal->type = output_msdos_raw; /* If Emacs was dumped on DOS/V machine, forget the stale VRAM @@ -2423,11 +2423,11 @@ dos_rawgetc (void) sc = regs.h.ah; total_doskeys += 2; - ASET (recent_doskeys, recent_doskeys_index, make_number (c)); + ASET (recent_doskeys, recent_doskeys_index, make_fixnum (c)); recent_doskeys_index++; if (recent_doskeys_index == NUM_RECENT_DOSKEYS) recent_doskeys_index = 0; - ASET (recent_doskeys, recent_doskeys_index, make_number (sc)); + ASET (recent_doskeys, recent_doskeys_index, make_fixnum (sc)); recent_doskeys_index++; if (recent_doskeys_index == NUM_RECENT_DOSKEYS) recent_doskeys_index = 0; @@ -2609,7 +2609,7 @@ dos_rawgetc (void) if (code == 0) continue; - if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)) + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)) { clear_mouse_face (hlinfo); hlinfo->mouse_face_hidden = 1; @@ -2718,8 +2718,8 @@ dos_rawgetc (void) event.code = button_num; event.modifiers = dos_get_modifiers (0) | (press ? down_modifier : up_modifier); - event.x = make_number (x); - event.y = make_number (y); + event.x = make_fixnum (x); + event.y = make_fixnum (y); event.frame_or_window = selected_frame; event.arg = Qnil; event.timestamp = event_timestamp (); @@ -3063,15 +3063,15 @@ XMenuActivate (Display *foo, XMenu *menu, int *pane, int *selidx, state = alloca (menu->panecount * sizeof (struct IT_menu_state)); screensize = screen_size * 2; faces[0] - = lookup_derived_face (sf, intern ("msdos-menu-passive-face"), + = lookup_derived_face (NULL, sf, intern ("msdos-menu-passive-face"), DEFAULT_FACE_ID, 1); faces[1] - = lookup_derived_face (sf, intern ("msdos-menu-active-face"), + = lookup_derived_face (NULL, sf, intern ("msdos-menu-active-face"), DEFAULT_FACE_ID, 1); selectface = intern ("msdos-menu-select-face"); - faces[2] = lookup_derived_face (sf, selectface, + faces[2] = lookup_derived_face (NULL, sf, selectface, faces[0], 1); - faces[3] = lookup_derived_face (sf, selectface, + faces[3] = lookup_derived_face (NULL, sf, selectface, faces[1], 1); /* Make sure the menu title is always displayed with @@ -4196,7 +4196,7 @@ msdos_fatal_signal (int sig) void syms_of_msdos (void) { - recent_doskeys = Fmake_vector (make_number (NUM_RECENT_DOSKEYS), Qnil); + recent_doskeys = Fmake_vector (make_fixnum (NUM_RECENT_DOSKEYS), Qnil); staticpro (&recent_doskeys); #ifndef HAVE_X_WINDOWS @@ -4207,7 +4207,7 @@ syms_of_msdos (void) DEFVAR_LISP ("dos-unsupported-char-glyph", Vdos_unsupported_char_glyph, doc: /* Glyph to display instead of chars not supported by current codepage. This variable is used only by MS-DOS terminals. */); - Vdos_unsupported_char_glyph = make_number ('\177'); + Vdos_unsupported_char_glyph = make_fixnum ('\177'); #endif diff --git a/src/nsfns.m b/src/nsfns.m index 59798d3bddc..887d6b10aa5 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -27,7 +27,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) */ /* This should be the first include, as it may set up #defines affecting - interpretation of even the system includes. */ + interpretation of even the system includes. */ #include <config.h> #include <math.h> @@ -54,14 +54,13 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) static EmacsTooltip *ns_tooltip = nil; -/* Static variables to handle applescript execution. */ +/* Static variables to handle AppleScript execution. */ static Lisp_Object as_script, *as_result; 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 *); /* ========================================================================== @@ -117,7 +116,7 @@ ns_get_window (Lisp_Object maybeFrame) id view =nil, window =nil; if (!FRAMEP (maybeFrame) || !FRAME_NS_P (XFRAME (maybeFrame))) - maybeFrame = selected_frame;/*wrong_type_argument (Qframep, maybeFrame); */ + maybeFrame = selected_frame; /* wrong_type_argument (Qframep, maybeFrame); */ if (!NILP (maybeFrame)) view = FRAME_NS_VIEW (XFRAME (maybeFrame)); @@ -179,7 +178,7 @@ ns_directory_from_panel (NSSavePanel *panel) static Lisp_Object interpret_services_menu (NSMenu *menu, Lisp_Object prefix, Lisp_Object old) /* -------------------------------------------------------------------------- - Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side + Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side. -------------------------------------------------------------------------- */ { int i, count; @@ -210,7 +209,7 @@ interpret_services_menu (NSMenu *menu, Lisp_Object prefix, Lisp_Object old) if (keys && [keys length] ) { key = [keys characterAtIndex: 0]; - res = make_number (key|super_modifier); + res = make_fixnum (key|super_modifier); } else { @@ -262,7 +261,7 @@ x_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (FRAME_NS_VIEW (f)) { update_face_from_frame_parameter (f, Qforeground_color, arg); - /*recompute_basic_faces (f); */ + /* recompute_basic_faces (f); */ if (FRAME_VISIBLE_P (f)) SET_FRAME_GARBAGED (f); } @@ -286,8 +285,9 @@ x_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) error ("Unknown color"); } - /* clear the frame; in some instances the NS-internal GC appears not to - update, or it does update and cannot clear old text properly */ + /* Clear the frame; in some instances the NS-internal GC appears not + to update, or it does update and cannot clear old text + properly. */ if (FRAME_VISIBLE_P (f)) ns_clear_frame (f); @@ -357,13 +357,13 @@ x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) NSView *view = FRAME_NS_VIEW (f); NSTRACE ("x_set_icon_name"); - /* see if it's changed */ + /* See if it's changed. */ if (STRINGP (arg)) { if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt)) return; } - else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil)) + else if (!STRINGP (oldval) && NILP (oldval) == NILP (arg)) return; fset_icon_name (f, arg); @@ -463,6 +463,47 @@ ns_set_name (struct frame *f, Lisp_Object name, int explicit) ns_set_name_internal (f, name); } +static void +ns_set_represented_filename (struct frame *f) +{ + Lisp_Object filename, encoded_filename; + Lisp_Object buf = XWINDOW (f->selected_window)->contents; + NSAutoreleasePool *pool; + NSString *fstr; + NSView *view = FRAME_NS_VIEW (f); + + NSTRACE ("ns_set_represented_filename"); + + if (f->explicit_name || ! NILP (f->title)) + return; + + block_input (); + pool = [[NSAutoreleasePool alloc] init]; + filename = BVAR (XBUFFER (buf), filename); + + if (! NILP (filename)) + { + encoded_filename = ENCODE_UTF_8 (filename); + + fstr = [NSString stringWithUTF8String: SSDATA (encoded_filename)]; + if (fstr == nil) fstr = @""; + } + else + fstr = @""; + +#ifdef NS_IMPL_COCOA + /* Work around a bug observed on 10.3 and later where + setTitleWithRepresentedFilename does not clear out previous state + if given filename does not exist. */ + if (! [[NSFileManager defaultManager] fileExistsAtPath: fstr]) + [[view window] setRepresentedFilename: @""]; +#endif + [[view window] setRepresentedFilename: fstr]; + + [pool release]; + unblock_input (); +} + /* This function should be called when the user's lisp code has specified a name for the frame; the name will override any set by the @@ -483,17 +524,10 @@ x_implicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { NSTRACE ("x_implicitly_set_name"); - Lisp_Object frame_title = buffer_local_value - (Qframe_title_format, XWINDOW (f->selected_window)->contents); - Lisp_Object icon_title = buffer_local_value - (Qicon_title_format, XWINDOW (f->selected_window)->contents); + if (ns_use_proxy_icon) + ns_set_represented_filename (f); - /* Deal with NS specific format t. */ - if (FRAME_NS_P (f) && ((FRAME_ICONIFIED_P (f) && EQ (icon_title, Qt)) - || EQ (frame_title, Qt))) - ns_set_name_as_filename (f); - else - ns_set_name (f, arg, 0); + ns_set_name (f, arg, 0); } @@ -520,78 +554,6 @@ x_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name) ns_set_name_internal (f, name); } - -static void -ns_set_name_as_filename (struct frame *f) -{ - NSView *view; - Lisp_Object name, filename; - Lisp_Object buf = XWINDOW (f->selected_window)->contents; - const char *title; - NSAutoreleasePool *pool; - Lisp_Object encoded_name, encoded_filename; - NSString *str; - NSTRACE ("ns_set_name_as_filename"); - - if (f->explicit_name || ! NILP (f->title)) - return; - - block_input (); - pool = [[NSAutoreleasePool alloc] init]; - filename = BVAR (XBUFFER (buf), filename); - name = BVAR (XBUFFER (buf), name); - - if (NILP (name)) - { - if (! NILP (filename)) - name = Ffile_name_nondirectory (filename); - else - name = build_string ([ns_app_name UTF8String]); - } - - encoded_name = ENCODE_UTF_8 (name); - - view = FRAME_NS_VIEW (f); - - title = FRAME_ICONIFIED_P (f) ? [[[view window] miniwindowTitle] UTF8String] - : [[[view window] title] UTF8String]; - - if (title && (! strcmp (title, SSDATA (encoded_name)))) - { - [pool release]; - unblock_input (); - return; - } - - str = [NSString stringWithUTF8String: SSDATA (encoded_name)]; - if (str == nil) str = @"Bad coding"; - - if (FRAME_ICONIFIED_P (f)) - [[view window] setMiniwindowTitle: str]; - else - { - NSString *fstr; - - if (! NILP (filename)) - { - encoded_filename = ENCODE_UTF_8 (filename); - - fstr = [NSString stringWithUTF8String: SSDATA (encoded_filename)]; - if (fstr == nil) fstr = @""; - } - else - fstr = @""; - - ns_set_represented_filename (fstr, f); - [[view window] setTitle: str]; - fset_name (f, name); - } - - [pool release]; - unblock_input (); -} - - void ns_set_doc_edited (void) { @@ -627,8 +589,8 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) if (FRAME_MINIBUF_ONLY_P (f)) return; - if (TYPE_RANGED_INTEGERP (int, value)) - nlines = XINT (value); + if (TYPE_RANGED_FIXNUMP (int, value)) + nlines = XFIXNUM (value); else nlines = 0; @@ -636,14 +598,14 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) if (nlines) { FRAME_EXTERNAL_MENU_BAR (f) = 1; - /* does for all frames, whereas we just want for one frame + /* Does for all frames, whereas we just want for one frame [NSMenu setMenuBarVisible: YES]; */ } else { if (FRAME_EXTERNAL_MENU_BAR (f) == 1) free_frame_menubar (f); - /* [NSMenu setMenuBarVisible: NO]; */ + /* [NSMenu setMenuBarVisible: NO]; */ FRAME_EXTERNAL_MENU_BAR (f) = 0; } } @@ -653,11 +615,11 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) 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. + /* Currently, when the tool bar changes state, the frame is resized. TODO: It would be better if this didn't occur when 1) the frame is full height or maximized or 2) when specified by - `frame-inhibit-implied-resize'. */ + `frame-inhibit-implied-resize'. */ int nlines; NSTRACE ("x_set_tool_bar_lines"); @@ -665,8 +627,8 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) if (FRAME_MINIBUF_ONLY_P (f)) return; - if (RANGED_INTEGERP (0, value, INT_MAX)) - nlines = XFASTINT (value); + if (RANGED_FIXNUMP (0, value, INT_MAX)) + nlines = XFIXNAT (value); else nlines = 0; @@ -724,7 +686,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva int old_width = FRAME_INTERNAL_BORDER_WIDTH (f); CHECK_TYPE_RANGED_INTEGER (int, arg); - f->internal_border_width = XINT (arg); + f->internal_border_width = XFIXNUM (arg); if (FRAME_INTERNAL_BORDER_WIDTH (f) < 0) f->internal_border_width = 0; @@ -774,7 +736,7 @@ ns_implicitly_set_icon_type (struct frame *f) chain = XCDR (chain)) { elt = XCAR (chain); - /* special case: t means go by file type */ + /* Special case: t means go by file type. */ if (SYMBOLP (elt) && EQ (elt, Qt) && SSDATA (f->name)[0] == '/') { NSString *str @@ -824,7 +786,7 @@ x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) store_frame_param (f, Qicon_type, arg); } - /* do it the implicit way */ + /* Do it the implicit way. */ if (NILP (arg)) { ns_implicitly_set_icon_type (f); @@ -860,7 +822,7 @@ x_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) static void x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - /* don't think we can do this on Nextstep */ + /* Don't think we can do this on Nextstep. */ } @@ -889,7 +851,7 @@ ns_appkit_version_str (void) /* This is for use by x-server-version and collapses all version info we have into a single int. For a better picture of the implementation - running, use ns_appkit_version_str.*/ + running, use ns_appkit_version_str. */ static int ns_appkit_version_int (void) { @@ -922,17 +884,18 @@ x_icon (struct frame *f, Lisp_Object parms) icon_y = x_get_arg (dpyinfo, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER); if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound)) { - CHECK_NUMBER (icon_x); - CHECK_NUMBER (icon_y); - f->output_data.ns->icon_top = XINT (icon_y); - f->output_data.ns->icon_left = XINT (icon_x); + CHECK_FIXNUM (icon_x); + CHECK_FIXNUM (icon_y); + f->output_data.ns->icon_top = XFIXNUM (icon_y); + f->output_data.ns->icon_left = XFIXNUM (icon_x); } else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound)) error ("Both left and top icon corners of icon must be specified"); } -/* Note: see frame.c for template, also where generic functions are impl */ +/* Note: see frame.c for template, also where generic functions are + implemented. */ frame_parm_handler ns_frame_parm_handlers[] = { x_set_autoraise, /* generic OK */ @@ -976,7 +939,7 @@ frame_parm_handler ns_frame_parm_handlers[] = #ifdef NS_IMPL_COCOA x_set_undecorated, #else - 0, /*x_set_undecorated */ + 0, /* x_set_undecorated */ #endif x_set_parent_frame, 0, /* x_set_skip_taskbar */ @@ -1078,15 +1041,7 @@ get_geometry_from_preferences (struct ns_display_info *dpyinfo, DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, 1, 1, 0, - doc: /* Make a new Nextstep window, called a "frame" in Emacs terms. -Return an Emacs frame object. -PARMS is an alist of frame parameters. -If the parameters specify that the frame should not have a minibuffer, -and do not specify a specific minibuffer window to use, -then `default-minibuffer-frame' must be a frame whose minibuffer can -be shared by the new frame. - -This function is an internal primitive--use `make-frame' instead. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object parms) { struct frame *f; @@ -1131,7 +1086,7 @@ This function is an internal primitive--use `make-frame' instead. */) if (EQ (parent, Qunbound)) parent = Qnil; if (! NILP (parent)) - CHECK_NUMBER (parent); + CHECK_FIXNUM (parent); /* make_frame_without_minibuffer can run Lisp code and garbage collect. */ /* No need to protect DISPLAY because that's not used after passing @@ -1172,9 +1127,9 @@ This function is an internal primitive--use `make-frame' instead. */) record_unwind_protect (unwind_create_frame, frame); f->output_data.ns->window_desc = desc_ctr++; - if (TYPE_RANGED_INTEGERP (Window, parent)) + if (TYPE_RANGED_FIXNUMP (Window, parent)) { - f->output_data.ns->parent_desc = XFASTINT (parent); + f->output_data.ns->parent_desc = XFIXNAT (parent); f->output_data.ns->explicit_parent = 1; } else @@ -1215,7 +1170,7 @@ This function is an internal primitive--use `make-frame' instead. */) /* use for default font name */ id font = [NSFont userFixedPitchFontOfSize: -1.0]; /* default */ x_default_parameter (f, parms, Qfontsize, - make_number (0 /*(int)[font pointSize]*/), + make_fixnum (0 /* (int)[font pointSize] */), "fontSize", "FontSize", RES_TYPE_NUMBER); // Remove ' Regular', not handled by backends. char *fontname = xstrdup ([[font displayName] UTF8String]); @@ -1229,14 +1184,14 @@ This function is an internal primitive--use `make-frame' instead. */) } unblock_input (); - x_default_parameter (f, parms, Qborder_width, make_number (0), + x_default_parameter (f, parms, Qborder_width, make_fixnum (0), "borderwidth", "BorderWidth", RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qinternal_border_width, make_number (2), + x_default_parameter (f, parms, Qinternal_border_width, make_fixnum (2), "internalBorderWidth", "InternalBorderWidth", RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qright_divider_width, make_number (0), + x_default_parameter (f, parms, Qright_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qbottom_divider_width, make_number (0), + x_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); /* default vertical scrollbars on right on Mac */ @@ -1258,7 +1213,6 @@ This function is an internal primitive--use `make-frame' instead. */) "foreground", "Foreground", RES_TYPE_STRING); x_default_parameter (f, parms, Qbackground_color, build_string ("White"), "background", "Background", RES_TYPE_STRING); - /* FIXME: not supported yet in Nextstep */ x_default_parameter (f, parms, Qline_spacing, Qnil, "lineSpacing", "LineSpacing", RES_TYPE_NUMBER); x_default_parameter (f, parms, Qleft_fringe, Qnil, @@ -1272,10 +1226,10 @@ This function is an internal primitive--use `make-frame' instead. */) /* Read comment about this code in corresponding place in xfns.c. */ tem = x_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, RES_TYPE_NUMBER); - if (NUMBERP (tem)) + if (FIXNUMP (tem)) store_frame_param (f, Qmin_width, tem); tem = x_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, RES_TYPE_NUMBER); - if (NUMBERP (tem)) + if (FIXNUMP (tem)) store_frame_param (f, Qmin_height, tem); adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, @@ -1321,11 +1275,11 @@ This function is an internal primitive--use `make-frame' instead. */) variables; ignore them here. */ x_default_parameter (f, parms, Qmenu_bar_lines, NILP (Vmenu_bar_mode) - ? make_number (0) : make_number (1), + ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); x_default_parameter (f, parms, Qtool_bar_lines, NILP (Vtool_bar_mode) - ? make_number (0) : make_number (1), + ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); x_default_parameter (f, parms, Qbuffer_predicate, Qnil, "bufferPredicate", @@ -1337,10 +1291,10 @@ This function is an internal primitive--use `make-frame' instead. */) window_prompting = x_figure_window_size (f, parms, true, &x_width, &x_height); tem = x_get_arg (dpyinfo, parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN); - f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !EQ (tem, Qnil)); + f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem)); /* NOTE: on other terms, this is done in set_mouse_color, however this - was not getting called under Nextstep */ + was not getting called under Nextstep. */ f->output_data.ns->text_cursor = [NSCursor IBeamCursor]; f->output_data.ns->nontext_cursor = [NSCursor arrowCursor]; f->output_data.ns->modeline_cursor = [NSCursor pointingHandCursor]; @@ -1372,8 +1326,9 @@ This function is an internal primitive--use `make-frame' instead. */) /* ns_display_info does not have a reference_count. */ f->terminal->reference_count++; - /* It is now ok to make the frame official even if we get an error below. - The frame needs to be on Vframe_list or making it visible won't work. */ + /* It is now ok to make the frame official even if we get an error + below. The frame needs to be on Vframe_list or making it visible + won't work. */ Vframe_list = Fcons (frame, Vframe_list); x_default_parameter (f, parms, Qicon_type, Qnil, @@ -1467,7 +1422,7 @@ x_focus_frame (struct frame *f, bool noactivate) static BOOL ns_window_is_ancestor (NSWindow *win, NSWindow *candidate) -/* Test whether CANDIDATE is an ancestor window of WIN. */ +/* Test whether CANDIDATE is an ancestor window of WIN. */ { if (candidate == NULL) return NO; @@ -1542,7 +1497,7 @@ Some window managers may refuse to restack windows. */) DEFUN ("ns-popup-font-panel", Fns_popup_font_panel, Sns_popup_font_panel, 0, 1, "", - doc: /* Pop up the font panel. */) + doc: /* Pop up the font panel. */) (Lisp_Object frame) { struct frame *f = decode_window_system_frame (frame); @@ -1783,23 +1738,18 @@ If VALUE is nil, the default is removed. */) DEFUN ("x-server-max-request-size", Fx_server_max_request_size, Sx_server_max_request_size, 0, 1, 0, - doc: /* This function is a no-op. It is only present for completeness. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); - /* This function has no real equivalent under NeXTstep. Return nil to - indicate this. */ + /* This function has no real equivalent under Nextstep. Return nil to + indicate this. */ return Qnil; } DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0, - doc: /* Return the "vendor ID" string of Nextstep display server TERMINAL. -\(Labeling every distributor as a "vendor" embodies the false assumption -that operating systems cannot be developed and distributed noncommercially.) -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); @@ -1812,95 +1762,66 @@ If omitted or nil, that stands for the selected frame's display. */) DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0, - doc: /* Return the version numbers of the server of display TERMINAL. -The value is a list of three integers: the major and minor -version numbers of the X Protocol in use, and the distributor-specific release -number. See also the function `x-server-vendor'. - -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); - /*NOTE: it is unclear what would best correspond with "protocol"; - we return 10.3, meaning Panther, since this is roughly the - level that GNUstep's APIs correspond to. - The last number is where we distinguish between the Apple - and GNUstep implementations ("distributor-specific release - number") and give int'ized versions of major.minor. */ + /* NOTE: it is unclear what would best correspond with "protocol"; + we return 10.3, meaning Panther, since this is roughly the + level that GNUstep's APIs correspond to. The last number + is where we distinguish between the Apple and GNUstep + implementations ("distributor-specific release number") and + give int'ized versions of major.minor. */ return list3i (10, 3, ns_appkit_version_int ()); } DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, - doc: /* Return the number of screens on Nextstep display server TERMINAL. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -Note: "screen" here is not in Nextstep terminology but in X11's. For -the number of physical monitors, use `(length -\(display-monitor-attributes-list TERMINAL))' instead. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); - return make_number (1); + return make_fixnum (1); } DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0, - doc: /* Return the height in millimeters of the Nextstep display TERMINAL. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the height in millimeters for -all physical monitors associated with TERMINAL. To get information -for each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { struct ns_display_info *dpyinfo = check_ns_display_info (terminal); - return make_number (x_display_pixel_height (dpyinfo) / (92.0/25.4)); + return make_fixnum (x_display_pixel_height (dpyinfo) / (92.0/25.4)); } DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, - doc: /* Return the width in millimeters of the Nextstep display TERMINAL. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the width in millimeters for -all physical monitors associated with TERMINAL. To get information -for each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { struct ns_display_info *dpyinfo = check_ns_display_info (terminal); - return make_number (x_display_pixel_width (dpyinfo) / (92.0/25.4)); + return make_fixnum (x_display_pixel_width (dpyinfo) / (92.0/25.4)); } DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_store, 0, 1, 0, - doc: /* Return an indication of whether the Nextstep display TERMINAL does backing store. -The value may be `buffered', `retained', or `non-retained'. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); + /* Note that the xfns.c version has different return values. */ switch ([ns_get_window (terminal) backingType]) { case NSBackingStoreBuffered: return intern ("buffered"); +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 case NSBackingStoreRetained: return intern ("retained"); case NSBackingStoreNonretained: return intern ("non-retained"); +#endif default: error ("Strange value for backingType parameter of frame"); } @@ -1910,13 +1831,7 @@ If omitted or nil, that stands for the selected frame's display. */) DEFUN ("x-display-visual-class", Fx_display_visual_class, Sx_display_visual_class, 0, 1, 0, - doc: /* Return the visual class of the Nextstep display TERMINAL. -The value is one of the symbols `static-gray', `gray-scale', -`static-color', `pseudo-color', `true-color', or `direct-color'. - -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { NSWindowDepth depth; @@ -1935,17 +1850,15 @@ If omitted or nil, that stands for the selected frame's display. */) else if ( depth == NSBestDepth (NSCalibratedRGBColorSpace, 8, 24, NO, NULL)) return intern ("direct-color"); else - /* color mgmt as far as we do it is really handled by Nextstep itself anyway */ + /* Color management as far as we do it is really handled by + Nextstep itself anyway. */ return intern ("direct-color"); } DEFUN ("x-display-save-under", Fx_display_save_under, Sx_display_save_under, 0, 1, 0, - doc: /* Return t if TERMINAL supports the save-under feature. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); @@ -1954,9 +1867,11 @@ If omitted or nil, that stands for the selected frame's display. */) case NSBackingStoreBuffered: return Qt; +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 case NSBackingStoreRetained: case NSBackingStoreNonretained: return Qnil; +#endif default: error ("Strange value for backingType parameter of frame"); @@ -1967,12 +1882,7 @@ If omitted or nil, that stands for the selected frame's display. */) DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, 1, 3, 0, - doc: /* Open a connection to a display server. -DISPLAY is the name of the display to connect to. -Optional second arg XRM-STRING is a string of resources in xrdb format. -If the optional third arg MUST-SUCCEED is non-nil, -terminate Emacs if we can't open the connection. -\(In the Nextstep version, the last two arguments are currently ignored.) */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display, Lisp_Object resource_string, Lisp_Object must_succeed) { struct ns_display_info *dpyinfo; @@ -1997,10 +1907,7 @@ terminate Emacs if we can't open the connection. DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0, - doc: /* Close the connection to TERMINAL's Nextstep display server. -For TERMINAL, specify a terminal object, a frame or a display name (a -string). If TERMINAL is nil, that stands for the selected frame's -terminal. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); @@ -2010,7 +1917,7 @@ terminal. */) DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, - doc: /* Return the list of display names that Emacs has connections to. */) + doc: /* SKIP: real doc in xfns.c. */) (void) { Lisp_Object result = Qnil; @@ -2070,7 +1977,7 @@ DEFUN ("ns-font-name", Fns_font_name, Sns_font_name, 1, 1, 0, doc: /* Determine font PostScript or family name for font NAME. NAME should be a string containing either the font name or an XLFD font descriptor. If string contains `fontset' and not -`fontset-startup', it is left alone. */) +`fontset-startup', it is left alone. */) (Lisp_Object name) { char *nm; @@ -2187,7 +2094,7 @@ there was no result. */) status as function value. A zero is returned if compilation and execution is successful, in which case *RESULT is set to a Lisp string or a number containing the resulting script value. Otherwise, - 1 is returned. */ + 1 is returned. */ static int ns_do_applescript (Lisp_Object script, Lisp_Object *result) { @@ -2228,7 +2135,7 @@ ns_do_applescript (Lisp_Object script, Lisp_Object *result) // coerce the result to the appropriate ObjC type desc = [returnDescriptor coerceToDescriptorType: typeUTF8Text]; if (desc) - *result = make_number([desc int32Value]); + *result = make_fixnum([desc int32Value]); } } } @@ -2240,7 +2147,7 @@ ns_do_applescript (Lisp_Object script, Lisp_Object *result) return 0; } -/* Helper function called from sendEvent to run applescript +/* Helper function called from sendEvent to run AppleScript from within the main event loop. */ void @@ -2255,7 +2162,7 @@ DEFUN ("ns-do-applescript", Fns_do_applescript, Sns_do_applescript, 1, 1, 0, doc: /* Execute AppleScript SCRIPT and return the result. If compilation and execution are successful, the resulting script value is returned as a string, a number or, in the case of other constructs, t. -In case the execution fails, an error is signaled. */) +In case the execution fails, an error is signaled. */) (Lisp_Object script) { Lisp_Object result; @@ -2271,10 +2178,10 @@ In case the execution fails, an error is signaled. */) as_script = script; as_result = &result; - /* executing apple script requires the event loop to run, otherwise + /* Executing AppleScript requires the event loop to run, otherwise 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. */ + 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: NSEventTypeApplicationDefined location: NSMakePoint (0, 0) modifierFlags: 0 @@ -2287,8 +2194,8 @@ In case the execution fails, an error is signaled. */) [NSApp postEvent: nxev atStart: NO]; - // If there are other events, the event loop may exit. Keep running - // until the script has been handled. */ + /* If there are other events, the event loop may exit. Keep running + until the script has been handled. */ ns_init_events (&ev); while (! NILP (as_script)) [NSApp run]; @@ -2341,7 +2248,7 @@ x_set_scroll_bar_default_height (struct frame *f) height - 1) / height; } -/* terms impl this instead of x-get-resource directly */ +/* Terms implement this instead of x-get-resource directly. */ char * x_get_string_resource (XrmDatabase rdb, const char *name, const char *class) { @@ -2383,8 +2290,7 @@ x_get_focus_frame (struct frame *frame) DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, - doc: /* Internal function called by `color-defined-p', which see. -\(Note that the Nextstep version of this function ignores FRAME.) */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object color, Lisp_Object frame) { NSColor * col; @@ -2394,7 +2300,7 @@ DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, - doc: /* Internal function called by `color-values', which see. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object color, Lisp_Object frame) { NSColor * col; @@ -2419,7 +2325,7 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, - doc: /* Internal function called by `display-color-p', which see. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { NSWindowDepth depth; @@ -2437,11 +2343,7 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, 0, 1, 0, - doc: /* Return t if the Nextstep display supports shades of gray. -Note that color displays do support shades of gray. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { NSWindowDepth depth; @@ -2455,37 +2357,23 @@ If omitted or nil, that stands for the selected frame's display. */) DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, 0, 1, 0, - doc: /* Return the width in pixels of the Nextstep display TERMINAL. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the pixel width for all -physical monitors associated with TERMINAL. To get information for -each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { struct ns_display_info *dpyinfo = check_ns_display_info (terminal); - return make_number (x_display_pixel_width (dpyinfo)); + return make_fixnum (x_display_pixel_width (dpyinfo)); } DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_height, 0, 1, 0, - doc: /* Return the height in pixels of the Nextstep display TERMINAL. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the pixel height for all -physical monitors associated with TERMINAL. To get information for -each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { struct ns_display_info *dpyinfo = check_ns_display_info (terminal); - return make_number (x_display_pixel_height (dpyinfo)); + return make_fixnum (x_display_pixel_height (dpyinfo)); } #ifdef NS_IMPL_COCOA @@ -2538,7 +2426,7 @@ ns_screen_name (CGDirectDisplayID did) /* CGDisplayIOServicePort is deprecated. Do it another (harder) way. Is this code OK for macOS < 10.9, and GNUstep? I suspect it is, - in which case is it worth keeping the other method in here? */ + in which case is it worth keeping the other method in here? */ if (IOMasterPort (MACH_PORT_NULL, &masterPort) != kIOReturnSuccess || IOServiceGetMatchingServices (masterPort, @@ -2588,7 +2476,7 @@ ns_make_monitor_attribute_list (struct MonitorInfo *monitors, int primary_monitor, const char *source) { - Lisp_Object monitor_frames = Fmake_vector (make_number (n_monitors), Qnil); + Lisp_Object monitor_frames = make_nil_vector (n_monitors); Lisp_Object frame, rest; NSArray *screens = [NSScreen screens]; int i; @@ -2725,35 +2613,25 @@ Internal use only, use `display-monitor-attributes-list' instead. */) DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, 0, 1, 0, - doc: /* Return the number of bitplanes of the Nextstep display TERMINAL. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { check_ns_display_info (terminal); - return make_number + return make_fixnum (NSBitsPerPixelFromDepth ([[[NSScreen screens] objectAtIndex:0] depth])); } DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, 0, 1, 0, - doc: /* Returns the number of color cells of the Nextstep display TERMINAL. -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { struct ns_display_info *dpyinfo = check_ns_display_info (terminal); /* We force 24+ bit depths to 24-bit to prevent an overflow. */ - return make_number (1 << min (dpyinfo->n_planes, 24)); + return make_fixnum (1 << min (dpyinfo->n_planes, 24)); } - -/* Unused dummy def needed for compatibility. */ -Lisp_Object tip_frame; - /* TODO: move to xdisp or similar */ static void compute_tip_xy (struct frame *f, @@ -2775,19 +2653,19 @@ compute_tip_xy (struct frame *f, right = Fcdr (Fassq (Qright, parms)); bottom = Fcdr (Fassq (Qbottom, parms)); - if ((!INTEGERP (left) && !INTEGERP (right)) - || (!INTEGERP (top) && !INTEGERP (bottom))) + if ((!FIXNUMP (left) && !FIXNUMP (right)) + || (!FIXNUMP (top) && !FIXNUMP (bottom))) pt = [NSEvent mouseLocation]; else { /* Absolute coordinates. */ - pt.x = INTEGERP (left) ? XINT (left) : XINT (right); + pt.x = FIXNUMP (left) ? XFIXNUM (left) : XFIXNUM (right); pt.y = (x_display_pixel_height (FRAME_DISPLAY_INFO (f)) - - (INTEGERP (top) ? XINT (top) : XINT (bottom)) + - (FIXNUMP (top) ? XFIXNUM (top) : XFIXNUM (bottom)) - height); } - /* Find the screen that pt is on. */ + /* Find the screen that pt is on. */ for (screen in [NSScreen screens]) if (pt.x >= screen.frame.origin.x && pt.x < screen.frame.origin.x + screen.frame.size.width @@ -2800,33 +2678,33 @@ compute_tip_xy (struct frame *f, if (CGRectContainsPoint ([screen frame], pt)) which would be neater, but it causes problems building on old - versions of macOS and in GNUstep. */ + versions of macOS and in GNUstep. */ /* Ensure in bounds. (Note, screen origin = lower left.) */ - if (INTEGERP (left) || INTEGERP (right)) + if (FIXNUMP (left) || FIXNUMP (right)) *root_x = pt.x; - else if (pt.x + XINT (dx) <= screen.frame.origin.x) - *root_x = screen.frame.origin.x; /* Can happen for negative dx */ - else if (pt.x + XINT (dx) + width + else if (pt.x + XFIXNUM (dx) <= screen.frame.origin.x) + *root_x = screen.frame.origin.x; + else if (pt.x + XFIXNUM (dx) + width <= screen.frame.origin.x + screen.frame.size.width) /* It fits to the right of the pointer. */ - *root_x = pt.x + XINT (dx); - else if (width + XINT (dx) <= pt.x) + *root_x = pt.x + XFIXNUM (dx); + else if (width + XFIXNUM (dx) <= pt.x) /* It fits to the left of the pointer. */ - *root_x = pt.x - width - XINT (dx); + *root_x = pt.x - width - XFIXNUM (dx); else /* Put it left justified on the screen -- it ought to fit that way. */ *root_x = screen.frame.origin.x; - if (INTEGERP (top) || INTEGERP (bottom)) + if (FIXNUMP (top) || FIXNUMP (bottom)) *root_y = pt.y; - else if (pt.y - XINT (dy) - height >= screen.frame.origin.y) + else if (pt.y - XFIXNUM (dy) - height >= screen.frame.origin.y) /* It fits below the pointer. */ - *root_y = pt.y - height - XINT (dy); - else if (pt.y + XINT (dy) + height + *root_y = pt.y - height - XFIXNUM (dy); + else if (pt.y + XFIXNUM (dy) + height <= screen.frame.origin.y + screen.frame.size.height) - /* It fits above the pointer */ - *root_y = pt.y + XINT (dy); + /* It fits above the pointer. */ + *root_y = pt.y + XFIXNUM (dy); else /* Put it on the top. */ *root_y = screen.frame.origin.y + screen.frame.size.height - height; @@ -2834,35 +2712,7 @@ compute_tip_xy (struct frame *f, 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 window displaying a string. - -This is an internal function; Lisp code should call `tooltip-show'. - -FRAME nil or omitted means use the selected frame. - -PARMS is an optional list of frame parameters which can be used to -change the tooltip's appearance. - -Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil -means use the default timeout of 5 seconds. - -If the list of frame parameters PARMS contains a `left' parameter, -display the tooltip at that x-position. If the list of frame parameters -PARMS contains no `left' but a `right' parameter, display the tooltip -right-adjusted at that x-position. Otherwise display it at the -x-position of the mouse, with offset DX added (default is 5 if DX isn't -specified). - -Likewise for the y-position: If a `top' frame parameter is specified, it -determines the position of the upper edge of the tooltip window. If a -`bottom' parameter but no `top' frame parameter is specified, it -determines the position of the lower edge of the tooltip window. -Otherwise display the tooltip window at the y-position of the mouse, -with offset DY added (default is -10). - -A tooltip's maximum size is specified by `x-max-tooltip-size'. -Text larger than the specified size is clipped. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) { int root_x, root_y; @@ -2870,6 +2720,8 @@ Text larger than the specified size is clipped. */) struct frame *f; char *str; NSSize size; + NSColor *color; + Lisp_Object t; specbind (Qinhibit_redisplay, Qt); @@ -2877,19 +2729,19 @@ Text larger than the specified size is clipped. */) str = SSDATA (string); f = decode_window_system_frame (frame); if (NILP (timeout)) - timeout = make_number (5); + timeout = make_fixnum (5); else - CHECK_NATNUM (timeout); + CHECK_FIXNAT (timeout); if (NILP (dx)) - dx = make_number (5); + dx = make_fixnum (5); else - CHECK_NUMBER (dx); + CHECK_FIXNUM (dx); if (NILP (dy)) - dy = make_number (-10); + dy = make_fixnum (-10); else - CHECK_NUMBER (dy); + CHECK_FIXNUM (dy); block_input (); if (ns_tooltip == nil) @@ -2897,6 +2749,14 @@ Text larger than the specified size is clipped. */) else Fx_hide_tip (); + t = x_get_arg (NULL, parms, Qbackground_color, NULL, NULL, RES_TYPE_STRING); + if (ns_lisp_to_color (t, &color) == 0) + [ns_tooltip setBackgroundColor: color]; + + t = x_get_arg (NULL, parms, Qforeground_color, NULL, NULL, RES_TYPE_STRING); + if (ns_lisp_to_color (t, &color) == 0) + [ns_tooltip setForegroundColor: color]; + [ns_tooltip setText: str]; size = [ns_tooltip frame].size; @@ -2905,7 +2765,7 @@ Text larger than the specified size is clipped. */) compute_tip_xy (f, parms, dx, dy, (int)size.width, (int)size.height, &root_x, &root_y); - [ns_tooltip showAtX: root_x Y: root_y for: XINT (timeout)]; + [ns_tooltip showAtX: root_x Y: root_y for: XFIXNUM (timeout)]; unblock_input (); return unbind_to (count, Qnil); @@ -2913,8 +2773,7 @@ Text larger than the specified size is clipped. */) DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, - doc: /* Hide the current tooltip window, if there is any. -Value is t if tooltip was open, nil otherwise. */) + doc: /* SKIP: real doc in xfns.c. */) (void) { if (ns_tooltip == nil || ![ns_tooltip isActive]) @@ -2953,44 +2812,44 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute) /* Construct list. */ if (EQ (attribute, Qouter_edges)) - return list4 (make_number (f->left_pos), make_number (f->top_pos), - make_number (f->left_pos + outer_width), - make_number (f->top_pos + outer_height)); + return list4 (make_fixnum (f->left_pos), make_fixnum (f->top_pos), + make_fixnum (f->left_pos + outer_width), + make_fixnum (f->top_pos + outer_height)); else if (EQ (attribute, Qnative_edges)) - return list4 (make_number (native_left), make_number (native_top), - make_number (native_right), make_number (native_bottom)); + return list4 (make_fixnum (native_left), make_fixnum (native_top), + make_fixnum (native_right), make_fixnum (native_bottom)); else if (EQ (attribute, Qinner_edges)) - return list4 (make_number (native_left + internal_border_width), - make_number (native_top + return list4 (make_fixnum (native_left + internal_border_width), + make_fixnum (native_top + tool_bar_height + internal_border_width), - make_number (native_right - internal_border_width), - make_number (native_bottom - internal_border_width)); + make_fixnum (native_right - internal_border_width), + make_fixnum (native_bottom - internal_border_width)); else return listn (CONSTYPE_HEAP, 10, Fcons (Qouter_position, - Fcons (make_number (f->left_pos), - make_number (f->top_pos))), + Fcons (make_fixnum (f->left_pos), + make_fixnum (f->top_pos))), Fcons (Qouter_size, - Fcons (make_number (outer_width), - make_number (outer_height))), + Fcons (make_fixnum (outer_width), + make_fixnum (outer_height))), Fcons (Qexternal_border_size, (fullscreen - ? Fcons (make_number (0), make_number (0)) - : Fcons (make_number (border), make_number (border)))), + ? Fcons (make_fixnum (0), make_fixnum (0)) + : Fcons (make_fixnum (border), make_fixnum (border)))), Fcons (Qtitle_bar_size, - Fcons (make_number (0), make_number (title_height))), + Fcons (make_fixnum (0), make_fixnum (title_height))), Fcons (Qmenu_bar_external, Qnil), - Fcons (Qmenu_bar_size, Fcons (make_number (0), make_number (0))), + Fcons (Qmenu_bar_size, Fcons (make_fixnum (0), make_fixnum (0))), Fcons (Qtool_bar_external, FRAME_EXTERNAL_TOOL_BAR (f) ? Qt : Qnil), Fcons (Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)), Fcons (Qtool_bar_size, - Fcons (make_number (tool_bar_width), - make_number (tool_bar_height))), + Fcons (make_fixnum (tool_bar_width), + make_fixnum (tool_bar_height))), Fcons (Qinternal_border_width, - make_number (internal_border_width))); + make_fixnum (internal_border_width))); } DEFUN ("ns-frame-geometry", Fns_frame_geometry, Sns_frame_geometry, 0, 1, 0, @@ -3071,7 +2930,7 @@ The coordinates X and Y are interpreted in pixels relative to a position { #ifdef NS_IMPL_COCOA /* GNUstep doesn't support CGWarpMouseCursorPosition, so none of - this will work. */ + this will work. */ struct frame *f = SELECTED_FRAME (); EmacsView *view = FRAME_NS_VIEW (f); NSScreen *screen = [[view window] screen]; @@ -3088,13 +2947,13 @@ The coordinates X and Y are interpreted in pixels relative to a position CHECK_TYPE_RANGED_INTEGER (int, x); CHECK_TYPE_RANGED_INTEGER (int, y); - mouse_x = screen_frame.origin.x + XINT (x); + mouse_x = screen_frame.origin.x + XFIXNUM (x); if (screen == primary_screen) - mouse_y = screen_frame.origin.y + XINT (y); + mouse_y = screen_frame.origin.y + XFIXNUM (y); else mouse_y = (primary_screen_height - screen_frame.size.height - - screen_frame.origin.y) + XINT (y); + - screen_frame.origin.y) + XFIXNUM (y); CGPoint mouse_pos = CGPointMake(mouse_x, mouse_y); CGWarpMouseCursorPosition (mouse_pos); @@ -3109,7 +2968,7 @@ DEFUN ("ns-mouse-absolute-pixel-position", doc: /* Return absolute position of mouse cursor in pixels. The position is returned as a cons cell (X . Y) of the coordinates of the mouse cursor position in pixels relative to a -position (0, 0) of the selected frame's terminal. */) +position (0, 0) of the selected frame's terminal. */) (void) { struct frame *f = SELECTED_FRAME (); @@ -3117,11 +2976,24 @@ position (0, 0) of the selected frame's terminal. */) NSScreen *screen = [[view window] screen]; NSPoint pt = [NSEvent mouseLocation]; - return Fcons(make_number(pt.x - screen.frame.origin.x), - make_number(screen.frame.size.height - + return Fcons(make_fixnum(pt.x - screen.frame.origin.x), + make_fixnum(screen.frame.size.height - (pt.y - screen.frame.origin.y))); } +DEFUN ("ns-show-character-palette", + Fns_show_character_palette, + Sns_show_character_palette, 0, 0, 0, + doc: /* Show the macOS character palette. */) + (void) +{ + struct frame *f = SELECTED_FRAME (); + EmacsView *view = FRAME_NS_VIEW (f); + [NSApp orderFrontCharacterPalette:view]; + + return Qnil; +} + /* ========================================================================== Class implementations @@ -3156,8 +3028,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) case NSPageDownFunctionKey: case NSEndFunctionKey: /* Don't send command modified keys, as those are handled in the - performKeyEquivalent method of the super class. - */ + performKeyEquivalent method of the super class. */ if (! ([theEvent modifierFlags] & NSEventModifierFlagCommand)) { [panel sendEvent: theEvent]; @@ -3169,8 +3040,7 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) them here. TODO: handle Emacs key bindings for copy/cut/select-all here, paste works, because we have that in our Edit menu. I.e. refactor out code in nsterm.m, keyDown: to figure out the - correct modifier. - */ + correct modifier. */ case 'x': // Cut case 'c': // Copy case 'v': // Paste @@ -3289,6 +3159,11 @@ be used as the image of the icon representing the frame. */); doc: /* Toolkit version for NS Windowing. */); Vns_version_string = ns_appkit_version_str (); + DEFVAR_BOOL ("ns-use-proxy-icon", ns_use_proxy_icon, + doc: /* When non-nil display a proxy icon in the titlebar. +Default is t. */); + ns_use_proxy_icon = true; + defsubr (&Sns_read_file_name); defsubr (&Sns_get_resource); defsubr (&Sns_set_resource); @@ -3313,6 +3188,7 @@ be used as the image of the icon representing the frame. */); defsubr (&Sns_frame_restack); defsubr (&Sns_set_mouse_absolute_pixel_position); defsubr (&Sns_mouse_absolute_pixel_position); + defsubr (&Sns_show_character_palette); defsubr (&Sx_display_mm_width); defsubr (&Sx_display_mm_height); defsubr (&Sx_display_screens); diff --git a/src/nsfont.m b/src/nsfont.m index 555ad0684e4..d4639dcca8c 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -21,7 +21,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu) */ /* This should be the first include, as it may set up #defines affecting - interpretation of even the system includes. */ + interpretation of even the system includes. */ #include <config.h> #include "lisp.h" @@ -37,7 +37,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu) #include "font.h" #include "termchar.h" -/* TODO: Drop once we can assume gnustep-gui 0.17.1. */ +/* TODO: Drop once we can assume gnustep-gui 0.17.1. */ #ifdef NS_IMPL_GNUSTEP #import <AppKit/NSFontDescriptor.h> #endif @@ -45,7 +45,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu) #define NSFONT_TRACE 0 #define LCD_SMOOTHING_MARGIN 2 -/* font glyph and metrics caching functions, implemented at end */ +/* Font glyph and metrics caching functions, implemented at end. */ static void ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block); static void ns_glyph_metrics (struct nsfont_info *font_info, @@ -61,7 +61,7 @@ static void ns_glyph_metrics (struct nsfont_info *font_info, /* Replace spaces w/another character so emacs core font parsing routines - aren't thrown off. */ + aren't thrown off. */ static void ns_escape_name (char *name) { @@ -71,7 +71,7 @@ ns_escape_name (char *name) } -/* Reconstruct spaces in a font family name passed through emacs. */ +/* Reconstruct spaces in a font family name passed through emacs. */ static void ns_unescape_name (char *name) { @@ -81,7 +81,7 @@ ns_unescape_name (char *name) } -/* Extract family name from a font spec. */ +/* Extract family name from a font spec. */ static NSString * ns_get_family (Lisp_Object font_spec) { @@ -103,7 +103,7 @@ ns_get_family (Lisp_Object font_spec) /* Return 0 if attr not set, else value (which might also be 0). On Leopard 0 gets returned even on descriptors where the attribute was never set, so there's no way to distinguish between unspecified - and set to not have. Callers should assume 0 means unspecified. */ + and set to not have. Callers should assume 0 means unspecified. */ static float ns_attribute_fvalue (NSFontDescriptor *fdesc, NSString *trait) { @@ -114,7 +114,7 @@ ns_attribute_fvalue (NSFontDescriptor *fdesc, NSString *trait) /* Converts FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, plus family and script/lang - to NSFont descriptor. Information under extra only needed for matching. */ + to NSFont descriptor. Information under extra only needed for matching. */ #define STYLE_REF 100 static NSFontDescriptor * ns_spec_to_descriptor (Lisp_Object font_spec) @@ -125,7 +125,7 @@ ns_spec_to_descriptor (Lisp_Object font_spec) NSString *family = ns_get_family (font_spec); float n; - /* add each attr in font_spec to fdAttrs.. */ + /* Add each attr in font_spec to fdAttrs. */ n = min (FONT_WEIGHT_NUMERIC (font_spec), 200); if (n != -1 && n != STYLE_REF) [tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F] @@ -156,7 +156,7 @@ ns_spec_to_descriptor (Lisp_Object font_spec) } -/* Converts NSFont descriptor to FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, etc.. */ +/* Converts NSFont descriptor to FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, etc. */ static Lisp_Object ns_descriptor_to_entity (NSFontDescriptor *desc, Lisp_Object extra, @@ -168,7 +168,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, unsigned int traits = [desc symbolicTraits]; char *escapedFamily; - /* Shouldn't happen, but on Tiger fallback desc gets name but no family. */ + /* Shouldn't happen, but on Tiger fallback desc gets name but no family. */ if (family == nil) family = [desc objectForKey: NSFontNameAttribute]; if (family == nil) @@ -186,24 +186,24 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX, traits & NSFontBoldTrait ? Qbold : Qmedium); /* FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX, - make_number (100 + 100 + make_fixnum (100 + 100 * ns_attribute_fvalue (desc, NSFontWeightTrait)));*/ FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, traits & NSFontItalicTrait ? Qitalic : Qnormal); /* FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, - make_number (100 + 100 + make_fixnum (100 + 100 * ns_attribute_fvalue (desc, NSFontSlantTrait)));*/ FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, traits & NSFontCondensedTrait ? Qcondensed : traits & NSFontExpandedTrait ? Qexpanded : Qnormal); /* FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, - make_number (100 + 100 + make_fixnum (100 + 100 * ns_attribute_fvalue (desc, NSFontWidthTrait)));*/ - ASET (font_entity, FONT_SIZE_INDEX, make_number (0)); - ASET (font_entity, FONT_AVGWIDTH_INDEX, make_number (0)); + ASET (font_entity, FONT_SIZE_INDEX, make_fixnum (0)); + ASET (font_entity, FONT_AVGWIDTH_INDEX, make_fixnum (0)); ASET (font_entity, FONT_SPACING_INDEX, - make_number([desc symbolicTraits] & NSFontMonoSpaceTrait + make_fixnum([desc symbolicTraits] & NSFontMonoSpaceTrait ? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL)); ASET (font_entity, FONT_EXTRA_INDEX, extra); @@ -220,7 +220,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, } -/* Default font entity. */ +/* Default font entity. */ static Lisp_Object ns_fallback_entity (void) { @@ -229,7 +229,7 @@ ns_fallback_entity (void) } -/* Utility: get width of a char c in screen font SFONT */ +/* Utility: get width of a char c in screen font SFONT. */ static CGFloat ns_char_width (NSFont *sfont, int c) { @@ -292,7 +292,7 @@ ns_ascii_average_width (NSFont *sfont) /* Return whether set1 covers set2 to a reasonable extent given by pct. We check, out of each 16 Unicode char range containing chars in set2, whether at least one character is present in set1. - This must be true for pct of the pairs to consider it covering. */ + This must be true for pct of the pairs to consider it covering. */ static BOOL ns_charset_covers(NSCharacterSet *set1, NSCharacterSet *set2, float pct) { @@ -312,20 +312,20 @@ ns_charset_covers(NSCharacterSet *set1, NSCharacterSet *set2, float pct) if (*bytes1 == 0) // *bytes1 & *bytes2 != *bytes2 off++; } -//fprintf(stderr, "off = %d\ttot = %d\n", off,tot); + // fprintf(stderr, "off = %d\ttot = %d\n", off,tot); return (float)off / tot < 1.0F - pct; } /* Convert :lang property to a script. Use of :lang property by font backend - seems to be limited for now (2009/05) to ja, zh, and ko. */ + seems to be limited for now (2009/05) to ja, zh, and ko. */ static NSString *ns_lang_to_script (Lisp_Object lang) { if (!strcmp (SSDATA (SYMBOL_NAME (lang)), "ja")) return @"han"; /* NOTE: ja given for any hanzi that's also a kanji, but Chinese fonts - have more characters. */ + have more characters. */ else if (!strcmp (SSDATA (SYMBOL_NAME (lang)), "zh")) return @"han"; else if (!strcmp (SSDATA (SYMBOL_NAME (lang)), "ko")) @@ -336,7 +336,7 @@ static NSString /* Convert OTF 4-letter script code to emacs script name. (Why can't - everyone just use some standard Unicode names for these?) */ + everyone just use some standard Unicode names for these?) */ static NSString *ns_otf_to_script (Lisp_Object otf) { @@ -347,7 +347,7 @@ static NSString } -/* Convert a font registry, such as */ +/* Convert a font registry. */ static NSString *ns_registry_to_script (char *reg) { @@ -368,14 +368,14 @@ static NSString /* Searches the :script, :lang, and :otf extra-bundle properties of the spec, plus registry regular property, for something that can be mapped to a - Unicode script. Empty string returned if no script spec found. */ + Unicode script. Empty string returned if no script spec found. */ static NSString *ns_get_req_script (Lisp_Object font_spec) { Lisp_Object reg = AREF (font_spec, FONT_REGISTRY_INDEX); Lisp_Object extra = AREF (font_spec, FONT_EXTRA_INDEX); - /* The extra-bundle properties have priority. */ + /* The extra-bundle properties have priority. */ for ( ; CONSP (extra); extra = XCDR (extra)) { Lisp_Object tmp = XCAR (extra); @@ -392,12 +392,12 @@ static NSString } } - /* If we get here, check the charset portion of the registry. */ + /* If we get here, check the charset portion of the registry. */ if (! NILP (reg)) { /* XXX: iso10646 is passed in for non-ascii latin-1 characters (which causes box rendering if we don't treat it like iso8858-1) - but also for ascii (which causes unnecessary font substitution). */ + but also for ascii (which causes unnecessary font substitution). */ #if 0 if (EQ (reg, Qiso10646_1)) reg = Qiso8859_1; @@ -410,7 +410,7 @@ static NSString /* This small function is static in fontset.c. If it can be made public for - all ports, remove this, but otherwise it doesn't seem worth the ifdefs. */ + all ports, remove this, but otherwise it doesn't seem worth the ifdefs. */ static void accumulate_script_ranges (Lisp_Object arg, Lisp_Object range, Lisp_Object val) { @@ -425,7 +425,7 @@ accumulate_script_ranges (Lisp_Object arg, Lisp_Object range, Lisp_Object val) /* Use the Unicode range information in Vchar_script_table to convert a script - name into an NSCharacterSet. */ + name into an NSCharacterSet. */ static NSCharacterSet *ns_script_to_charset (NSString *scriptName) { @@ -445,8 +445,8 @@ static NSCharacterSet { for (; CONSP (range_list); range_list = XCDR (range_list)) { - int start = XINT (XCAR (XCAR (range_list))); - int end = XINT (XCDR (XCAR (range_list))); + int start = XFIXNUM (XCAR (XCAR (range_list))); + int end = XFIXNUM (XCDR (XCAR (range_list))); if (NSFONT_TRACE) debug_print (XCAR (range_list)); if (end < 0x10000) @@ -465,7 +465,7 @@ static NSCharacterSet If none are found, we reduce the percentage and try again, until 5%. This provides a font with at least some characters if such can be found. We don't use isSupersetOfSet: because (a) it doesn't work on Tiger, and - (b) need approximate match as fonts covering full Unicode ranges are rare. */ + (b) need approximate match as fonts covering full Unicode ranges are rare. */ static NSSet *ns_get_covering_families (NSString *script, float pct) { @@ -497,7 +497,7 @@ static NSSet { NSCharacterSet *fset = [[fontMgr fontWithFamily: family traits: 0 weight: 5 size: 12.0] coveredCharacterSet]; - /* Some fonts on macOS, maybe many on GNUstep, return nil. */ + /* Some fonts on macOS, maybe many on GNUstep, return nil. */ if (fset == nil) fset = [NSCharacterSet characterSetWithRange: NSMakeRange (0, 127)]; @@ -525,7 +525,7 @@ static NSSet /* Implementation for list() and match(). List() can return nil, match() must return something. Strategy is to drop family name from attribute -matching set for match. */ +matching set for match. */ static Lisp_Object ns_findfonts (Lisp_Object font_spec, BOOL isMatch) { @@ -574,9 +574,9 @@ ns_findfonts (Lisp_Object font_spec, BOOL isMatch) foundItal = YES; } - /* Add synthItal member if needed. */ + /* Add synthItal member if needed. */ family = [fdesc objectForKey: NSFontFamilyAttribute]; - if (family != nil && !foundItal && XINT (Flength (list)) > 0) + if (family != nil && !foundItal && XFIXNUM (Flength (list)) > 0) { NSFontDescriptor *s1 = [NSFontDescriptor new]; NSFontDescriptor *sDesc @@ -590,13 +590,13 @@ ns_findfonts (Lisp_Object font_spec, BOOL isMatch) unblock_input (); - /* Return something if was a match and nothing found. */ + /* Return something if was a match and nothing found. */ if (isMatch) return ns_fallback_entity (); if (NSFONT_TRACE) fprintf (stderr, " Returning %"pI"d entities.\n", - XINT (Flength (list))); + XFIXNUM (Flength (list))); return list; } @@ -642,7 +642,7 @@ nsfont_list (struct frame *f, Lisp_Object font_spec) /* Return a font entity most closely matching with FONT_SPEC on FRAME. The closeness is determined by the font backend, thus `face-font-selection-order' is ignored here. - Properties to be considered are same as for list(). */ + Properties to be considered are same as for list(). */ static Lisp_Object nsfont_match (struct frame *f, Lisp_Object font_spec) { @@ -651,7 +651,7 @@ nsfont_match (struct frame *f, Lisp_Object font_spec) /* List available families. The value is a list of family names - (symbols). */ + (symbols). */ static Lisp_Object nsfont_list_family (struct frame *f) { @@ -664,11 +664,11 @@ nsfont_list_family (struct frame *f) objectEnumerator]; while ((family = [families nextObject])) list = Fcons (intern ([family UTF8String]), list); - /* FIXME: escape the name? */ + /* FIXME: escape the name? */ if (NSFONT_TRACE) fprintf (stderr, "nsfont: list families returning %"pI"d entries\n", - XINT (Flength (list))); + XFIXNUM (Flength (list))); unblock_input (); return list; @@ -705,7 +705,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) { /* try to get it out of frame params */ Lisp_Object tem = get_frame_param (f, Qfontsize); - pixel_size = NILP (tem) ? 0 : XFASTINT (tem); + pixel_size = NILP (tem) ? 0 : XFIXNAT (tem); } tem = AREF (font_entity, FONT_ADSTYLE_INDEX); @@ -715,7 +715,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) if (family == nil) family = [[NSFont userFixedPitchFontOfSize: 0] familyName]; /* Should be > 0.23 as some font descriptors (e.g. Terminus) set to that - when setting family in ns_spec_to_descriptor(). */ + when setting family in ns_spec_to_descriptor(). */ if (ns_attribute_fvalue (fontDesc, NSFontWeightTrait) > 0.50F) traits |= NSBoldFontMask; if (fabs (ns_attribute_fvalue (fontDesc, NSFontSlantTrait) > 0.05F)) @@ -757,7 +757,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) if (!font) { unblock_input (); - return Qnil; /* FIXME: other terms do, but return Qnil causes segfault */ + return Qnil; /* FIXME: other terms do, but returning Qnil causes segfault. */ } font_info->glyphs = xzalloc (0x100 * sizeof *font_info->glyphs); @@ -793,7 +793,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) * -2.00000405... (represented by 0xc000000220000000). Without * adjustment, the code below would round the descender to -3, * resulting in a font that would be one pixel higher than - * intended. */ + * intended. */ CGFloat adjusted_descender = [sfont descender] + 0.0001; #ifdef NS_IMPL_GNUSTEP @@ -810,7 +810,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) synthItal || ([fontMgr traitsOfFont: nsfont] & NSItalicFontMask); /* Metrics etc.; some fonts return an unusually large max advance, so we - only use it for fonts that have wide characters. */ + only use it for fonts that have wide characters. */ font_info->width = ([sfont numberOfGlyphs] > 2000) ? [sfont maximumAdvancement].width : ns_char_width (sfont, '0'); @@ -823,7 +823,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) /* max bounds */ font->ascent = font_info->max_bounds.ascent = lrint ([sfont ascender]); /* Descender is usually negative. Use floor to avoid - clipping descenders. */ + clipping descenders. */ font->descent = font_info->max_bounds.descent = -lrint (floor(adjusted_descender)); font_info->height = @@ -880,7 +880,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) } -/* Close FONT. */ +/* Close FONT. */ static void nsfont_close (struct font *font) { @@ -911,7 +911,7 @@ nsfont_close (struct font *font) /* If FONT_ENTITY has a glyph for character C (Unicode code point), return 1. If not, return 0. If a font must be opened to check - it, return -1. */ + it, return -1. */ static int nsfont_has_char (Lisp_Object entity, int c) { @@ -920,7 +920,7 @@ nsfont_has_char (Lisp_Object entity, int c) /* Return a glyph code of FONT for character C (Unicode code point). - If FONT doesn't have such a glyph, return FONT_INVALID_CODE. */ + If FONT doesn't have such a glyph, return FONT_INVALID_CODE. */ static unsigned int nsfont_encode_char (struct font *font, int c) { @@ -931,7 +931,7 @@ nsfont_encode_char (struct font *font, int c) if (c > 0xFFFF) return FONT_INVALID_CODE; - /* did we already cache this block? */ + /* Did we already cache this block? */ if (!font_info->glyphs[high]) ns_uni_to_glyphs (font_info, high); @@ -942,7 +942,7 @@ nsfont_encode_char (struct font *font, int c) /* Perform the size computation of glyphs of FONT and fill in members of METRICS. The glyphs are specified by their glyph codes in - CODE (length NGLYPHS). */ + CODE (length NGLYPHS). */ static void nsfont_text_extents (struct font *font, unsigned int *code, int nglyphs, struct font_metrics *metrics) @@ -985,11 +985,11 @@ nsfont_text_extents (struct font *font, unsigned int *code, /* Draw glyphs between FROM and TO of S->char2b at (X Y) pixel position of frame F with S->FACE and S->GC. If WITH_BACKGROUND, fill the background in advance. It is assured that WITH_BACKGROUND - is false when (FROM > 0 || TO < S->nchars). */ + is false when (FROM > 0 || TO < S->nchars). */ static int nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, bool with_background) -/* NOTE: focus and clip must be set */ +/* NOTE: focus and clip must be set. */ { static unsigned char cbuf[1024]; unsigned char *c = cbuf; @@ -1019,7 +1019,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, if (font == NULL) font = (struct nsfont_info *)FRAME_FONT (s->f); - /* Select face based on input flags */ + /* Select face based on input flags. */ flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR : (s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE : (s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND : @@ -1049,11 +1049,11 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, /* Convert UTF-16 (?) to UTF-8 and determine advances. Note if we just ask NS to render the string, it will come out differently from the individual - character widths added up because of layout processing. */ + character widths added up because of layout processing. */ { int cwidth, twidth = 0; int hi, lo; - /* FIXME: composition: no vertical displacement is considered. */ + /* FIXME: composition: no vertical displacement is considered. */ t += from; /* advance into composition */ for (i = from; i < to; i++, t++) { @@ -1082,14 +1082,14 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, } else { - if (!font->metrics[hi]) /* FIXME: why/how can we need this now? */ + if (!font->metrics[hi]) /* FIXME: why/how can we need this now? */ ns_glyph_metrics (font, hi); cwidth = font->metrics[hi][lo].width; } twidth += cwidth; #ifdef NS_IMPL_GNUSTEP *adv++ = cwidth; - CHAR_STRING_ADVANCE (*t, c); /* this converts the char to UTF-8 */ + CHAR_STRING_ADVANCE (*t, c); /* This converts the char to UTF-8. */ #else (*adv++).width = cwidth; #endif @@ -1099,7 +1099,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, *c = 0; } - /* fill background if requested */ + /* Fill background if requested. */ if (with_background && !isComposite) { NSRect br = r; @@ -1119,7 +1119,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, } if (s->face->box == FACE_NO_BOX) { - /* expand unboxed top row over internal border */ + /* Expand unboxed top row over internal border. */ if (br.origin.y <= fibw + 1 + mbox_line_width) { br.size.height += br.origin.y; @@ -1258,7 +1258,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, ========================================================================== */ /* Find and cache corresponding glyph codes for unicode values in given - hi-byte block of 256. */ + hi-byte block of 256. */ static void ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) { @@ -1288,7 +1288,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) if (!unichars || !(font_info->glyphs[block])) emacs_abort (); - /* create a string containing all Unicode characters in this block */ + /* Create a string containing all Unicode characters in this block. */ for (idx = block<<8, i = 0; i < 0x100; idx++, i++) if (idx < 0xD800 || idx > 0xDFFF) unichars[i] = idx; @@ -1303,7 +1303,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) length: 0x100 freeWhenDone: NO]; NSGlyphGenerator *glyphGenerator = [NSGlyphGenerator sharedGlyphGenerator]; - /*NSCharacterSet *coveredChars = [nsfont coveredCharacterSet]; */ + /* NSCharacterSet *coveredChars = [nsfont coveredCharacterSet]; */ unsigned int numGlyphs = [font_info->nsfont numberOfGlyphs]; NSUInteger gInd = 0, cInd = 0; @@ -1319,9 +1319,9 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) g = unichars[i]; #else g = glyphStorage->cglyphs[i]; - /* TODO: is this a good check? maybe need to use coveredChars.. */ + /* TODO: is this a good check? Maybe need to use coveredChars. */ if (g > numGlyphs || g == NSNullGlyph) - g = INVALID_GLYPH; /* hopefully unused... */ + g = INVALID_GLYPH; /* Hopefully unused... */ #endif *glyphs = g; } @@ -1337,7 +1337,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) /* Determine and cache metrics for corresponding glyph codes in given - hi-byte block of 256. */ + hi-byte block of 256. */ static void ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block) { @@ -1387,16 +1387,16 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block) metrics->rbearing = lrint (w + rb + LCD_SMOOTHING_MARGIN); metrics->descent = r.origin.y < 0 ? -r.origin.y : 0; - /*lrint (hshrink * [sfont ascender] + expand * hd/2); */ + /* lrint (hshrink * [sfont ascender] + expand * hd/2); */ metrics->ascent = r.size.height - metrics->descent; -/*-lrint (hshrink* [sfont descender] - expand * hd/2); */ + /* -lrint (hshrink* [sfont descender] - expand * hd/2); */ } unblock_input (); } #ifdef NS_IMPL_COCOA -/* helper for font glyph setup */ +/* Helper for font glyph setup. */ @implementation EmacsGlyphStorage - init @@ -1508,7 +1508,7 @@ syms_of_nsfont (void) DEFSYM (Qapple, "apple"); DEFSYM (Qmedium, "medium"); DEFVAR_LISP ("ns-reg-to-script", Vns_reg_to_script, - doc: /* Internal use: maps font registry to Unicode script. */); + doc: /* Internal use: maps font registry to Unicode script. */); ascii_printable = NULL; } diff --git a/src/nsgui.h b/src/nsgui.h index 271fbc1e032..c857d77d9cd 100644 --- a/src/nsgui.h +++ b/src/nsgui.h @@ -19,7 +19,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef __NSGUI_H__ #define __NSGUI_H__ -/* this gets included from a couple of the plain (non-NS) .c files */ +/* This gets included from a couple of the plain (non-NS) .c files. */ #ifdef __OBJC__ #ifdef NS_IMPL_COCOA @@ -73,9 +73,11 @@ typedef unichar XChar2b; #define XCHAR2B_BYTE2(chp) \ (*(chp) & 0x00ff) +/* Used in xdisp.c when comparing faces and frame colors. */ +extern unsigned long ns_color_index_to_rgba(int idx, struct frame *f); /* XXX: xfaces requires these structures, but the question is are we - forced to use them? */ + forced to use them? */ typedef struct _XGCValues { unsigned long foreground; @@ -119,8 +121,8 @@ typedef int Display; typedef Lisp_Object XrmDatabase; -/* some sort of attempt to normalize rectangle handling.. seems a bit much - for what is accomplished */ +/* Some sort of attempt to normalize rectangle handling. Seems a bit + much for what is accomplished. */ typedef struct { int x, y; unsigned width, height; @@ -160,7 +162,7 @@ typedef struct _NSRect { NSPoint origin; NSSize size; } NSRect; -/* This stuff needed by frame.c. */ +/* This stuff needed by frame.c. */ #define ForgetGravity 0 #define NorthWestGravity 1 #define NorthGravity 2 diff --git a/src/nsimage.m b/src/nsimage.m index f3eba5e37b2..7879c5891d6 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -26,7 +26,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) */ /* This should be the first include, as it may set up #defines affecting - interpretation of even the system includes. */ + interpretation of even the system includes. */ #include <config.h> #include "lisp.h" @@ -41,7 +41,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) C interface. This allows easy calling from C files. We could just compile everything as Objective-C, but that might mean slower - compilation and possible difficulties on some platforms.. + compilation and possible difficulties on some platforms. ========================================================================== */ @@ -76,15 +76,19 @@ ns_load_image (struct frame *f, struct image *img, { EmacsImage *eImg = nil; NSSize size; - Lisp_Object lisp_index; + Lisp_Object lisp_index, lisp_rotation; unsigned int index; + double rotation; NSTRACE ("ns_load_image"); eassert (valid_image_p (img->spec)); lisp_index = Fplist_get (XCDR (img->spec), QCindex); - index = INTEGERP (lisp_index) ? XFASTINT (lisp_index) : 0; + index = FIXNUMP (lisp_index) ? XFIXNAT (lisp_index) : 0; + + lisp_rotation = Fplist_get (XCDR (img->spec), QCrotation); + rotation = NUMBERP (lisp_rotation) ? XFLOATINT (lisp_rotation) : 0; if (STRINGP (spec_file)) { @@ -109,10 +113,21 @@ ns_load_image (struct frame *f, struct image *img, if (![eImg setFrame: index]) { add_to_log ("Unable to set index %d for image %s", - make_number (index), img->spec); + make_fixnum (index), img->spec); return 0; } + img->lisp_data = [eImg getMetadata]; + + if (rotation != 0) + { + EmacsImage *temp = [eImg rotate:rotation]; + [eImg release]; + eImg = temp; + } + + [eImg setSizeFromSpec:XCDR (img->spec)]; + size = [eImg size]; img->width = size.width; img->height = size.height; @@ -120,7 +135,6 @@ ns_load_image (struct frame *f, struct image *img, /* 4) set img->pixmap = emacsimage */ img->pixmap = eImg; - img->lisp_data = [eImg getMetadata]; return 1; } @@ -212,7 +226,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) /* Create image from monochrome bitmap. If both FG and BG are 0 - (black), set the background to white and make it transparent. */ + (black), set the background to white and make it transparent. */ - (instancetype)initFromXBM: (unsigned char *)bits width: (int)w height: (int)h fg: (unsigned long)fg bg: (unsigned long)bg { @@ -237,7 +251,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) } { - /* pull bits out to set the (bytewise) alpha mask */ + /* Pull bits out to set the (bytewise) alpha mask. */ int i, j, k; unsigned char *s = bits; unsigned char *rr = planes[0]; @@ -348,7 +362,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) } -/* attempt to pull out pixmap data from a BitmapImageRep; returns NO if fails */ +/* Attempt to pull out pixmap data from a BitmapImageRep; returns NO if fails. */ - (void) setPixmapData { NSEnumerator *reps; @@ -372,15 +386,15 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) } -/* note; this and next work only for image created with initForXPMWithDepth, - initFromSkipXBM, or where setPixmapData was called successfully */ +/* Note: this and next work only for image created with initForXPMWithDepth, + initFromSkipXBM, or where setPixmapData was called successfully. */ /* return ARGB */ - (unsigned long) getPixelAtX: (int)x Y: (int)y { if (bmRep == nil) return 0; - /* this method is faster but won't work for bitmaps */ + /* This method is faster but won't work for bitmaps. */ if (pixmapData[0] != NULL) { int loc = x + y * [self size].width; @@ -443,7 +457,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) } } -/* returns a pattern color, which is cached here */ +/* Returns a pattern color, which is cached here. */ - (NSColor *)stippleMask { if (stippleMask == nil) @@ -451,7 +465,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) return stippleMask; } -/* Find the first NSBitmapImageRep which has multiple frames. */ +/* Find the first NSBitmapImageRep which has multiple frames. */ - (NSBitmapImageRep *)getAnimatedBitmapImageRep { for (NSImageRep * r in [self representations]) @@ -467,7 +481,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) } /* If the image has multiple frames, get a count of them and the - animation delay, if available. */ + animation delay, if available. */ - (Lisp_Object)getMetadata { Lisp_Object metadata = Qnil; @@ -481,14 +495,14 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) floatValue]; if (frames > 1) - metadata = Fcons (Qcount, Fcons (make_number (frames), metadata)); + metadata = Fcons (Qcount, Fcons (make_fixnum (frames), metadata)); if (delay > 0) metadata = Fcons (Qdelay, Fcons (make_float (delay), metadata)); } return metadata; } -/* Attempt to set the animation frame to be displayed. */ +/* Attempt to set the animation frame to be displayed. */ - (BOOL)setFrame: (unsigned int) index { NSBitmapImageRep * bm = [self getAnimatedBitmapImageRep]; @@ -497,7 +511,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) { int frames = [[bm valueForProperty:NSImageFrameCount] intValue]; - /* If index is invalid, give up. */ + /* If index is invalid, give up. */ if (index < 0 || index > frames) return NO; @@ -506,8 +520,106 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) } /* Setting the frame has succeeded, or the image doesn't have - multiple frames. */ + multiple frames. */ return YES; } +- (void)setSizeFromSpec: (Lisp_Object) spec +{ + NSSize size = [self size]; + Lisp_Object value; + double scale = 1, aspect = size.width / size.height; + double width = -1, height = -1, max_width = -1, max_height = -1; + + value = Fplist_get (spec, QCscale); + if (NUMBERP (value)) + scale = XFLOATINT (value) ; + + value = Fplist_get (spec, QCmax_width); + if (NUMBERP (value)) + max_width = XFLOATINT (value); + + value = Fplist_get (spec, QCmax_height); + if (NUMBERP (value)) + max_height = XFLOATINT (value); + + value = Fplist_get (spec, QCwidth); + if (NUMBERP (value)) + { + width = XFLOATINT (value) * scale; + /* :width overrides :max-width. */ + max_width = -1; + } + + value = Fplist_get (spec, QCheight); + if (NUMBERP (value)) + { + height = XFLOATINT (value) * scale; + /* :height overrides :max-height. */ + max_height = -1; + } + + if (width <= 0 && height <= 0) + { + width = size.width * scale; + height = size.height * scale; + } + else if (width > 0 && height <= 0) + height = width / aspect; + else if (height > 0 && width <= 0) + width = height * aspect; + + if (max_width > 0 && width > max_width) + { + width = max_width; + height = max_width / aspect; + } + + if (max_height > 0 && height > max_height) + { + height = max_height; + width = max_height * aspect; + } + + [self setSize:NSMakeSize(width, height)]; +} + +- (instancetype)rotate: (double)rotation +{ + EmacsImage *new_image; + NSPoint new_origin; + NSSize new_size, size = [self size]; + NSRect rect = { NSZeroPoint, [self size] }; + + /* Create a bezier path of the outline of the image and do the + * rotation on it. */ + NSBezierPath *bounds_path = [NSBezierPath bezierPathWithRect:rect]; + NSAffineTransform *transform = [NSAffineTransform transform]; + [transform rotateByDegrees: rotation * -1]; + [bounds_path transformUsingAffineTransform:transform]; + + /* Now we can find out how large the rotated image needs to be. */ + new_size = [bounds_path bounds].size; + new_image = [[EmacsImage alloc] initWithSize:new_size]; + + new_origin = NSMakePoint((new_size.width - size.width)/2, + (new_size.height - size.height)/2); + + [new_image lockFocus]; + + /* Create the final transform. */ + transform = [NSAffineTransform transform]; + [transform translateXBy:new_size.width/2 yBy:new_size.height/2]; + [transform rotateByDegrees: rotation * -1]; + [transform translateXBy:-new_size.width/2 yBy:-new_size.height/2]; + + [transform concat]; + [self drawAtPoint:new_origin fromRect:NSZeroRect + operation:NSCompositingOperationCopy fraction:1]; + + [new_image unlockFocus]; + + return new_image; +} + @end diff --git a/src/nsmenu.m b/src/nsmenu.m index da63064516e..de5db868223 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -22,7 +22,7 @@ Christian Limpach, Scott Bender, Christophe de Dinechin) and code in the Carbon version by Yamamoto Mitsuharu. */ /* This should be the first include, as it may set up #defines affecting - interpretation of even the system includes. */ + interpretation of even the system includes. */ #include <config.h> #include "lisp.h" @@ -47,7 +47,7 @@ Carbon version by Yamamoto Mitsuharu. */ #if 0 -/* Include lisp -> C common menu parsing code */ +/* Include lisp -> C common menu parsing code. */ #define ENCODE_MENU_STRING(str) ENCODE_UTF_8 (str) #include "nsmenu_common.c" #endif @@ -62,7 +62,7 @@ static int trackingMenu; /* NOTE: toolbar implementation is at end, - following complete menu implementation. */ + following complete menu implementation. */ /* ========================================================================== @@ -74,7 +74,7 @@ static int trackingMenu; /* Supposed to discard menubar and free storage. Since we share the menubar among frames and update its context for the focused window, - there is nothing to do here. */ + there is nothing to do here. */ void free_frame_menubar (struct frame *f) { @@ -123,7 +123,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) block_input (); pool = [[NSAutoreleasePool alloc] init]; - /* Menu may have been created automatically; if so, discard it. */ + /* Menu may have been created automatically; if so, discard it. */ if ([menu isKindOfClass: [EmacsMenu class]] == NO) { [menu release]; @@ -147,7 +147,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) if (deep_p) { - /* Fully parse one or more of the submenus. */ + /* Fully parse one or more of the submenus. */ int n = 0; int *submenu_start, *submenu_end; bool *submenu_top_level_items; @@ -172,8 +172,8 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) set_buffer_internal_1 (XBUFFER (buffer)); /* TODO: for some reason this is not needed in other terms, - but some menu updates call Info-extract-pointer which causes - abort-on-error if waiting-for-input. Needs further investigation. */ + but some menu updates call Info-extract-pointer which causes + abort-on-error if waiting-for-input. Needs further investigation. */ owfi = waiting_for_input; waiting_for_input = 0; @@ -214,10 +214,10 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) break; /* FIXME: we'd like to only parse the needed submenu, but this - was causing crashes in the _common parsing code.. need to make - sure proper initialization done.. */ -/* if (submenu && strcmp ([[submenu title] UTF8String], SSDATA (string))) - continue; */ + was causing crashes in the _common parsing code: need to make + sure proper initialization done. */ + /* if (submenu && strcmp ([[submenu title] UTF8String], SSDATA (string))) + continue; */ submenu_start[i] = menu_items_used; @@ -267,17 +267,17 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) set_buffer_internal_1 (prev); - /* Compare the new menu items with previous, and leave off if no change */ + /* Compare the new menu items with previous, and leave off if no change. */ /* FIXME: following other terms here, but seems like this should be - done before parse stage 2 above, since its results aren't used */ + done before parse stage 2 above, since its results aren't used. */ if (previous_menu_items_used && (!submenu || (submenu && submenu == last_submenu)) && menu_items_used == previous_menu_items_used) { for (i = 0; i < previous_menu_items_used; i++) /* FIXME: this ALWAYS fails on Buffers menu items.. something - about their strings causes them to change every time, so we - double-check failures */ + about their strings causes them to change every time, so we + double-check failures. */ if (!EQ (previous_items[i], AREF (menu_items, i))) if (!(STRINGP (previous_items[i]) && STRINGP (AREF (menu_items, i)) @@ -286,7 +286,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) break; if (i == previous_menu_items_used) { - /* No change.. */ + /* No change. */ #if NSMENUPROFILE ftime (&tb); @@ -302,16 +302,16 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) return; } } - /* The menu items are different, so store them in the frame */ - /* FIXME: this is not correct for single-submenu case */ + /* The menu items are different, so store them in the frame. */ + /* FIXME: this is not correct for single-submenu case. */ fset_menu_bar_vector (f, menu_items); f->menu_bar_items_used = menu_items_used; - /* Calls restore_menu_items, etc., as they were outside */ + /* Calls restore_menu_items, etc., as they were outside. */ unbind_to (specpdl_count, Qnil); /* Parse stage 2a: now GC cannot happen during the lifetime of the - widget_value, so it's safe to store data from a Lisp_String */ + widget_value, so it's safe to store data from a Lisp_String. */ wv = first_wv->contents; for (i = 0; i < ASIZE (items); i += 4) { @@ -326,7 +326,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) } /* Now, update the NS menu; if we have a submenu, use that, otherwise - create a new menu for each sub and fill it. */ + create a new menu for each sub and fill it. */ if (submenu) { const char *submenuTitle = [[submenu title] UTF8String]; @@ -358,7 +358,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) wv->button_type = BUTTON_TYPE_NONE; first_wv = wv; - /* Make widget-value tree w/ just the top level menu bar strings */ + /* Make widget-value tree with just the top level menu bar strings. */ items = FRAME_MENU_BAR_ITEMS (f); if (NILP (items)) { @@ -369,7 +369,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) } - /* check if no change.. this mechanism is a bit rough, but ready */ + /* Check if no change: this mechanism is a bit rough, but ready. */ n = ASIZE (items) / 4; if (f == last_f && n_previous_strings == n) { @@ -377,7 +377,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) { string = AREF (items, 4*i+1); - if (EQ (string, make_number (0))) // FIXME: Why??? --Stef + if (EQ (string, make_fixnum (0))) // FIXME: Why??? --Stef continue; if (NILP (string)) { @@ -416,10 +416,10 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) wv->call_data = (void *) (intptr_t) (-1); #ifdef NS_IMPL_COCOA - /* we'll update the real copy under app menu when time comes */ + /* We'll update the real copy under app menu when time comes. */ if (!strcmp ("Services", wv->name)) { - /* but we need to make sure it will update on demand */ + /* But we need to make sure it will update on demand. */ [svcsMenu setFrame: f]; } else @@ -461,7 +461,7 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) /* Main emacs core entry point for menubar menus: called to indicate that the frame's menus have changed, and the *step representation should be updated - from Lisp. */ + from Lisp. */ void set_frame_menubar (struct frame *f, bool first_time, bool deep_p) { @@ -489,7 +489,7 @@ x_activate_menubar (struct frame *f) /* Menu that can define itself from Emacs "widget_value"s and will lazily update itself when user clicked. Based on Carbon/AppKit implementation - by Yamamoto Mitsuharu. */ + by Yamamoto Mitsuharu. */ @implementation EmacsMenu /* override designated initializer */ @@ -556,8 +556,8 @@ x_activate_menubar (struct frame *f) #endif /* NS_IMPL_COCOA */ -/* delegate method called when a submenu is being opened: run a 'deep' call - to set_frame_menubar */ +/* Delegate method called when a submenu is being opened: run a 'deep' call + to set_frame_menubar. */ - (void)menuNeedsUpdate: (NSMenu *)menu { if (!FRAME_LIVE_P (frame)) @@ -664,7 +664,7 @@ x_activate_menubar (struct frame *f) [item setEnabled: wv->enabled]; - /* Draw radio buttons and tickboxes */ + /* Draw radio buttons and tickboxes. */ if (wv->selected && (wv->button_type == BUTTON_TYPE_TOGGLE || wv->button_type == BUTTON_TYPE_RADIO)) [item setState: NSOnState]; @@ -735,7 +735,7 @@ x_activate_menubar (struct frame *f) } -/* adds an empty submenu and returns it */ +/* Adds an empty submenu and returns it. */ - (EmacsMenu *)addSubmenuWithTitle: (const char *)title forFrame: (struct frame *)f { NSString *titleStr = [NSString stringWithUTF8String: title]; @@ -748,7 +748,7 @@ x_activate_menubar (struct frame *f) return submenu; } -/* run a menu in popup mode */ +/* Run a menu in popup mode. */ - (Lisp_Object)runMenuAt: (NSPoint)p forFrame: (struct frame *)f keymaps: (bool)keymaps { @@ -756,7 +756,7 @@ x_activate_menubar (struct frame *f) NSEvent *e, *event; long retVal; -/* p = [view convertPoint:p fromView: nil]; */ + /* p = [view convertPoint:p fromView: nil]; */ p.y = NSHeight ([view frame]) - p.y; e = [[view window] currentEvent]; event = [NSEvent mouseEventWithType: NSEventTypeRightMouseDown @@ -765,7 +765,7 @@ x_activate_menubar (struct frame *f) timestamp: [e timestamp] windowNumber: [[view window] windowNumber] context: nil - eventNumber: 0/*[e eventNumber] */ + eventNumber: 0 /* [e eventNumber] */ clickCount: 1 pressure: 0]; @@ -811,14 +811,14 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags, first_wv = wv; #if 0 - /* FIXME: a couple of one-line differences prevent reuse */ + /* FIXME: a couple of one-line differences prevent reuse. */ wv = digest_single_submenu (0, menu_items_used, 0); #else { widget_value *save_wv = 0, *prev_wv = 0; widget_value **submenu_stack = alloca (menu_items_used * sizeof *submenu_stack); -/* Lisp_Object *subprefix_stack + /* Lisp_Object *subprefix_stack = alloca (menu_items_used * sizeof *subprefix_stack); */ int submenu_depth = 0; int first_pane = 1; @@ -828,7 +828,7 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags, i = 0; while (i < menu_items_used) { - if (EQ (AREF (menu_items, i), Qnil)) + if (NILP (AREF (menu_items, i))) { submenu_stack[submenu_depth++] = save_wv; save_wv = prev_wv; @@ -1009,8 +1009,8 @@ free_frame_tool_bar (struct frame *f) block_input (); view->wait_for_tool_bar = NO; - /* Note: This trigger an animation, which calls windowDidResize - repeatedly. */ + /* Note: This triggers an animation, which calls windowDidResize + repeatedly. */ f->output_data.ns->in_animation = 1; [[view toolbar] setVisible: NO]; f->output_data.ns->in_animation = 0; @@ -1021,7 +1021,7 @@ free_frame_tool_bar (struct frame *f) void update_frame_tool_bar (struct frame *f) /* -------------------------------------------------------------------------- - Update toolbar contents + Update toolbar contents. -------------------------------------------------------------------------- */ { int i, k = 0; @@ -1042,7 +1042,7 @@ update_frame_tool_bar (struct frame *f) [toolbar clearAll]; #endif - /* update EmacsToolbar as in GtkUtils, build items list */ + /* Update EmacsToolbar as in GtkUtils, build items list. */ for (i = 0; i < f->n_tool_bar_items; ++i) { #define TOOLPROP(IDX) AREF (f->tool_bar_items, \ @@ -1070,7 +1070,7 @@ update_frame_tool_bar (struct frame *f) image = TOOLPROP (TOOL_BAR_ITEM_IMAGES); if (VECTORP (image)) { - /* NS toolbar auto-computes disabled and selected images */ + /* NS toolbar auto-computes disabled and selected images. */ idx = TOOL_BAR_IMAGE_ENABLED_SELECTED; eassert (ASIZE (image) >= idx); image = AREF (image, idx); @@ -1119,7 +1119,7 @@ update_frame_tool_bar (struct frame *f) #ifdef NS_IMPL_COCOA if ([toolbar changed]) { - /* inform app that toolbar has changed */ + /* Inform app that toolbar has changed. */ NSDictionary *dict = [toolbar configurationDictionary]; NSMutableDictionary *newDict = [dict mutableCopy]; NSEnumerator *keys = [[dict allKeys] objectEnumerator]; @@ -1252,7 +1252,7 @@ update_frame_tool_bar (struct frame *f) } /* This overrides super's implementation, which automatically sets - all items to enabled state (for some reason). */ + all items to enabled state (for some reason). */ - (void)validateVisibleItems { NSTRACE ("[EmacsToolbar validateVisibleItems]"); @@ -1267,7 +1267,7 @@ update_frame_tool_bar (struct frame *f) { NSTRACE ("[EmacsToolbar toolbar: ...]"); - /* look up NSToolbarItem by identifier and return... */ + /* Look up NSToolbarItem by identifier and return... */ return [identifierToItem objectForKey: itemIdentifier]; } @@ -1275,7 +1275,7 @@ update_frame_tool_bar (struct frame *f) { NSTRACE ("[EmacsToolbar toolbarDefaultItemIdentifiers:]"); - /* return entire set.. */ + /* Return entire set. */ return activeIdentifiers; } @@ -1284,7 +1284,7 @@ update_frame_tool_bar (struct frame *f) { NSTRACE ("[EmacsToolbar toolbarAllowedItemIdentifiers:]"); - /* return entire set... */ + /* return entire set... */ return activeIdentifiers; //return [identifierToItem allKeys]; } @@ -1313,24 +1313,22 @@ update_frame_tool_bar (struct frame *f) ========================================================================== */ /* Needed because NeXTstep does not provide enough control over tooltip - display. */ + display. */ @implementation EmacsTooltip - (instancetype)init { - NSColor *bgcol = [NSColor colorWithCalibratedRed: 1.0 green: 1.0 + NSColor *col = [NSColor colorWithCalibratedRed: 1.0 green: 1.0 blue: 0.792 alpha: 0.95]; - NSColor *fgcol = [NSColor blackColor]; NSFont *font = [NSFont toolTipsFontOfSize: 0]; NSFont *sfont = [font screenFont]; int height = [sfont ascender] - [sfont descender]; -/*[font boundingRectForFont].size.height; */ + /* [font boundingRectForFont].size.height; */ NSRect r = NSMakeRect (0, 0, 100, height+6); textField = [[NSTextField alloc] initWithFrame: r]; [textField setFont: font]; - [textField setTextColor: fgcol]; - [textField setBackgroundColor: bgcol]; + [textField setBackgroundColor: col]; [textField setEditable: NO]; [textField setSelectable: NO]; @@ -1347,7 +1345,7 @@ update_frame_tool_bar (struct frame *f) [win setReleasedWhenClosed: NO]; [win setDelegate: self]; [[win contentView] addSubview: textField]; -/* [win setBackgroundColor: bgcol]; */ + /* [win setBackgroundColor: col]; */ [win setOpaque: NO]; return self; @@ -1375,6 +1373,16 @@ update_frame_tool_bar (struct frame *f) [textField setFrame: r]; } +- (void) setBackgroundColor: (NSColor *)col +{ + [textField setBackgroundColor: col]; +} + +- (void) setForegroundColor: (NSColor *)col +{ + [textField setTextColor: col]; +} + - (void) showAtX: (int)x Y: (int)y for: (int)seconds { NSRect wr = [win frame]; @@ -1550,7 +1558,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) [self setTitle: @""]; area.origin.x += ICONSIZE+2*SPACER; -/* area.origin.y = TEXTHEIGHT; ICONSIZE/2-10+SPACER; */ + /* area.origin.y = TEXTHEIGHT; ICONSIZE/2-10+SPACER; */ area.size.width = 400; area.size.height= TEXTHEIGHT; command = [[[NSTextField alloc] initWithFrame: area] autorelease]; @@ -1561,16 +1569,16 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) [command setSelectable: NO]; [command setFont: [NSFont boldSystemFontOfSize: 13.0]]; -/* area.origin.x = ICONSIZE+2*SPACER; + /* area.origin.x = ICONSIZE+2*SPACER; area.origin.y = TEXTHEIGHT + 2*SPACER; area.size.width = 400; area.size.height= 2; tem = [[[NSBox alloc] initWithFrame: area] autorelease]; [[self contentView] addSubview: tem]; [tem setTitlePosition: NSNoTitle]; - [tem setAutoresizingMask: NSViewWidthSizable];*/ + [tem setAutoresizingMask: NSViewWidthSizable]; */ -/* area.origin.x = ICONSIZE+2*SPACER; */ + /* area.origin.x = ICONSIZE+2*SPACER; */ area.origin.y += TEXTHEIGHT+SPACER; area.size.width = 400; area.size.height= TEXTHEIGHT; @@ -1624,24 +1632,24 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) int row = 0; int buttons = 0, btnnr = 0; - for (; XTYPE (lst) == Lisp_Cons; lst = XCDR (lst)) + for (; CONSP (lst); lst = XCDR (lst)) { item = XCAR (list); - if (XTYPE (item) == Lisp_Cons) + if (CONSP (item)) ++buttons; } if (buttons > 0) button_values = xmalloc (buttons * sizeof *button_values); - for (; XTYPE (list) == Lisp_Cons; list = XCDR (list)) + for (; CONSP (list); list = XCDR (list)) { item = XCAR (list); - if (XTYPE (item) == Lisp_String) + if (STRINGP (item)) { [self addString: SSDATA (item) row: row++]; } - else if (XTYPE (item) == Lisp_Cons) + else if (CONSP (item)) { button_values[btnnr] = XCDR (item); [self addButton: SSDATA (XCAR (item)) value: btnnr row: row++]; @@ -1718,7 +1726,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) Lisp_Object head; [super init]; - if (XTYPE (contents) == Lisp_Cons) + if (CONSP (contents)) { head = Fcar (contents); [self process_dialog: Fcdr (contents)]; @@ -1726,7 +1734,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) else head = contents; - if (XTYPE (head) == Lisp_String) + if (STRINGP (head)) [title setStringValue: [NSString stringWithUTF8String: SSDATA (head)]]; else if (isQ == YES) @@ -1738,7 +1746,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) int i; NSRect r, s, t; - if (cols == 1 && rows > 1) /* Never told where to split */ + if (cols == 1 && rows > 1) /* Never told where to split. */ { [matrix addColumn]; for (i = 0; i < rows/2; i++) @@ -1802,9 +1810,9 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) data2: 0]; timer_fired = YES; - /* We use sto because stopModal/abortModal out of the main loop does not - seem to work in 10.6. But as we use stop we must send a real event so - the stop is seen and acted upon. */ + /* We use stop because stopModal/abortModal out of the main loop + does not seem to work in 10.6. But as we use stop we must send a + real event so the stop is seen and acted upon. */ [NSApp stop:self]; [NSApp postEvent: nxev atStart: NO]; } @@ -1835,7 +1843,7 @@ ns_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) ret = dialog_return; if (! timer_fired) { - if (tmo != nil) [tmo invalidate]; /* Cancels timer */ + if (tmo != nil) [tmo invalidate]; /* Cancels timer. */ break; } } @@ -1866,7 +1874,7 @@ DEFUN ("ns-reset-menu", Fns_reset_menu, Sns_reset_menu, 0, 0, 0, DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0, - doc: /* Return t if a menu or popup dialog is active. */) + doc: /* SKIP: real doc in xmenu.c. */) (void) { return popup_activated () ? Qt : Qnil; diff --git a/src/nsselect.m b/src/nsselect.m index c6dc05d1ec4..cf36c869eb1 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -36,7 +36,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) static Lisp_Object Vselection_alist; -/* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */ +/* NSPasteboardNameGeneral is pretty much analogous to X11 CLIPBOARD. */ static NSString *NXPrimaryPboard; static NSString *NXSecondaryPboard; @@ -54,7 +54,7 @@ static NSString * symbol_to_nsstring (Lisp_Object sym) { CHECK_SYMBOL (sym); - if (EQ (sym, QCLIPBOARD)) return NSGeneralPboard; + if (EQ (sym, QCLIPBOARD)) return NSPasteboardNameGeneral; if (EQ (sym, QPRIMARY)) return NXPrimaryPboard; if (EQ (sym, QSECONDARY)) return NXSecondaryPboard; if (EQ (sym, QTEXT)) return NSStringPboardType; @@ -70,7 +70,7 @@ ns_symbol_to_pb (Lisp_Object symbol) static Lisp_Object ns_string_to_symbol (NSString *t) { - if ([t isEqualToString: NSGeneralPboard]) + if ([t isEqualToString: NSPasteboardNameGeneral]) return QCLIPBOARD; if ([t isEqualToString: NXPrimaryPboard]) return QPRIMARY; @@ -90,20 +90,20 @@ static Lisp_Object clean_local_selection_data (Lisp_Object obj) { if (CONSP (obj) - && INTEGERP (XCAR (obj)) + && FIXNUMP (XCAR (obj)) && CONSP (XCDR (obj)) - && INTEGERP (XCAR (XCDR (obj))) + && FIXNUMP (XCAR (XCDR (obj))) && NILP (XCDR (XCDR (obj)))) obj = Fcons (XCAR (obj), XCDR (obj)); if (CONSP (obj) - && INTEGERP (XCAR (obj)) - && INTEGERP (XCDR (obj))) + && FIXNUMP (XCAR (obj)) + && FIXNUMP (XCDR (obj))) { - if (XINT (XCAR (obj)) == 0) + if (XFIXNUM (XCAR (obj)) == 0) return XCDR (obj); - if (XINT (XCAR (obj)) == -1) - return make_number (- XINT (XCDR (obj))); + if (XFIXNUM (XCAR (obj)) == -1) + return make_fixnum (- XFIXNUM (XCDR (obj))); } if (VECTORP (obj)) @@ -164,7 +164,7 @@ ns_get_our_change_count_for (Lisp_Object selection) static void ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype) { - if (EQ (str, Qnil)) + if (NILP (str)) { [pb declareTypes: [NSArray array] owner: nil]; } @@ -399,7 +399,7 @@ these literal upper-case names.) The symbol nil is the same as return Qnil; CHECK_SYMBOL (selection); - if (EQ (selection, Qnil)) selection = QPRIMARY; + if (NILP (selection)) selection = QPRIMARY; if (EQ (selection, Qt)) selection = QSECONDARY; pb = ns_symbol_to_pb (selection); if (pb == nil) return Qnil; @@ -421,7 +421,7 @@ and t is the same as `SECONDARY'. */) { check_window_system (NULL); CHECK_SYMBOL (selection); - if (EQ (selection, Qnil)) selection = QPRIMARY; + if (NILP (selection)) selection = QPRIMARY; if (EQ (selection, Qt)) selection = QSECONDARY; return ns_get_pb_change_count (selection) == ns_get_our_change_count_for (selection) @@ -469,7 +469,7 @@ nxatoms_of_nsselect (void) pasteboard_changecount = [[NSMutableDictionary dictionaryWithObjectsAndKeys: - [NSNumber numberWithLong:0], NSGeneralPboard, + [NSNumber numberWithLong:0], NSPasteboardNameGeneral, [NSNumber numberWithLong:0], NXPrimaryPboard, [NSNumber numberWithLong:0], NXSecondaryPboard, [NSNumber numberWithLong:0], NSStringPboardType, diff --git a/src/nsterm.h b/src/nsterm.h index 35dd9b3c3b6..089cbccbf0c 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -29,7 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* CGFloat on GNUstep may be 4 or 8 byte, but functions expect float* for some versions. - On Cocoa >= 10.5, functions expect CGFloat *. Make compatible type. */ + On Cocoa >= 10.5, functions expect CGFloat *. Make compatible type. */ #ifdef NS_IMPL_COCOA typedef CGFloat EmacsCGFloat; #elif GNUSTEP_GUI_MAJOR_VERSION > 0 || GNUSTEP_GUI_MINOR_VERSION >= 22 @@ -85,7 +85,7 @@ typedef float EmacsCGFloat; can become misaligned, as all threads (currently) share one state. This is post prominent when the EVENTS part is enabled. - Note that the trace system, when enabled, use the GCC/Clang + Note that the trace system, when enabled, uses the GCC/Clang "cleanup" extension. */ /* For example, the following is the output of `M-x @@ -170,7 +170,7 @@ void nstrace_leave(int *); void nstrace_restore_global_trace_state(int *); char const * nstrace_fullscreen_type_name (int); -/* printf-style trace output. Output is aligned with contained heading. */ +/* printf-style trace output. Output is aligned with contained heading. */ #define NSTRACE_MSG_NO_DASHES(...) \ do \ { \ @@ -192,7 +192,7 @@ char const * nstrace_fullscreen_type_name (int); /* Macros for printing complex types. NSTRACE_FMT_what -- Printf format string for "what". - NSTRACE_ARG_what(x) -- Printf argument for "what". */ + NSTRACE_ARG_what(x) -- Printf argument for "what". */ #define NSTRACE_FMT_SIZE "(W:%.0f H:%.0f)" #define NSTRACE_ARG_SIZE(elt) (elt).width, (elt).height @@ -208,7 +208,7 @@ char const * nstrace_fullscreen_type_name (int); #define NSTRACE_ARG_FSTYPE(elt) nstrace_fullscreen_type_name(elt) -/* Macros for printing complex types as extra information. */ +/* Macros for printing complex types as extra information. */ #define NSTRACE_SIZE(str,size) \ NSTRACE_MSG (str ": " NSTRACE_FMT_SIZE, \ @@ -236,7 +236,7 @@ char const * nstrace_fullscreen_type_name (int); NSTRACE_FMT_RETURN - A string literal representing a returned value. Useful when creating a format string - to printf-like constructs like NSTRACE(). */ + to printf-like constructs like NSTRACE(). */ #define NSTRACE_FMT_RETURN "->>" @@ -262,7 +262,7 @@ char const * nstrace_fullscreen_type_name (int); NSTRACE_WHEN (cond, fmt, ...) -- Enable trace output when COND is true. NSTRACE_UNLESS (cond, fmt, ...) -- Enable trace output unless COND is - true. */ + true. */ @@ -278,7 +278,7 @@ char const * nstrace_fullscreen_type_name (int); /* Unsilence called functions. Concretely, this us used to allow "event" functions to be silenced - while trace output can be printed for functions they call. */ + while trace output can be printed for functions they call. */ #define NSTRACE_UNSILENCE() do { nstrace_enabled_global = 1; } while(0) #endif /* NSTRACE_ENABLED */ @@ -286,7 +286,7 @@ char const * nstrace_fullscreen_type_name (int); #define NSTRACE(...) NSTRACE_WHEN(1, __VA_ARGS__) #define NSTRACE_UNLESS(cond, ...) NSTRACE_WHEN(!(cond), __VA_ARGS__) -/* Non-trace replacement versions. */ +/* Non-trace replacement versions. */ #ifndef NSTRACE_WHEN #define NSTRACE_WHEN(...) #endif @@ -332,7 +332,7 @@ char const * nstrace_fullscreen_type_name (int); #endif -/* If the compiler doesn't support instancetype, map it to id. */ +/* If the compiler doesn't support instancetype, map it to id. */ #ifndef NATIVE_OBJC_INSTANCETYPE typedef id instancetype; #endif @@ -356,7 +356,7 @@ typedef id instancetype; ========================================================================== */ -/* We override sendEvent: as a means to stop/start the event loop */ +/* We override sendEvent: as a means to stop/start the event loop. */ @interface EmacsApp : NSApplication { #ifdef NS_IMPL_COCOA @@ -456,7 +456,7 @@ typedef id instancetype; #endif - (int)fullscreenState; -/* Non-notification versions of NSView methods. Used for direct calls. */ +/* Non-notification versions of NSView methods. Used for direct calls. */ - (void)windowWillEnterFullScreen; - (void)windowDidEnterFullScreen; - (void)windowWillExitFullScreen; @@ -465,7 +465,7 @@ typedef id instancetype; @end -/* Small utility used for processing resize events under Cocoa. */ +/* Small utility used for processing resize events under Cocoa. */ @interface EmacsWindow : NSWindow { NSPoint grabOffset; @@ -585,6 +585,8 @@ typedef id instancetype; } - (instancetype) init; - (void) setText: (char *)text; +- (void) setBackgroundColor: (NSColor *)col; +- (void) setForegroundColor: (NSColor *)col; - (void) showAtX: (int)x Y: (int)y for: (int)seconds; - (void) hide; - (BOOL) isActive; @@ -646,6 +648,8 @@ typedef id instancetype; - (NSColor *)stippleMask; - (Lisp_Object)getMetadata; - (BOOL)setFrame: (unsigned int) index; +- (void)setSizeFromSpec: (Lisp_Object) spec; +- (instancetype)rotate: (double)rotation; @end @@ -718,7 +722,7 @@ extern NSArray *ns_send_types, *ns_return_types; extern NSString *ns_app_name; extern EmacsMenu *svcsMenu; -/* Apple removed the declaration, but kept the implementation */ +/* Apple removed the declaration, but kept the implementation. */ #if defined (NS_IMPL_COCOA) @interface NSApplication (EmacsApp) - (void)setAppleMenu: (NSMenu *)menu; @@ -748,8 +752,8 @@ extern EmacsMenu *svcsMenu; #define KEY_NS_TOGGLE_TOOLBAR ((1<<28)|(0<<16)|13) #define KEY_NS_SHOW_PREFS ((1<<28)|(0<<16)|14) -/* could use list to store these, but rest of emacs has a big infrastructure - for managing a table of bitmap "records" */ +/* Could use list to store these, but rest of emacs has a big infrastructure + for managing a table of bitmap "records". */ struct ns_bitmap_record { #ifdef __OBJC__ @@ -762,7 +766,7 @@ struct ns_bitmap_record int height, width, depth; }; -/* this to map between emacs color indices and NSColor objects */ +/* This maps between emacs color indices and NSColor objects. */ struct ns_color_table { ptrdiff_t size; @@ -786,7 +790,7 @@ struct ns_color_table #define BLUE_FROM_ULONG(color) ((color) & 0xff) /* Do not change `* 0x101' in the following lines to `<< 8'. If - changed, image masks in 1-bit depth will not work. */ + changed, image masks in 1-bit depth will not work. */ #define RED16_FROM_ULONG(color) (RED_FROM_ULONG(color) * 0x101) #define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG(color) * 0x101) #define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG(color) * 0x101) @@ -798,7 +802,7 @@ struct nsfont_info char *name; /* PostScript name, uniquely identifies on NS systems */ - /* The following metrics are stored as float rather than int. */ + /* The following metrics are stored as float rather than int. */ float width; /* Maximum advance for the font. */ float height; @@ -819,26 +823,26 @@ struct nsfont_info char bold, ital; /* convenience flags */ char synthItal; XCharStruct max_bounds; - /* we compute glyph codes and metrics on-demand in blocks of 256 indexed - by hibyte, lobyte */ + /* We compute glyph codes and metrics on-demand in blocks of 256 indexed + by hibyte, lobyte. */ unsigned short **glyphs; /* map Unicode index to glyph */ struct font_metrics **metrics; }; -/* init'd in ns_initialize_display_info () */ +/* Initialized in ns_initialize_display_info (). */ struct ns_display_info { /* Chain of all ns_display_info structures. */ struct ns_display_info *next; - /* The generic display parameters corresponding to this NS display. */ + /* The generic display parameters corresponding to this NS display. */ struct terminal *terminal; /* This is a cons cell of the form (NAME . FONT-LIST-CACHE). */ Lisp_Object name_list_element; - /* The number of fonts loaded. */ + /* The number of fonts loaded. */ int n_fonts; /* Minimum width over all characters in all fonts in font_table. */ @@ -868,10 +872,10 @@ struct ns_display_info /* Xism */ XrmDatabase xrdb; - /* The cursor to use for vertical scroll bars. */ + /* The cursor to use for vertical scroll bars. */ Cursor vertical_scroll_bar_cursor; - /* The cursor to use for horizontal scroll bars. */ + /* The cursor to use for horizontal scroll bars. */ Cursor horizontal_scroll_bar_cursor; /* Information about the range of text currently shown in @@ -927,7 +931,7 @@ struct ns_output void *toolbar; #endif - /* NSCursors init'ed in initFrameFromEmacs */ + /* NSCursors are initialized in initFrameFromEmacs. */ Cursor text_cursor; Cursor nontext_cursor; Cursor modeline_cursor; @@ -965,10 +969,10 @@ struct ns_output scroll bars, in pixels. */ int vertical_scroll_bar_extra; - /* The height of the titlebar decoration (included in NSWindow's frame). */ + /* The height of the titlebar decoration (included in NSWindow's frame). */ int titlebar_height; - /* The height of the toolbar if displayed, else 0. */ + /* The height of the toolbar if displayed, else 0. */ int toolbar_height; /* This is the Emacs structure for the NS display this frame is on. */ @@ -977,11 +981,11 @@ struct ns_output /* Non-zero if we are zooming (maximizing) the frame. */ int zooming; - /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */ + /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */ int in_animation; }; -/* this dummy decl needed to support TTYs */ +/* This dummy declaration needed to support TTYs. */ struct x_output { int unused; @@ -1015,12 +1019,12 @@ struct x_output #define FRAME_FONT(f) ((f)->output_data.ns->font) #ifdef __OBJC__ -#define XNS_SCROLL_BAR(vec) ((id) XSAVE_POINTER (vec, 0)) +#define XNS_SCROLL_BAR(vec) ((id) xmint_pointer (vec)) #else -#define XNS_SCROLL_BAR(vec) XSAVE_POINTER (vec, 0) +#define XNS_SCROLL_BAR(vec) xmint_pointer (vec) #endif -/* Compute pixel height of the frame's titlebar. */ +/* Compute pixel height of the frame's titlebar. */ #define FRAME_NS_TITLEBAR_HEIGHT(f) \ (NSHeight([FRAME_NS_VIEW (f) frame]) == 0 ? \ 0 \ @@ -1029,7 +1033,7 @@ struct x_output [[FRAME_NS_VIEW (f) window] frame] \ styleMask:[[FRAME_NS_VIEW (f) window] styleMask]]))) -/* Compute pixel height of the toolbar. */ +/* Compute pixel height of the toolbar. */ #define FRAME_TOOLBAR_HEIGHT(f) \ (([[FRAME_NS_VIEW (f) window] toolbar] == nil \ || ! [[FRAME_NS_VIEW (f) window] toolbar].isVisible) ? \ @@ -1039,7 +1043,7 @@ struct x_output styleMask:[[FRAME_NS_VIEW (f) window] styleMask]]) \ - NSHeight([[[FRAME_NS_VIEW (f) window] contentView] frame]))) -/* Compute pixel size for vertical scroll bars */ +/* Compute pixel size for vertical scroll bars. */ #define NS_SCROLL_BAR_WIDTH(f) \ (FRAME_HAS_VERTICAL_SCROLL_BARS (f) \ ? rint (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0 \ @@ -1047,7 +1051,7 @@ struct x_output : (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f))) \ : 0) -/* Compute pixel size for horizontal scroll bars */ +/* Compute pixel size for horizontal scroll bars. */ #define NS_SCROLL_BAR_HEIGHT(f) \ (FRAME_HAS_HORIZONTAL_SCROLL_BARS (f) \ ? rint (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0 \ @@ -1055,22 +1059,22 @@ struct x_output : (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f))) \ : 0) -/* Difference btwn char-column-calculated and actual SB widths. - This is only a concern for rendering when SB on left. */ +/* Difference between char-column-calculated and actual SB widths. + This is only a concern for rendering when SB on left. */ #define NS_SCROLL_BAR_ADJUST(w, f) \ (WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_LEFT (w) ? \ (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f) \ - NS_SCROLL_BAR_WIDTH (f)) : 0) -/* Difference btwn char-line-calculated and actual SB heights. - This is only a concern for rendering when SB on top. */ +/* Difference between char-line-calculated and actual SB heights. + This is only a concern for rendering when SB on top. */ #define NS_SCROLL_BAR_ADJUST_HORIZONTALLY(w, f) \ (WINDOW_HAS_HORIZONTAL_SCROLL_BARS (w) ? \ (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \ - NS_SCROLL_BAR_HEIGHT (f)) : 0) /* Calculate system coordinates of the left and top of the parent - window or, if there is no parent window, the screen. */ + window or, if there is no parent window, the screen. */ #define NS_PARENT_WINDOW_LEFT_POS(f) \ (FRAME_PARENT_FRAME (f) != NULL \ ? [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.origin.x : 0) @@ -1090,7 +1094,7 @@ struct x_output #define WHITE_PIX_DEFAULT(f) 0xFFFFFF /* First position where characters can be shown (instead of scrollbar, if - it is on left. */ + it is on left. */ #define FIRST_CHAR_POSITION(f) \ (! (FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f)) ? 0 \ : FRAME_SCROLL_BAR_COLS (f)) @@ -1114,7 +1118,7 @@ extern void nsfont_make_fontset_for_font (Lisp_Object name, struct glyph_string; void ns_dump_glyphstring (struct glyph_string *s) EXTERNALLY_VISIBLE; -/* Implemented in nsterm, published in or needed from nsfns. */ +/* Implemented in nsterm, published in or needed from nsfns. */ extern Lisp_Object ns_list_fonts (struct frame *f, Lisp_Object pattern, int size, int maxnames); extern void ns_clear_frame (struct frame *f); @@ -1156,6 +1160,9 @@ extern void ns_release_autorelease_pool (void *); extern const char *ns_get_defaults_value (const char *key); extern void ns_init_locale (void); +#ifdef NS_IMPL_COCOA +extern void ns_enable_screen_updates (void); +#endif /* in nsmenu */ extern void update_frame_tool_bar (struct frame *f); @@ -1230,12 +1237,6 @@ struct input_event; extern void ns_init_events (struct input_event *); extern void ns_finish_events (void); -#ifdef __OBJC__ -/* Needed in nsfns.m. */ -extern void -ns_set_represented_filename (NSString *fstr, struct frame *f); - -#endif #ifdef NS_IMPL_GNUSTEP extern char gnustep_base_version[]; /* version tracking */ @@ -1244,13 +1245,13 @@ extern char gnustep_base_version[]; /* version tracking */ #define MINWIDTH 10 #define MINHEIGHT 10 -/* Screen max coordinate - Using larger coordinates causes movewindow/placewindow to abort */ +/* Screen max coordinate -- using larger coordinates causes + movewindow/placewindow to abort. */ #define SCREENMAX 16000 #define NS_SCROLL_BAR_WIDTH_DEFAULT [EmacsScroller scrollerWidth] #define NS_SCROLL_BAR_HEIGHT_DEFAULT [EmacsScroller scrollerHeight] -/* This is to match emacs on other platforms, ugly though it is. */ +/* This is to match emacs on other platforms, ugly though it is. */ #define NS_SELECTION_BG_COLOR_DEFAULT @"LightGoldenrod2"; #define NS_SELECTION_FG_COLOR_DEFAULT @"Black"; #define RESIZE_HANDLE_SIZE 12 @@ -1260,7 +1261,7 @@ extern char gnustep_base_version[]; /* version tracking */ ? (min) : (((x)>(max)) ? (max) : (x))) #define SCREENMAXBOUND(x) (IN_BOUND (-SCREENMAX, x, SCREENMAX)) -/* macOS 10.7 introduces some new constants. */ +/* macOS 10.7 introduces some new constants. */ #if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_7) #define NSFullScreenWindowMask (1 << 14) #define NSWindowCollectionBehaviorFullScreenPrimary (1 << 7) @@ -1269,7 +1270,7 @@ extern char gnustep_base_version[]; /* version tracking */ #define NSAppKitVersionNumber10_7 1138 #endif /* !defined (MAC_OS_X_VERSION_10_7) */ -/* macOS 10.12 deprecates a bunch of constants. */ +/* macOS 10.12 deprecates a bunch of constants. */ #if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_12) #define NSEventModifierFlagCommand NSCommandKeyMask #define NSEventModifierFlagControl NSControlKeyMask @@ -1306,18 +1307,24 @@ extern char gnustep_base_version[]; /* version tracking */ #define NSWindowStyleMaskUtilityWindow NSUtilityWindowMask #define NSAlertStyleCritical NSCriticalAlertStyle #define NSControlSizeRegular NSRegularControlSize +#define NSCompositingOperationCopy NSCompositeCopy -/* And adds NSWindowStyleMask. */ +/* And adds NSWindowStyleMask. */ #ifdef __OBJC__ typedef NSUInteger NSWindowStyleMask; #endif -/* Window tabbing mode enums are new too. */ +/* Window tabbing mode enums are new too. */ enum NSWindowTabbingMode { NSWindowTabbingModeAutomatic, NSWindowTabbingModePreferred, NSWindowTabbingModeDisallowed }; +#endif /* !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_12) */ + +#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_13) +/* Deprecated in macOS 10.13. */ +#define NSPasteboardNameGeneral NSGeneralPboard #endif #endif /* HAVE_NS */ diff --git a/src/nsterm.m b/src/nsterm.m index c09f684daf4..016c0447609 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -27,7 +27,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) */ /* This should be the first include, as it may set up #defines affecting - interpretation of even the system includes. */ + interpretation of even the system includes. */ #include <config.h> #include <fcntl.h> @@ -37,6 +37,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #include <time.h> #include <signal.h> #include <unistd.h> +#include <stdbool.h> #include <c-ctype.h> #include <c-strcase.h> @@ -66,6 +67,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #ifdef NS_IMPL_COCOA #include "macfont.h" +#include <Carbon/Carbon.h> #endif static EmacsMenu *dockMenu; @@ -82,7 +84,7 @@ static EmacsMenu *mainMenu; #if NSTRACE_ENABLED /* The following use "volatile" since they can be accessed from - parallel threads. */ + parallel threads. */ volatile int nstrace_num = 0; volatile int nstrace_depth = 0; @@ -91,10 +93,10 @@ volatile int nstrace_depth = 0; TODO: This should really be a thread-local variable, to avoid that a function with disabled trace thread silence trace output in - another. However, in practice this seldom is a problem. */ + another. However, in practice this seldom is a problem. */ volatile int nstrace_enabled_global = 1; -/* Called when nstrace_enabled goes out of scope. */ +/* Called when nstrace_enabled goes out of scope. */ void nstrace_leave(int * pointer_to_nstrace_enabled) { if (*pointer_to_nstrace_enabled) @@ -104,7 +106,7 @@ void nstrace_leave(int * pointer_to_nstrace_enabled) } -/* Called when nstrace_saved_enabled_global goes out of scope. */ +/* Called when nstrace_saved_enabled_global goes out of scope. */ void nstrace_restore_global_trace_state(int * pointer_to_saved_enabled_global) { nstrace_enabled_global = *pointer_to_saved_enabled_global; @@ -159,7 +161,7 @@ char const * nstrace_fullscreen_type_name (int fs_type) { /* FIXMES: We're checking for colorWithSRGBRed here so this will only work in the same place as in the method above. It should - really be a check whether we're on macOS 10.7 or above. */ + really be a check whether we're on macOS 10.7 or above. */ #if defined (NS_IMPL_COCOA) \ && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 if (ns_use_srgb_colorspace @@ -183,7 +185,7 @@ char const * nstrace_fullscreen_type_name (int fs_type) /* Convert a symbol indexed with an NSxxx value to a value as defined in keyboard.c (lispy_function_key). I hope this is a correct way - of doing things... */ + of doing things... */ static unsigned convert_ns_to_X_keysym[] = { NSHomeFunctionKey, 0x50, @@ -232,9 +234,9 @@ static unsigned convert_ns_to_X_keysym[] = NSF23FunctionKey, 0xD4, NSF24FunctionKey, 0xD5, - NSBackspaceCharacter, 0x08, /* 8: Not on some KBs. */ - NSDeleteCharacter, 0xFF, /* 127: Big 'delete' key upper right. */ - NSDeleteFunctionKey, 0x9F, /* 63272: Del forw key off main array. */ + NSBackspaceCharacter, 0x08, /* 8: Not on some KBs. */ + NSDeleteCharacter, 0xFF, /* 127: Big 'delete' key upper right. */ + NSDeleteFunctionKey, 0x9F, /* 63272: Del forw key off main array. */ NSTabCharacter, 0x09, 0x19, 0x09, /* left tab->regular since pass shift */ @@ -264,7 +266,7 @@ static unsigned convert_ns_to_X_keysym[] = /* On macOS picks up the default NSGlobalDomain AppleAntiAliasingThreshold, the maximum font size to NOT antialias. On GNUstep there is currently - no way to control this behavior. */ + no way to control this behavior. */ float ns_antialias_threshold; NSArray *ns_send_types = 0, *ns_return_types = 0; @@ -280,8 +282,11 @@ static int ns_window_num = 0; static BOOL ns_fake_keydown = NO; #ifdef NS_IMPL_COCOA static BOOL ns_menu_bar_is_hidden = NO; + +/* The number of times NSDisableScreenUpdates has been called. */ +static int disable_screen_updates_count = 0; #endif -/*static int debug_lock = 0; */ +/* static int debug_lock = 0; */ /* event loop */ static BOOL send_appdefined = YES; @@ -316,9 +321,6 @@ static struct { NULL, 0, 0 }; -static NSString *represented_filename = nil; -static struct frame *represented_frame = 0; - #ifdef NS_IMPL_COCOA /* * State for pending menu activation: @@ -345,31 +347,56 @@ static CGPoint menu_mouse_point; #define NSRightCommandKeyMask (0x000010 | NSEventModifierFlagCommand) #define NSLeftAlternateKeyMask (0x000020 | NSEventModifierFlagOption) #define NSRightAlternateKeyMask (0x000040 | NSEventModifierFlagOption) -#define EV_MODIFIERS2(flags) \ - (((flags & NSEventModifierFlagHelp) ? \ - hyper_modifier : 0) \ - | (!EQ (ns_right_alternate_modifier, Qleft) && \ - ((flags & NSRightAlternateKeyMask) \ - == NSRightAlternateKeyMask) ? \ - parse_solitary_modifier (ns_right_alternate_modifier) : 0) \ - | ((flags & NSEventModifierFlagOption) ? \ - parse_solitary_modifier (ns_alternate_modifier) : 0) \ - | ((flags & NSEventModifierFlagShift) ? \ - shift_modifier : 0) \ - | (!EQ (ns_right_control_modifier, Qleft) && \ - ((flags & NSRightControlKeyMask) \ - == NSRightControlKeyMask) ? \ - parse_solitary_modifier (ns_right_control_modifier) : 0) \ - | ((flags & NSEventModifierFlagControl) ? \ - parse_solitary_modifier (ns_control_modifier) : 0) \ - | ((flags & NS_FUNCTION_KEY_MASK) ? \ - parse_solitary_modifier (ns_function_modifier) : 0) \ - | (!EQ (ns_right_command_modifier, Qleft) && \ - ((flags & NSRightCommandKeyMask) \ - == NSRightCommandKeyMask) ? \ - parse_solitary_modifier (ns_right_command_modifier) : 0) \ - | ((flags & NSEventModifierFlagCommand) ? \ - parse_solitary_modifier (ns_command_modifier):0)) + +static unsigned int +ev_modifiers_helper (unsigned int flags, unsigned int left_mask, + unsigned int right_mask, unsigned int either_mask, + Lisp_Object left_modifier, Lisp_Object right_modifier) +{ + unsigned int modifiers = 0; + + if (flags & either_mask) + { + BOOL left_key = (flags & left_mask) == left_mask; + BOOL right_key = (flags & right_mask) == right_mask + && ! EQ (right_modifier, Qleft); + + if (right_key) + modifiers |= parse_solitary_modifier (right_modifier); + + /* GNUstep (and possibly macOS in certain circumstances) doesn't + differentiate between the left and right keys, so if we can't + identify which key it is, we use the left key setting. */ + if (left_key || ! right_key) + modifiers |= parse_solitary_modifier (left_modifier); + } + + return modifiers; +} + +#define EV_MODIFIERS2(flags) \ + (((flags & NSEventModifierFlagHelp) ? \ + hyper_modifier : 0) \ + | ((flags & NSEventModifierFlagShift) ? \ + shift_modifier : 0) \ + | ((flags & NS_FUNCTION_KEY_MASK) ? \ + parse_solitary_modifier (ns_function_modifier) : 0) \ + | ev_modifiers_helper (flags, NSLeftControlKeyMask, \ + NSRightControlKeyMask, \ + NSEventModifierFlagControl, \ + ns_control_modifier, \ + ns_right_control_modifier) \ + | ev_modifiers_helper (flags, NSLeftCommandKeyMask, \ + NSRightCommandKeyMask, \ + NSEventModifierFlagCommand, \ + ns_command_modifier, \ + ns_right_command_modifier) \ + | ev_modifiers_helper (flags, NSLeftAlternateKeyMask, \ + NSRightAlternateKeyMask, \ + NSEventModifierFlagOption, \ + ns_alternate_modifier, \ + ns_right_alternate_modifier)) + #define EV_MODIFIERS(e) EV_MODIFIERS2 ([e modifierFlags]) #define EV_UDMODIFIERS(e) \ @@ -388,7 +415,7 @@ static CGPoint menu_mouse_point; (([e type] == NSEventTypeRightMouseDown) || ([e type] == NSEventTypeRightMouseUp)) ? 2 : \ [e buttonNumber] - 1) -/* Convert the time field to a timestamp in milliseconds. */ +/* Convert the time field to a timestamp in milliseconds. */ #define EV_TIMESTAMP(e) ([e timestamp] * 1000) /* This is a piece of code which is common to all the event handling @@ -418,14 +445,14 @@ static CGPoint menu_mouse_point; /* These flags will be OR'd or XOR'd with the NSWindow's styleMask - property depending on what we're doing. */ + property depending on what we're doing. */ #define FRAME_DECORATED_FLAGS (NSWindowStyleMaskTitled \ | NSWindowStyleMaskResizable \ | NSWindowStyleMaskMiniaturizable \ | NSWindowStyleMaskClosable) #define FRAME_UNDECORATED_FLAGS NSWindowStyleMaskBorderless -/* TODO: get rid of need for these forward declarations */ +/* 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); @@ -437,13 +464,6 @@ static void ns_judge_scroll_bars (struct frame *f); ========================================================================== */ void -ns_set_represented_filename (NSString *fstr, struct frame *f) -{ - represented_filename = [fstr retain]; - represented_frame = f; -} - -void ns_init_events (struct input_event *ev) { EVENT_INIT (*ev); @@ -602,7 +622,7 @@ ns_load_path (void) void ns_init_locale (void) /* macOS doesn't set any environment variables for the locale when run - from the GUI. Get the locale from the OS and set LANG. */ + from the GUI. Get the locale from the OS and set LANG. */ { NSLocale *locale = [NSLocale currentLocale]; @@ -613,11 +633,11 @@ ns_init_locale (void) /* It seems macOS should probably use UTF-8 everywhere. 'localeIdentifier' does not specify the encoding, and I can't find any way to get the OS to tell us which encoding to use, - so hard-code '.UTF-8'. */ + so hard-code '.UTF-8'. */ NSString *localeID = [NSString stringWithFormat:@"%@.UTF-8", [locale localeIdentifier]]; - /* Set LANG to locale, but not if LANG is already set. */ + /* Set LANG to locale, but not if LANG is already set. */ setenv("LANG", [localeID UTF8String], 0); } @catch (NSException *e) @@ -640,7 +660,7 @@ ns_release_object (void *obj) void ns_retain_object (void *obj) /* -------------------------------------------------------------------------- - Retain an object (callable from C) + Retain an object (callable from C) -------------------------------------------------------------------------- */ { [(id)obj retain]; @@ -667,6 +687,40 @@ ns_release_autorelease_pool (void *pool) } +#ifdef NS_IMPL_COCOA +/* Disabling screen updates can be used to make several actions appear + "atomic" to the end user. It seems some actions can still update + the display, though. + + When we re-enable screen updates the number of calls to + NSEnableScreenUpdates should match the number to + NSDisableScreenUpdates. + + We use these functions to prevent the user seeing a blank frame + after it has been resized. x_set_window_size disables updates and + when redisplay completes unwind_redisplay enables them again + (bug#30699). */ + +static void +ns_disable_screen_updates (void) +{ + NSDisableScreenUpdates (); + disable_screen_updates_count++; +} + +void +ns_enable_screen_updates (void) +/* Re-enable screen updates. Called from unwind_redisplay. */ +{ + while (disable_screen_updates_count > 0) + { + NSEnableScreenUpdates (); + disable_screen_updates_count--; + } +} +#endif + + static BOOL ns_menu_bar_should_be_hidden (void) /* True, if the menu bar should be hidden. */ @@ -739,7 +793,7 @@ ns_screen_margins (NSScreen *screen) static struct EmacsMargins ns_screen_margins_ignoring_hidden_dock (NSScreen *screen) /* The parts of SCREEN used by the operating system, excluding the parts -reserved for an hidden dock. */ + reserved for a hidden dock. */ { NSTRACE ("ns_screen_margins_ignoring_hidden_dock"); @@ -1233,7 +1287,7 @@ ns_reset_clipping (struct frame *f) @interface EmacsBell : NSImageView { - // Number of currently active bell:s. + // Number of currently active bells. unsigned int nestCount; NSView * mView; bool isAttached; @@ -1494,7 +1548,7 @@ x_make_frame_visible (struct frame *f) NSTRACE ("x_make_frame_visible"); /* XXX: at some points in past this was not needed, as the only place that called this (frame.c:Fraise_frame ()) also called raise_lower; - if this ends up the case again, comment this out again. */ + if this ends up the case again, comment this out again. */ if (!FRAME_VISIBLE_P (f)) { EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f); @@ -1517,7 +1571,7 @@ x_make_frame_visible (struct frame *f) } /* Making a frame invisible seems to break the parent->child - relationship, so reinstate it. */ + relationship, so reinstate it. */ if ([window parentWindow] == nil && FRAME_PARENT_FRAME (f) != NULL) { NSWindow *parent = [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window]; @@ -1529,7 +1583,7 @@ x_make_frame_visible (struct frame *f) /* If the parent frame moved while the child frame was invisible, the child frame's position won't have been - updated. Make sure it's in the right place now. */ + updated. Make sure it's in the right place now. */ x_set_offset(f, f->left_pos, f->top_pos, 0); } } @@ -1571,8 +1625,8 @@ x_iconify_frame (struct frame *f) if ([[view window] windowNumber] <= 0) { - /* the window is still deferred. Make it very small, bring it - on screen and order it out. */ + /* The window is still deferred. Make it very small, bring it + on screen and order it out. */ NSRect s = { { 100, 100}, {0, 0} }; NSRect t; t = [[view window] frame]; @@ -1583,7 +1637,7 @@ x_iconify_frame (struct frame *f) } /* Processing input while Emacs is being minimized can cause a - crash, so block it for the duration. */ + crash, so block it for the duration. */ block_input(); [[view window] miniaturize: NSApp]; unblock_input(); @@ -1617,10 +1671,6 @@ x_free_frame_resources (struct frame *f) dpyinfo->x_highlight_frame = 0; if (f == hlinfo->mouse_face_mouse_frame) reset_mouse_highlight (hlinfo); - /* Ensure that sendEvent does not attempt to dereference a freed - frame. (bug#30800) */ - if (represented_frame == f) - represented_frame = NULL; if (f->output_data.ns->miniimage != nil) [f->output_data.ns->miniimage release]; @@ -1642,7 +1692,7 @@ x_destroy_window (struct frame *f) NSTRACE ("x_destroy_window"); /* If this frame has a parent window, detach it as not doing so can - cause a crash in GNUStep. */ + cause a crash in GNUStep. */ if (FRAME_PARENT_FRAME (f) != NULL) { NSWindow *child = [FRAME_NS_VIEW (f) window]; @@ -1664,7 +1714,6 @@ x_set_offset (struct frame *f, int xoff, int yoff, int change_grav) -------------------------------------------------------------------------- */ { NSView *view = FRAME_NS_VIEW (f); - NSArray *screens = [NSScreen screens]; NSScreen *screen = [[view window] screen]; NSTRACE ("x_set_offset"); @@ -1753,6 +1802,15 @@ x_set_window_size (struct frame *f, block_input (); +#ifdef NS_IMPL_COCOA + /* To prevent showing the user a blank frame, stop updates being + flushed to the screen until after redisplay has completed. This + breaks live resize (resizing with a mouse), so don't do it if + we're in a live resize loop. */ + if (![view inLiveResize]) + ns_disable_screen_updates (); +#endif + if (pixelwise) { pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width); @@ -1780,11 +1838,11 @@ x_set_window_size (struct frame *f, frame_size_history_add (f, Qx_set_window_size_1, width, height, - list5 (Fcons (make_number (pixelwidth), make_number (pixelheight)), - Fcons (make_number (wr.size.width), make_number (wr.size.height)), - make_number (f->border_width), - make_number (FRAME_NS_TITLEBAR_HEIGHT (f)), - make_number (FRAME_TOOLBAR_HEIGHT (f)))); + list5 (Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)), + Fcons (make_fixnum (wr.size.width), make_fixnum (wr.size.height)), + make_fixnum (f->border_width), + make_fixnum (FRAME_NS_TITLEBAR_HEIGHT (f)), + make_fixnum (FRAME_TOOLBAR_HEIGHT (f)))); [window setFrame: wr display: YES]; @@ -1826,7 +1884,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value else { [window setToolbar: nil]; - /* Do I need to release the toolbar here? */ + /* Do I need to release the toolbar here? */ FRAME_UNDECORATED (f) = true; [window setStyleMask: ((window.styleMask | FRAME_UNDECORATED_FLAGS) @@ -1834,7 +1892,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value } /* At this point it seems we don't have an active NSResponder, - so some key presses (TAB) are swallowed by the system. */ + so some key presses (TAB) are swallowed by the system. */ [window makeFirstResponder: view]; [view updateFrameSize: NO]; @@ -1925,7 +1983,7 @@ x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, Lisp_Object old_v * displayed for the first time and when the frame changes its state * from `iconified' or `invisible' to `visible'.) * - * Some window managers may not honor this parameter. */ + * Some window managers may not honor this parameter. */ { NSTRACE ("x_set_no_focus_on_map"); @@ -1944,7 +2002,7 @@ x_set_no_accept_focus (struct frame *f, Lisp_Object new_value, Lisp_Object old_v * If non-nil, this may have the unwanted side-effect that a user cannot * scroll a non-selected frame with the mouse. * - * Some window managers may not honor this parameter. */ + * Some window managers may not honor this parameter. */ { NSTRACE ("x_set_no_accept_focus"); @@ -1961,7 +2019,7 @@ x_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) `below' property set. If `below', F's window is displayed below all windows that do. - Some window managers may not honor this parameter. */ + Some window managers may not honor this parameter. */ { EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f); NSWindow *window = [view window]; @@ -1980,7 +2038,7 @@ x_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) } else if (EQ (new_value, Qabove_suspended)) { - /* Not sure what level this should be. */ + /* Not sure what level this should be. */ window.level = NSNormalWindowLevel + 1; FRAME_Z_GROUP (f) = z_group_above_suspended; } @@ -2058,8 +2116,7 @@ ns_fullscreen_hook (struct frame *f) if (! [view fsIsNative] && f->want_fullscreen == FULLSCREEN_BOTH) { /* Old style fs don't initiate correctly if created from - init/default-frame alist, so use a timer (not nice...). - */ + init/default-frame alist, so use a timer (not nice...). */ [NSTimer scheduledTimerWithTimeInterval: 0.5 target: view selector: @selector (handleFS) userInfo: nil repeats: NO]; @@ -2126,7 +2183,7 @@ ns_index_color (NSColor *color, struct frame *f) color_table->colors[idx] = color; [color retain]; -/*fprintf(stderr, "color_table: allocated %d\n",idx);*/ + /* fprintf(stderr, "color_table: allocated %d\n",idx); */ return idx; } @@ -2138,7 +2195,7 @@ ns_get_color (const char *name, NSColor **col) -------------------------------------------------------------------------- */ /* On *Step, we attempt to mimic the X11 platform here, down to installing an X11 rgb.txt-compatible color list in Emacs.clr (see ns_term_init()). - See: http://thread.gmane.org/gmane.emacs.devel/113050/focus=113272). */ + See https://lists.gnu.org/r/emacs-devel/2009-07/msg01203.html. */ { NSColor *new = nil; static char hex[20]; @@ -2173,8 +2230,7 @@ ns_get_color (const char *name, NSColor **col) else if ([nsname isEqualToString: @"ns_selection_fg_color"]) { /* NOTE: macOS applications normally don't set foreground - selection, but text may be unreadable if we don't. - */ + selection, but text may be unreadable if we don't. */ if ((new = [NSColor selectedTextColor]) != nil) { *col = [new colorUsingDefaultColorSpace]; @@ -2186,7 +2242,7 @@ ns_get_color (const char *name, NSColor **col) name = [nsname UTF8String]; } - /* First, check for some sort of numeric specification. */ + /* First, check for some sort of numeric specification. */ hex[0] = '\0'; if (name[0] == '0' || name[0] == '1' || name[0] == '.') /* RGB decimal */ @@ -2236,7 +2292,7 @@ ns_get_color (const char *name, NSColor **col) NSColorList *clist; #ifdef NS_IMPL_GNUSTEP - /* XXX: who is wrong, the requestor or the implementation? */ + /* XXX: who is wrong, the requestor or the implementation? */ if ([nsname compare: @"Highlight" options: NSCaseInsensitiveSearch] == NSOrderedSame) nsname = @"highlightColor"; @@ -2265,7 +2321,7 @@ ns_get_color (const char *name, NSColor **col) int ns_lisp_to_color (Lisp_Object color, NSColor **col) /* -------------------------------------------------------------------------- - Convert a Lisp string object to a NS color + Convert a Lisp string object to a NS color. -------------------------------------------------------------------------- */ { NSTRACE ("ns_lisp_to_color"); @@ -2276,6 +2332,22 @@ ns_lisp_to_color (Lisp_Object color, NSColor **col) return 1; } +/* Convert an index into the color table into an RGBA value. Used in + xdisp.c:extend_face_to_end_of_line when comparing faces and frame + color values. */ + +unsigned long +ns_color_index_to_rgba(int idx, struct frame *f) +{ + NSColor *col; + col = ns_lookup_indexed_color (idx, f); + + EmacsCGFloat r, g, b, a; + [col getRed: &r green: &g blue: &b alpha: &a]; + + return ARGB_TO_ULONG((int)(a*255), + (int)(r*255), (int)(g*255), (int)(b*255)); +} void ns_query_color(void *col, XColor *color_def, int setPixel) @@ -2310,7 +2382,7 @@ ns_defined_color (struct frame *f, If makeIndex and alloc are nonzero put the color in the color_table, and set color_def pixel to the resulting index. If makeIndex is zero, set color_def pixel to ARGB. - Return false if not found + Return false if not found. -------------------------------------------------------------------------- */ { NSColor *col; @@ -2349,8 +2421,8 @@ x_set_frame_alpha (struct frame *f) if (FLOATP (Vframe_alpha_lower_limit)) alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit); - else if (INTEGERP (Vframe_alpha_lower_limit)) - alpha_min = (XINT (Vframe_alpha_lower_limit)) / 100.0; + else if (FIXNUMP (Vframe_alpha_lower_limit)) + alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0; if (alpha < 0.0) return; @@ -2383,7 +2455,7 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) { NSTRACE ("frame_set_mouse_pixel_position"); - /* FIXME: what about GNUstep? */ + /* FIXME: what about GNUstep? */ #ifdef NS_IMPL_COCOA CGPoint mouse_pos = CGPointMake(f->left_pos + pix_x, @@ -2404,15 +2476,15 @@ note_mouse_movement (struct frame *frame, CGFloat x, CGFloat y) struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); NSRect *r; -// NSTRACE ("note_mouse_movement"); + // NSTRACE ("note_mouse_movement"); dpyinfo->last_mouse_motion_frame = frame; r = &dpyinfo->last_mouse_glyph; /* Note, this doesn't get called for enter/leave, since we don't have a - position. Those are taken care of in the corresponding NSView methods. */ + position. Those are taken care of in the corresponding NSView methods. */ - /* has movement gone beyond last rect we were tracking? */ + /* Has movement gone beyond last rect we were tracking? */ if (x < r->origin.x || x >= r->origin.x + r->size.width || y < r->origin.y || y >= r->origin.y + r->size.height) { @@ -2436,7 +2508,7 @@ ns_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, External (hook): inform emacs about mouse position and hit parts. If a scrollbar is being dragged, set bar_window, part, x, y, time. x & y should be position in the scrollbar (the whole bar, not the handle) - and length of scrollbar respectively + and length of scrollbar respectively. -------------------------------------------------------------------------- */ { id view; @@ -2555,7 +2627,7 @@ ns_convert_key (unsigned code) { const unsigned last_keysym = ARRAYELTS (convert_ns_to_X_keysym); unsigned keysym; - /* An array would be faster, but less easy to read. */ + /* An array would be faster, but less easy to read. */ for (keysym = 0; keysym < last_keysym; keysym += 2) if (code == convert_ns_to_X_keysym[keysym]) return 0xFF00 | convert_ns_to_X_keysym[keysym+1]; @@ -2578,7 +2650,78 @@ x_get_keysym_name (int keysym) return value; } +#ifdef NS_IMPL_COCOA +static UniChar +ns_get_shifted_character (NSEvent *event) +/* Look up the character corresponding to the key pressed on the + current keyboard layout and the currently configured shift-like + modifiers. This ignores the control-like modifiers that cause + [event characters] to give us the wrong result. + + Although UCKeyTranslate doesn't require the Carbon framework, some + of the surrounding paraphernalia does, so this function makes + Carbon a requirement. */ +{ + static UInt32 dead_key_state; + + /* UCKeyTranslate may return up to 255 characters. If the buffer + isn't large enough then it produces an error. What kind of + keyboard inputs 255 characters in a single keypress? */ + UniChar buf[255]; + UniCharCount max_string_length = 255; + UniCharCount actual_string_length = 0; + OSStatus result; + + CFDataRef layout_ref = (CFDataRef) TISGetInputSourceProperty + (TISCopyCurrentKeyboardLayoutInputSource (), kTISPropertyUnicodeKeyLayoutData); + UCKeyboardLayout* layout = (UCKeyboardLayout*) CFDataGetBytePtr (layout_ref); + + UInt32 flags = [event modifierFlags]; + UInt32 modifiers = (flags & NSEventModifierFlagShift) ? shiftKey : 0; + + NSTRACE ("ns_get_shifted_character"); + + if ((flags & NSRightAlternateKeyMask) == NSRightAlternateKeyMask + && (EQ (ns_right_alternate_modifier, Qnone) + || (EQ (ns_right_alternate_modifier, Qleft) + && EQ (ns_alternate_modifier, Qnone)))) + modifiers |= rightOptionKey; + + if ((flags & NSLeftAlternateKeyMask) == NSLeftAlternateKeyMask + && EQ (ns_alternate_modifier, Qnone)) + modifiers |= optionKey; + + if ((flags & NSRightCommandKeyMask) == NSRightCommandKeyMask + && (EQ (ns_right_command_modifier, Qnone) + || (EQ (ns_right_command_modifier, Qleft) + && EQ (ns_command_modifier, Qnone)))) + /* Carbon doesn't differentiate between left and right command + keys. */ + modifiers |= cmdKey; + + if ((flags & NSLeftCommandKeyMask) == NSLeftCommandKeyMask + && EQ (ns_command_modifier, Qnone)) + modifiers |= cmdKey; + + result = UCKeyTranslate (layout, [event keyCode], kUCKeyActionDown, + (modifiers >> 8) & 0xFF, LMGetKbdType (), + kUCKeyTranslateNoDeadKeysBit, &dead_key_state, + max_string_length, &actual_string_length, buf); + + if (result != 0) + { + NSLog(@"Failed to translate character '%@' with modifiers %x", + [event characters], modifiers); + return 0; + } + + /* FIXME: What do we do if more than one code unit is returned? */ + if (actual_string_length > 0) + return buf[0]; + return 0; +} +#endif /* NS_IMPL_COCOA */ /* ========================================================================== @@ -2698,7 +2841,7 @@ ns_copy_bits (struct frame *f, NSRect src, NSRect dest) static void ns_scroll_run (struct window *w, struct run *run) /* -------------------------------------------------------------------------- - External (RIF): Insert or delete n lines at line vpos + External (RIF): Insert or delete n lines at line vpos. -------------------------------------------------------------------------- */ { struct frame *f = XFRAME (w->frame); @@ -3057,17 +3200,17 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, get_phys_cursor_geometry (w, glyph_row, phys_cursor_glyph, &fx, &fy, &h); /* The above get_phys_cursor_geometry call set w->phys_cursor_width - to the glyph width; replace with CURSOR_WIDTH for (V)BAR cursors. */ + to the glyph width; replace with CURSOR_WIDTH for (V)BAR cursors. */ if (cursor_type == BAR_CURSOR) { if (cursor_width < 1) cursor_width = max (FRAME_CURSOR_WIDTH (f), 1); - /* The bar cursor should never be wider than the glyph. */ + /* 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. */ + /* If we have an HBAR, "cursor_width" MAY specify height. */ else if (cursor_type == HBAR_CURSOR) { cursor_height = (cursor_width < 1) ? lrint (0.25 * h) : cursor_width; @@ -3319,7 +3462,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, if (s->for_overlaps) return; - /* Do underline. */ + /* Do underline. */ if (face->underline_p) { if (s->face->underline_type == FACE_UNDER_WAVE) @@ -3337,7 +3480,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, NSRect r; unsigned long thickness, position; - /* If the prev was underlined, match its appearance. */ + /* If the prev was underlined, match its appearance. */ if (s->prev && s->prev->face->underline_p && s->prev->face->underline_type == FACE_UNDER_LINE && s->prev->underline_thickness > 0) @@ -3349,25 +3492,40 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, { struct font *font = font_for_underline_metrics (s); unsigned long descent = s->y + s->height - s->ybase; - - /* Use underline thickness of font, defaulting to 1. */ + unsigned long minimum_offset; + BOOL underline_at_descent_line, use_underline_position_properties; + Lisp_Object val = buffer_local_value (Qunderline_minimum_offset, + s->w->contents); + if (FIXNUMP (val)) + minimum_offset = XFIXNAT (val); + else + minimum_offset = 1; + val = buffer_local_value (Qx_underline_at_descent_line, + s->w->contents); + underline_at_descent_line = !(NILP (val) || EQ (val, Qunbound)); + val = buffer_local_value (Qx_use_underline_position_properties, + s->w->contents); + use_underline_position_properties = + !(NILP (val) || EQ (val, Qunbound)); + + /* Use underline thickness of font, defaulting to 1. */ thickness = (font && font->underline_thickness > 0) ? font->underline_thickness : 1; - /* Determine the offset of underlining from the baseline. */ - if (x_underline_at_descent_line) + /* Determine the offset of underlining from the baseline. */ + if (underline_at_descent_line) position = descent - thickness; - else if (x_use_underline_position_properties + else if (use_underline_position_properties && font && font->underline_position >= 0) position = font->underline_position; else if (font) position = lround (font->descent / 2); else - position = underline_minimum_offset; + position = minimum_offset; - position = max (position, underline_minimum_offset); + position = max (position, minimum_offset); - /* Ensure underlining is not cropped. */ + /* Ensure underlining is not cropped. */ if (descent <= position) { position = descent - 1; @@ -3390,7 +3548,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, } } /* Do overline. We follow other terms in using a thickness of 1 - and ignoring overline_margin. */ + and ignoring overline_margin. */ if (face->overline_p) { NSRect r; @@ -3404,7 +3562,7 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, } /* Do strike-through. We follow other terms for thickness and - vertical position.*/ + vertical position. */ if (face->strike_through_p) { NSRect r; @@ -3511,7 +3669,7 @@ ns_draw_relief (NSRect r, int thickness, char raised_p, [(raised_p ? lightCol : darkCol) set]; - /* TODO: mitering. Using NSBezierPath doesn't work because of color switch. */ + /* TODO: mitering. Using NSBezierPath doesn't work because of color switch. */ /* top */ sr.size.height = thickness; @@ -3585,7 +3743,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) r = NSMakeRect (s->x, s->y, right_x - s->x + 1, s->height); - /* TODO: Sometimes box_color is 0 and this seems wrong; should investigate. */ + /* TODO: Sometimes box_color is 0 and this seems wrong; should investigate. */ if (s->face->box == FACE_SIMPLE_BOX && s->face->box_color) { ns_draw_box (r, abs (thickness), @@ -3688,7 +3846,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) /* Draw BG: if we need larger area than image itself cleared, do that, otherwise, since we composite the image under NS (instead of mucking - with its background color), we must clear just the image area. */ + with its background color), we must clear just the image area. */ if (s->hl == DRAW_MOUSE_FACE) { face = FACE_FROM_ID_OR_NULL (s->f, @@ -3714,7 +3872,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) NSRectFill (br); - /* Draw the image.. do we need to draw placeholder if img ==nil? */ + /* Draw the image... do we need to draw placeholder if img == nil? */ if (img != nil) { #ifdef NS_IMPL_COCOA @@ -3740,11 +3898,11 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) if (s->w->phys_cursor_type == FILLED_BOX_CURSOR) tdCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f); else - /* Currently on NS img->mask is always 0. Since + /* Currently on NS img->mask is always 0. Since get_window_cursor_type specifies a hollow box cursor when on - a non-masked image we never reach this clause. But we put it + a non-masked image we never reach this clause. But we put it in, in anticipation of better support for image masks on - NS. */ + NS. */ tdCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); } else @@ -3752,7 +3910,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) tdCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); } - /* Draw underline, overline, strike-through. */ + /* Draw underline, overline, strike-through. */ ns_draw_text_decoration (s, face, tdCol, br.size.width, br.origin.x); /* Draw relief, if requested */ @@ -4148,7 +4306,7 @@ ns_draw_glyph_string (struct glyph_string *s) emacs_abort (); } - /* Draw box if not done already. */ + /* Draw box if not done already. */ if (!s->for_overlaps && !box_drawn_p && s->face->box != FACE_NO_BOX) { n = ns_get_glyph_string_clip_rect (s, r); @@ -4193,8 +4351,8 @@ ns_send_appdefined (int value) } /* 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. */ + the [NXApp run] main loop after having processed all events queued at + this moment. */ #ifdef NS_IMPL_COCOA if (! send_appdefined) @@ -4217,7 +4375,7 @@ ns_send_appdefined (int value) /* We only need one NX_APPDEFINED event to stop NXApp from running. */ send_appdefined = NO; - /* Don't need wakeup timer any more */ + /* Don't need wakeup timer any more. */ if (timed_entry) { [timed_entry invalidate]; @@ -4271,7 +4429,7 @@ check_native_fs () void ns_check_menu_open (NSMenu *menu) { - /* Click in menu bar? */ + /* Click in menu bar? */ NSArray *a = [[NSApp mainMenu] itemArray]; int i; BOOL found = NO; @@ -4367,19 +4525,19 @@ ns_read_socket (struct terminal *terminal, struct input_event *hold_quit) ns_init_events (&ev); q_event_ptr = hold_quit; - /* we manage autorelease pools by allocate/reallocate each time around + /* 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 */ + 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 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]]) { [ns_pending_files removeObjectAtIndex: 0]; } - /* Deal with pending service requests. */ + /* 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] @@ -4432,7 +4590,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, if (hold_event_q.nr > 0) { - /* We already have events pending. */ + /* We already have events pending. */ raise (SIGIO); errno = EINTR; return -1; @@ -4484,13 +4642,13 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, pthread_mutex_unlock (&select_mutex); - /* Inform fd_handler that select should be called */ + /* Inform fd_handler that select should be called. */ c = 'g'; emacs_write_sig (selfds[1], &c, 1); } else if (nr == 0 && timeout) { - /* No file descriptor, just a timeout, no need to wake fd_handler */ + /* No file descriptor, just a timeout, no need to wake fd_handler. */ double time = timespectod (*timeout); timed_entry = [[NSTimer scheduledTimerWithTimeInterval: time target: NSApp @@ -4502,7 +4660,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, } else /* No timeout and no file descriptors, can this happen? */ { - /* Send appdefined so we exit from the loop */ + /* Send appdefined so we exit from the loop. */ ns_send_appdefined (-1); } @@ -4527,7 +4685,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, if (t == -2) { - /* The NX_APPDEFINED event we received was a timeout. */ + /* The NX_APPDEFINED event we received was a timeout. */ result = 0; } else if (t == -1) @@ -4539,7 +4697,7 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, } else { - /* Received back from select () in fd_handler; copy the results */ + /* 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; @@ -4559,11 +4717,11 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, #ifdef HAVE_PTHREAD void ns_run_loop_break () -/* Break out of the NS run loop in ns_select or ns_read_socket. */ +/* Break out of the NS run loop in ns_select or ns_read_socket. */ { NSTRACE_WHEN (NSTRACE_GROUP_EVENTS, "ns_run_loop_break"); - /* If we don't have a GUI, don't send the event. */ + /* If we don't have a GUI, don't send the event. */ if (NSApp != NULL) ns_send_appdefined(-1); } @@ -4593,7 +4751,7 @@ ns_set_vertical_scroll_bar (struct window *window, int top, left, height, width; BOOL update_p = YES; - /* optimization; display engine sends WAY too many of these.. */ + /* Optimization; display engine sends WAY too many of these. */ if (!NILP (window->vertical_scroll_bar)) { bar = XNS_SCROLL_BAR (window->vertical_scroll_bar); @@ -4620,14 +4778,14 @@ ns_set_vertical_scroll_bar (struct window *window, left = WINDOW_SCROLL_BAR_AREA_X (window); r = NSMakeRect (left, top, width, height); - /* the parent view is flipped, so we need to flip y value */ + /* The parent view is flipped, so we need to flip y value. */ v = [view frame]; r.origin.y = (v.size.height - r.size.height - r.origin.y); XSETWINDOW (win, window); block_input (); - /* we want at least 5 lines to display a scrollbar */ + /* We want at least 5 lines to display a scrollbar. */ if (WINDOW_TOTAL_LINES (window) < 5) { if (!NILP (window->vertical_scroll_bar)) @@ -4648,7 +4806,7 @@ ns_set_vertical_scroll_bar (struct window *window, ns_clear_frame_area (f, left, top, width, height); bar = [[EmacsScroller alloc] initFrame: r window: win]; - wset_vertical_scroll_bar (window, make_save_ptr (bar)); + wset_vertical_scroll_bar (window, make_mint_ptr (bar)); update_p = YES; } else @@ -4675,7 +4833,7 @@ static void ns_set_horizontal_scroll_bar (struct window *window, int portion, int whole, int position) /* -------------------------------------------------------------------------- - External (hook): Update or add scrollbar + External (hook): Update or add scrollbar. -------------------------------------------------------------------------- */ { Lisp_Object win; @@ -4687,7 +4845,7 @@ ns_set_horizontal_scroll_bar (struct window *window, int window_x, window_width; BOOL update_p = YES; - /* optimization; display engine sends WAY too many of these.. */ + /* Optimization; display engine sends WAY too many of these. */ if (!NILP (window->horizontal_scroll_bar)) { bar = XNS_SCROLL_BAR (window->horizontal_scroll_bar); @@ -4714,7 +4872,7 @@ ns_set_horizontal_scroll_bar (struct window *window, 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 */ + /* The parent view is flipped, so we need to flip y value. */ v = [view frame]; r.origin.y = (v.size.height - r.size.height - r.origin.y); @@ -4727,7 +4885,7 @@ ns_set_horizontal_scroll_bar (struct window *window, ns_clear_frame_area (f, left, top, width, height); bar = [[EmacsScroller alloc] initFrame: r window: win]; - wset_horizontal_scroll_bar (window, make_save_ptr (bar)); + wset_horizontal_scroll_bar (window, make_mint_ptr (bar)); update_p = YES; } else @@ -4746,7 +4904,7 @@ ns_set_horizontal_scroll_bar (struct window *window, /* 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. */ + 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); @@ -4869,7 +5027,7 @@ x_display_pixel_width (struct ns_display_info *dpyinfo) static Lisp_Object ns_string_to_lispmod (const char *s) /* -------------------------------------------------------------------------- - Convert modifier name to lisp symbol + Convert modifier name to lisp symbol. -------------------------------------------------------------------------- */ { if (!strncmp (SSDATA (SYMBOL_NAME (Qmeta)), s, 10)) @@ -4894,7 +5052,7 @@ ns_default (const char *parameter, Lisp_Object *result, Lisp_Object yesval, Lisp_Object noval, BOOL is_float, BOOL is_modstring) /* -------------------------------------------------------------------------- - Check a parameter value in user's preferences + Check a parameter value in user's preferences. -------------------------------------------------------------------------- */ { const char *value = ns_get_defaults_value (parameter); @@ -4935,7 +5093,7 @@ ns_initialize_display_info (struct ns_display_info *dpyinfo) dpyinfo->n_planes = NSBitsPerPixelFromDepth (depth); dpyinfo->color_table = xmalloc (sizeof *dpyinfo->color_table); dpyinfo->color_table->colors = NULL; - dpyinfo->root_window = 42; /* a placeholder.. */ + dpyinfo->root_window = 42; /* A placeholder. */ dpyinfo->x_highlight_frame = dpyinfo->x_focus_frame = NULL; dpyinfo->n_fonts = 0; dpyinfo->smallest_font_height = 1; @@ -4945,11 +5103,11 @@ ns_initialize_display_info (struct ns_display_info *dpyinfo) } -/* This and next define (many of the) public functions in this file. */ +/* This and next define (many of the) public functions in this file. */ /* x_... are generic versions in xdisp.c that we, and other terms, get away with using despite presence in the "system dependent" redisplay interface. In addition, many of the ns_ methods have code that is - shared with all terms, indicating need for further refactoring. */ + shared with all terms, indicating need for further refactoring. */ extern frame_parm_handler ns_frame_parm_handlers[]; static struct redisplay_interface ns_redisplay_interface = { @@ -4985,11 +5143,11 @@ static struct redisplay_interface ns_redisplay_interface = static void ns_delete_display (struct ns_display_info *dpyinfo) { - /* TODO... */ + /* TODO... */ } -/* This function is called when the last frame on a display is deleted. */ +/* This function is called when the last frame on a display is deleted. */ static void ns_delete_terminal (struct terminal *terminal) { @@ -5097,9 +5255,9 @@ ns_term_init (Lisp_Object display_name) ns_pending_service_names = [[NSMutableArray alloc] init]; ns_pending_service_args = [[NSMutableArray alloc] init]; -/* Start app and create the main menu, window, view. + /* Start app and create the main menu, window, view. Needs to be here because ns_initialize_display_info () uses AppKit classes. - The view will then ask the NSApp to stop and return to Emacs. */ + The view will then ask the NSApp to stop and return to Emacs. */ [EmacsApp sharedApplication]; if (NSApp == nil) return NULL; @@ -5171,7 +5329,7 @@ ns_term_init (Lisp_Object display_name) { color = XCAR (color_map); name = SSDATA (XCAR (color)); - c = XINT (XCDR (color)); + c = XFIXNUM (XCDR (color)); [cl setColor: [NSColor colorForEmacsRed: RED_FROM_ULONG (c) / 255.0 green: GREEN_FROM_ULONG (c) / 255.0 @@ -5203,7 +5361,7 @@ ns_term_init (Lisp_Object display_name) #ifdef NS_IMPL_GNUSTEP Vwindow_system_version = build_string (gnustep_base_version); #else - /*PSnextrelease (128, c); */ + /* PSnextrelease (128, c); */ char c[DBL_BUFSIZE_BOUND]; int len = dtoastr (c, sizeof c, 0, 0, NSAppKitVersionNumber); Vwindow_system_version = make_unibyte_string (c, len); @@ -5289,7 +5447,7 @@ ns_term_init (Lisp_Object display_name) #endif /* macOS menu setup */ /* Register our external input/output types, used for determining - applicable services and also drag/drop eligibility. */ + applicable services and also drag/drop eligibility. */ NSTRACE_MSG ("Input/output types"); @@ -5454,23 +5612,6 @@ ns_term_shutdown (int sig) } #endif - if (represented_filename != nil && represented_frame) - { - NSString *fstr = represented_filename; - NSView *view = FRAME_NS_VIEW (represented_frame); -#ifdef NS_IMPL_COCOA - /* work around a bug observed on 10.3 and later where - setTitleWithRepresentedFilename does not clear out previous state - if given filename does not exist */ - if (! [[NSFileManager defaultManager] fileExistsAtPath: fstr]) - [[view window] setRepresentedFilename: @""]; -#endif - [[view window] setRepresentedFilename: fstr]; - [represented_filename release]; - represented_filename = nil; - represented_frame = NULL; - } - if (type == NSEventTypeApplicationDefined) { switch ([theEvent data2]) @@ -5499,7 +5640,7 @@ ns_term_shutdown (int sig) /* Events posted by ns_send_appdefined interrupt the run loop here. But, if a modal window is up, an appdefined can still come through, (e.g., from a makeKeyWindow event) but stopping self also stops the - modal loop. Just defer it until later. */ + modal loop. Just defer it until later. */ if ([NSApp modalWindow] == nil) { last_appdefined_event_data = [theEvent data1]; @@ -5564,7 +5705,7 @@ ns_term_shutdown (int sig) } -/* Open a file (used by below, after going into queue read by ns_read_socket) */ +/* Open a file (used by below, after going into queue read by ns_read_socket). */ - (BOOL) openFile: (NSString *)fileName { NSTRACE ("[EmacsApp openFile:]"); @@ -5594,7 +5735,7 @@ ns_term_shutdown (int sig) - (void)applicationDidFinishLaunching: (NSNotification *)notification /* -------------------------------------------------------------------------- - When application is loaded, terminate event loop in ns_term_init + When application is loaded, terminate event loop in ns_term_init. -------------------------------------------------------------------------- */ { NSTRACE ("[EmacsApp applicationDidFinishLaunching:]"); @@ -5617,7 +5758,7 @@ ns_term_shutdown (int sig) if ([NSApp activationPolicy] == NSApplicationActivationPolicyProhibited) { /* Set the app's activation policy to regular when we run outside of a bundle. This is already done for us by Info.plist when we - run inside a bundle. */ + run inside a bundle. */ [NSApp setActivationPolicy:NSApplicationActivationPolicyRegular]; [NSApp setApplicationIconImage: [EmacsImage @@ -5721,7 +5862,7 @@ not_in_argv (NSString *arg) return 1; } -/* Notification from the Workspace to open a file */ +/* Notification from the Workspace to open a file. */ - (BOOL)application: sender openFile: (NSString *)file { if (ns_do_open_file || not_in_argv (file)) @@ -5730,7 +5871,7 @@ not_in_argv (NSString *arg) } -/* Open a file as a temporary file */ +/* Open a file as a temporary file. */ - (BOOL)application: sender openTempFile: (NSString *)file { if (ns_do_open_file || not_in_argv (file)) @@ -5739,7 +5880,7 @@ not_in_argv (NSString *arg) } -/* Notification from the Workspace to open a file noninteractively (?) */ +/* Notification from the Workspace to open a file noninteractively (?). */ - (BOOL)application: sender openFileWithoutUI: (NSString *)file { if (ns_do_open_file || not_in_argv (file)) @@ -5747,7 +5888,7 @@ not_in_argv (NSString *arg) return YES; } -/* Notification from the Workspace to open multiple files */ +/* Notification from the Workspace to open multiple files. */ - (void)application: sender openFiles: (NSArray *)fileList { NSEnumerator *files = [fileList objectEnumerator]; @@ -5771,11 +5912,11 @@ not_in_argv (NSString *arg) } -/* TODO: these may help w/IO switching btwn terminal and NSApp */ +/* TODO: these may help w/IO switching between terminal and NSApp. */ - (void)applicationWillBecomeActive: (NSNotification *)notification { NSTRACE ("[EmacsApp applicationWillBecomeActive:]"); - //ns_app_active=YES; + // ns_app_active=YES; } - (void)applicationDidBecomeActive: (NSNotification *)notification @@ -5786,7 +5927,7 @@ not_in_argv (NSString *arg) if (! applicationDidFinishLaunchingCalled) [self applicationDidFinishLaunching:notification]; #endif - //ns_app_active=YES; + // ns_app_active=YES; ns_update_auto_hide_menu_bar (); // No constraining takes place when the application is not active. @@ -5796,7 +5937,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsApp applicationDidResignActive:]"); - //ns_app_active=NO; + // ns_app_active=NO; ns_send_appdefined (-1); } @@ -5814,7 +5955,7 @@ not_in_argv (NSString *arg) The timeout specified to ns_select has passed. -------------------------------------------------------------------------- */ { - /*NSTRACE ("timeout_handler"); */ + /* NSTRACE ("timeout_handler"); */ ns_send_appdefined (-2); } @@ -5825,7 +5966,7 @@ not_in_argv (NSString *arg) - (void)fd_handler:(id)unused /* -------------------------------------------------------------------------- - Check data waiting on file descriptors and terminate if so + Check data waiting on file descriptors and terminate if so. -------------------------------------------------------------------------- */ { int result; @@ -5920,7 +6061,7 @@ not_in_argv (NSString *arg) ========================================================================== */ -/* called from system: queue for next pass through event loop */ +/* Called from system: queue for next pass through event loop. */ - (void)requestService: (NSPasteboard *)pboard userData: (NSString *)userData error: (NSString **)error @@ -5931,7 +6072,7 @@ not_in_argv (NSString *arg) } -/* called from ns_read_socket to clear queue */ +/* Called from ns_read_socket to clear queue. */ - (BOOL)fulfillService: (NSString *)name withArg: (NSString *)arg { struct frame *emacsframe = SELECTED_FRAME (); @@ -5956,7 +6097,6 @@ not_in_argv (NSString *arg) @end /* EmacsApp */ - /* ========================================================================== EmacsView implementation @@ -5966,7 +6106,7 @@ not_in_argv (NSString *arg) @implementation EmacsView -/* needed to inform when window closed from LISP */ +/* Needed to inform when window closed from lisp. */ - (void) setWindowClosing: (BOOL)closing { NSTRACE ("[EmacsView setWindowClosing:%d]", closing); @@ -5985,7 +6125,7 @@ not_in_argv (NSString *arg) } -/* called on font panel selection */ +/* Called on font panel selection. */ - (void)changeFont: (id)sender { NSEvent *e = [[self window] currentEvent]; @@ -6016,7 +6156,7 @@ not_in_argv (NSString *arg) emacs_event->code = KEY_NS_CHANGE_FONT; size = [newFont pointSize]; - ns_input_fontsize = make_number (lrint (size)); + ns_input_fontsize = make_fixnum (lrint (size)); ns_input_font = build_string ([[newFont familyName] UTF8String]); EV_TRAILER (e); } @@ -6041,13 +6181,19 @@ not_in_argv (NSString *arg) if (!NSIsEmptyRect (visible)) [self addCursorRect: visible cursor: currentCursor]; - [currentCursor setOnMouseEntered: YES]; + +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 + if ([currentCursor respondsToSelector: @selector(setOnMouseEntered)]) +#endif + [currentCursor setOnMouseEntered: YES]; +#endif } /*****************************************************************************/ -/* Keyboard handling. */ +/* Keyboard handling. */ #define NS_KEYLOG 0 - (void)keyDown: (NSEvent *)theEvent @@ -6056,12 +6202,11 @@ not_in_argv (NSString *arg) int code; unsigned fnKeysym = 0; static NSMutableArray *nsEvArray; - int left_is_none; unsigned int flags = [theEvent modifierFlags]; NSTRACE ("[EmacsView keyDown:]"); - /* Rhapsody and macOS give up and down events for the arrow keys */ + /* 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] != NSEventTypeKeyDown) @@ -6072,7 +6217,7 @@ not_in_argv (NSString *arg) if (![[self window] isKeyWindow] && [[theEvent window] isKindOfClass: [EmacsWindow class]] - /* we must avoid an infinite loop here. */ + /* We must avoid an infinite loop here. */ && (EmacsView *)[[theEvent window] delegate] != self) { /* XXX: There is an occasional condition in which, when Emacs display @@ -6080,7 +6225,7 @@ not_in_argv (NSString *arg) selects it, then processes some interrupt-driven input (dispnew.c:3878), OS will send the event to the correct NSWindow, but for some reason that window has its first responder set to the NSView - most recently updated (I guess), which is not the correct one. */ + most recently updated (I guess), which is not the correct one. */ [(EmacsView *)[[theEvent window] delegate] keyDown: theEvent]; return; } @@ -6090,7 +6235,7 @@ not_in_argv (NSString *arg) [NSCursor setHiddenUntilMouseMoves: YES]; - if (hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)) + if (hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)) { clear_mouse_face (hlinfo); hlinfo->mouse_face_hidden = 1; @@ -6098,19 +6243,14 @@ not_in_argv (NSString *arg) if (!processingCompose) { - /* When using screen sharing, no left or right information is sent, - so use Left key in those cases. */ - int is_left_key, is_right_key; - + /* FIXME: What should happen for key sequences with more than + one character? */ code = ([[theEvent charactersIgnoringModifiers] length] == 0) ? 0 : [[theEvent charactersIgnoringModifiers] characterAtIndex: 0]; - /* (Carbon way: [theEvent keyCode]) */ - - /* is it a "function key"? */ + /* Is it a "function key"? */ /* Note: Sometimes a plain key will have the NSEventModifierFlagNumericPad - flag set (this is probably a bug in the OS). - */ + flag set (this is probably a bug in the OS). */ if (code < 0x00ff && (flags&NSEventModifierFlagNumericPad)) { fnKeysym = ns_convert_key ([theEvent keyCode] | NSEventModifierFlagNumericPad); @@ -6123,14 +6263,13 @@ not_in_argv (NSString *arg) if (fnKeysym) { /* COUNTERHACK: map 'Delete' on upper-right main KB to 'Backspace', - because Emacs treats Delete and KP-Delete same (in simple.el). */ + because Emacs treats Delete and KP-Delete same (in simple.el). */ if ((fnKeysym == 0xFFFF && [theEvent keyCode] == 0x33) #ifdef NS_IMPL_GNUSTEP /* GNUstep uses incompatible keycodes, even for those that are supposed to be hardware independent. Just check for delete. Keypad delete does not have keysym 0xFFFF. - See https://savannah.gnu.org/bugs/?25395 - */ + See https://savannah.gnu.org/bugs/?25395 */ || (fnKeysym == 0xFFFF && code == 127) #endif ) @@ -6139,142 +6278,65 @@ not_in_argv (NSString *arg) code = fnKeysym; } - /* are there modifiers? */ - emacs_event->modifiers = 0; - - if (flags & NSEventModifierFlagHelp) - emacs_event->modifiers |= hyper_modifier; - - if (flags & NSEventModifierFlagShift) - emacs_event->modifiers |= shift_modifier; - - is_right_key = (flags & NSRightCommandKeyMask) == NSRightCommandKeyMask; - is_left_key = (flags & NSLeftCommandKeyMask) == NSLeftCommandKeyMask - || (! is_right_key && (flags & NSEventModifierFlagCommand) == NSEventModifierFlagCommand); - - if (is_right_key) - emacs_event->modifiers |= parse_solitary_modifier - (EQ (ns_right_command_modifier, Qleft) - ? ns_command_modifier - : ns_right_command_modifier); - - if (is_left_key) - { - emacs_event->modifiers |= parse_solitary_modifier - (ns_command_modifier); - - /* if super (default), take input manager's word so things like - dvorak / qwerty layout work */ - if (EQ (ns_command_modifier, Qsuper) - && !fnKeysym - && [[theEvent characters] length] != 0) - { - /* XXX: the code we get will be unshifted, so if we have - a shift modifier, must convert ourselves */ - if (!(flags & NSEventModifierFlagShift)) - code = [[theEvent characters] characterAtIndex: 0]; -#if 0 - /* this is ugly and also requires linking w/Carbon framework - (for LMGetKbdType) so for now leave this rare (?) case - undealt with.. in future look into CGEvent methods */ - else - { - long smv = GetScriptManagerVariable (smKeyScript); - Handle uchrHandle = GetResource - ('uchr', GetScriptVariable (smv, smScriptKeys)); - UInt32 dummy = 0; - UCKeyTranslate ((UCKeyboardLayout *) *uchrHandle, - [[theEvent characters] characterAtIndex: 0], - kUCKeyActionDisplay, - (flags & ~NSEventModifierFlagCommand) >> 8, - LMGetKbdType (), kUCKeyTranslateNoDeadKeysMask, - &dummy, 1, &dummy, &code); - code &= 0xFF; - } -#endif - } - } - - is_right_key = (flags & NSRightControlKeyMask) == NSRightControlKeyMask; - is_left_key = (flags & NSLeftControlKeyMask) == NSLeftControlKeyMask - || (! is_right_key && (flags & NSEventModifierFlagControl) == NSEventModifierFlagControl); - - if (is_right_key) - emacs_event->modifiers |= parse_solitary_modifier - (EQ (ns_right_control_modifier, Qleft) - ? ns_control_modifier - : ns_right_control_modifier); - - if (is_left_key) - emacs_event->modifiers |= parse_solitary_modifier - (ns_control_modifier); - - if (flags & NS_FUNCTION_KEY_MASK && !fnKeysym) - emacs_event->modifiers |= - parse_solitary_modifier (ns_function_modifier); - - left_is_none = NILP (ns_alternate_modifier) - || EQ (ns_alternate_modifier, Qnone); - - is_right_key = (flags & NSRightAlternateKeyMask) - == NSRightAlternateKeyMask; - is_left_key = (flags & NSLeftAlternateKeyMask) == NSLeftAlternateKeyMask - || (! is_right_key - && (flags & NSEventModifierFlagOption) == NSEventModifierFlagOption); - - if (is_right_key) - { - if ((NILP (ns_right_alternate_modifier) - || EQ (ns_right_alternate_modifier, Qnone) - || (EQ (ns_right_alternate_modifier, Qleft) && left_is_none)) - && !fnKeysym) - { /* accept pre-interp alt comb */ - if ([[theEvent characters] length] > 0) - code = [[theEvent characters] characterAtIndex: 0]; - /*HACK: clear lone shift modifier to stop next if from firing */ - if (emacs_event->modifiers == shift_modifier) - emacs_event->modifiers = 0; - } - else - emacs_event->modifiers |= parse_solitary_modifier - (EQ (ns_right_alternate_modifier, Qleft) - ? ns_alternate_modifier - : ns_right_alternate_modifier); - } - - if (is_left_key) /* default = meta */ - { - if (left_is_none && !fnKeysym) - { /* accept pre-interp alt comb */ - if ([[theEvent characters] length] > 0) - code = [[theEvent characters] characterAtIndex: 0]; - /*HACK: clear lone shift modifier to stop next if from firing */ - if (emacs_event->modifiers == shift_modifier) - emacs_event->modifiers = 0; - } - else - emacs_event->modifiers |= - parse_solitary_modifier (ns_alternate_modifier); - } - - if (NS_KEYLOG) - fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n", - (unsigned) code, fnKeysym, flags, emacs_event->modifiers); - - /* if it was a function key or had modifiers, pass it directly to emacs */ + /* The ⌘ and ⌥ modifiers can be either shift-like (for alternate + character input) or control-like (as command prefix). If we + have only shift-like modifiers, then we should use the + translated characters (returned by the characters method); if + we have only control-like modifiers, then we should use the + untranslated characters (returned by the + charactersIgnoringModifiers method). An annoyance happens if + we have both shift-like and control-like modifiers because + the NSEvent API doesn’t let us ignore only some modifiers. + In that case we use UCKeyTranslate (ns_get_shifted_character) + to look up the correct character. */ + + /* EV_MODIFIERS2 uses parse_solitary_modifier on all known + modifier keys, which returns 0 for shift-like modifiers. + Therefore its return value is the set of control-like + modifiers. */ + emacs_event->modifiers = EV_MODIFIERS2 (flags); + + /* Function keys (such as the F-keys, arrow keys, etc.) set + modifiers as though the fn key has been pressed when it + hasn't. Also some combinations of fn and a function key + return a different key than was pressed (e.g. fn-<left> gives + <home>). We need to unset the fn modifier in these cases. + FIXME: Can we avoid setting it in the first place? */ + if (fnKeysym && (flags & NS_FUNCTION_KEY_MASK)) + emacs_event->modifiers ^= parse_solitary_modifier (ns_function_modifier); + + if (NS_KEYLOG) + fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n", + code, fnKeysym, flags, emacs_event->modifiers); + + /* If it was a function key or had control-like modifiers, pass + it directly to Emacs. */ if (fnKeysym || (emacs_event->modifiers && (emacs_event->modifiers != shift_modifier) && [[theEvent charactersIgnoringModifiers] length] > 0)) -/*[[theEvent characters] length] */ { emacs_event->kind = NON_ASCII_KEYSTROKE_EVENT; + /* FIXME: What are the next four lines supposed to do? */ if (code < 0x20) code |= (1<<28)|(3<<16); else if (code == 0x7f) code |= (1<<28)|(3<<16); else if (!fnKeysym) - emacs_event->kind = code > 0xFF - ? MULTIBYTE_CHAR_KEYSTROKE_EVENT : ASCII_KEYSTROKE_EVENT; + { +#ifdef NS_IMPL_COCOA + /* We potentially have both shift- and control-like + modifiers in use, so find the correct character + ignoring any control-like ones. */ + code = ns_get_shifted_character (theEvent); +#endif + + /* FIXME: This seems wrong, characters in the range + [0x80, 0xFF] are not ASCII characters. Can’t we just + use MULTIBYTE_CHAR_KEYSTROKE_EVENT here for all kinds + of characters? */ + emacs_event->kind = code > 0xFF + ? MULTIBYTE_CHAR_KEYSTROKE_EVENT : ASCII_KEYSTROKE_EVENT; + } emacs_event->code = code; EV_TRAILER (theEvent); @@ -6283,23 +6345,44 @@ not_in_argv (NSString *arg) } } + /* If we get here, a non-function key without control-like modifiers + was hit. Use interpretKeyEvents, which in turn will call + insertText; see + https://developer.apple.com/library/mac/documentation/Cocoa/Conceptual/EventOverview/HandlingKeyEvents/HandlingKeyEvents.html. */ if (NS_KEYLOG && !processingCompose) fprintf (stderr, "keyDown: Begin compose sequence.\n"); + /* FIXME: interpretKeyEvents doesn’t seem to send insertText if ⌘ is + used as shift-like modifier, at least on El Capitan. Mask it + out. This shouldn’t be needed though; we should figure out what + the correct way of handling ⌘ is. */ + if ([theEvent modifierFlags] & NSEventModifierFlagCommand) + theEvent = [NSEvent keyEventWithType:[theEvent type] + location:[theEvent locationInWindow] + modifierFlags:[theEvent modifierFlags] & ~NSEventModifierFlagCommand + timestamp:[theEvent timestamp] + windowNumber:[theEvent windowNumber] + context:nil + characters:[theEvent characters] + charactersIgnoringModifiers:[theEvent charactersIgnoringModifiers] + isARepeat:[theEvent isARepeat] + keyCode:[theEvent keyCode]]; + processingCompose = YES; + /* FIXME: Use [NSArray arrayWithObject:theEvent]? */ [nsEvArray addObject: theEvent]; [self interpretKeyEvents: nsEvArray]; [nsEvArray removeObject: theEvent]; } -/* <NSTextInput> implementation (called through super interpretKeyEvents:]). */ +/* <NSTextInput> implementation (called through [super interpretKeyEvents:]). */ /* <NSTextInput>: called when done composing; - NOTE: also called when we delete over working text, followed immed. - by doCommandBySelector: deleteBackward: */ + NOTE: also called when we delete over working text, followed + immediately by doCommandBySelector: deleteBackward: */ - (void)insertText: (id)aString { NSString *s; @@ -6321,7 +6404,7 @@ not_in_argv (NSString *arg) if (!emacs_event) return; - /* first, clear any working text */ + /* First, clear any working text. */ if (workingText != nil) [self deleteWorkingText]; @@ -6330,7 +6413,7 @@ not_in_argv (NSString *arg) However, we probably can't use SAFE_NALLOCA here because it might exit nonlocally. */ - /* now insert the string as keystrokes */ + /* Now insert the string as keystrokes. */ for (NSUInteger i = 0; i < len; i++) { NSUInteger code = [s characterAtIndex:i]; @@ -6343,7 +6426,7 @@ not_in_argv (NSString *arg) ++i; } } - /* TODO: still need this? */ + /* TODO: still need this? */ if (code == 0x2DC) code = '~'; /* 0x7E */ if (code != 32) /* Space */ @@ -6356,7 +6439,7 @@ not_in_argv (NSString *arg) } -/* <NSTextInput>: inserts display of composing characters */ +/* <NSTextInput>: inserts display of composing characters. */ - (void)setMarkedText: (id)aString selectedRange: (NSRange)selRange { NSString *str = [aString respondsToSelector: @selector (string)] ? @@ -6388,7 +6471,7 @@ not_in_argv (NSString *arg) } -/* delete display of composing characters [not in <NSTextInput>] */ +/* Delete display of composing characters [not in <NSTextInput>]. */ - (void)deleteWorkingText { NSTRACE ("[EmacsView deleteWorkingText]"); @@ -6441,7 +6524,7 @@ not_in_argv (NSString *arg) } -/* used to position char selection windows, etc. */ +/* Used to position char selection windows, etc. */ - (NSRect)firstRectForCharacterRange: (NSRange)theRange { NSRect rect; @@ -6501,8 +6584,8 @@ not_in_argv (NSString *arg) processingCompose = NO; if (aSelector == @selector (deleteBackward:)) { - /* happens when user backspaces over an ongoing composition: - throw a 'delete' into the event queue */ + /* Happens when user backspaces over an ongoing composition: + throw a 'delete' into the event queue. */ if (!emacs_event) return; emacs_event->kind = NON_ASCII_KEYSTROKE_EVENT; @@ -6547,7 +6630,7 @@ not_in_argv (NSString *arg) return str; } -/* End <NSTextInput> impl. */ +/* End <NSTextInput> implementation. */ /*****************************************************************************/ @@ -6565,8 +6648,8 @@ not_in_argv (NSString *arg) return; dpyinfo->last_mouse_frame = emacsframe; - /* appears to be needed to prevent spurious movement events generated on - button clicks */ + /* Appears to be needed to prevent spurious movement events generated on + button clicks. */ emacsframe->mouse_moved = 0; if ([theEvent type] == NSEventTypeScrollWheel) @@ -6602,8 +6685,8 @@ not_in_argv (NSString *arg) static int totalDeltaX, totalDeltaY; int lineHeight; - if (NUMBERP (ns_mwheel_line_height)) - lineHeight = XINT (ns_mwheel_line_height); + if (FIXNUMP (ns_mwheel_line_height)) + lineHeight = XFIXNUM (ns_mwheel_line_height); else { /* FIXME: Use actual line height instead of the default. */ @@ -6672,7 +6755,7 @@ not_in_argv (NSString *arg) return; emacs_event->kind = horizontal ? HORIZ_WHEEL_EVENT : WHEEL_EVENT; - emacs_event->arg = (make_number (lines)); + emacs_event->arg = (make_fixnum (lines)); emacs_event->code = 0; emacs_event->modifiers = EV_MODIFIERS (theEvent) | @@ -6685,7 +6768,8 @@ not_in_argv (NSString *arg) #if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 1070 { CGFloat delta = [theEvent deltaY]; - /* Mac notebooks send wheel events w/delta =0 when trackpad scrolling */ + /* Mac notebooks send wheel events with delta equal to 0 + when trackpad scrolling. */ if (delta == 0) { delta = [theEvent deltaX]; @@ -6762,7 +6846,7 @@ not_in_argv (NSString *arg) } -/* Tell emacs the mouse has moved. */ +/* Tell emacs the mouse has moved. */ - (void)mouseMoved: (NSEvent *)e { Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (emacsframe); @@ -6777,14 +6861,14 @@ not_in_argv (NSString *arg) dpyinfo->last_mouse_motion_x = pt.x; dpyinfo->last_mouse_motion_y = pt.y; - /* update any mouse face */ + /* Update any mouse face. */ if (hlinfo->mouse_face_hidden) { hlinfo->mouse_face_hidden = 0; clear_mouse_face (hlinfo); } - /* tooltip handling */ + /* Tooltip handling. */ previous_help_echo_string = help_echo_string; help_echo_string = Qnil; @@ -6819,7 +6903,7 @@ not_in_argv (NSString *arg) { /* NOTE: help_echo_{window,pos,object} are set in xdisp.c (note_mouse_highlight), which is called through the - note_mouse_movement () call above */ + note_mouse_movement () call above. */ any_help_event_p = YES; gen_help_event (help_echo_string, frame, help_echo_window, help_echo_object, help_echo_pos); @@ -6903,7 +6987,7 @@ not_in_argv (NSString *arg) if (wait_for_tool_bar) { /* The toolbar height is always 0 in fullscreen and undecorated - frames, so don't wait for it to become available. */ + frames, so don't wait for it to become available. */ if (FRAME_TOOLBAR_HEIGHT (emacsframe) == 0 && FRAME_UNDECORATED (emacsframe) == false && ! [self isFullscreen]) @@ -6951,7 +7035,7 @@ not_in_argv (NSString *arg) wr = NSMakeRect (0, 0, neww, newh); [view setFrame: wr]; - // to do: consider using [NSNotificationCenter postNotificationName:]. + // To do: consider using [NSNotificationCenter postNotificationName:]. [self windowDidMove: // Update top/left. [NSNotification notificationWithName:NSWindowDidMoveNotification object:[view window]]]; @@ -6963,7 +7047,7 @@ not_in_argv (NSString *arg) } - (NSSize)windowWillResize: (NSWindow *)sender toSize: (NSSize)frameSize -/* normalize frame to gridded text size */ +/* Normalize frame to gridded text size. */ { int extra = 0; @@ -7005,7 +7089,7 @@ not_in_argv (NSString *arg) rows = MINHEIGHT; #ifdef NS_IMPL_COCOA { - /* this sets window title to have size in it; the wm does this under GS */ + /* This sets window title to have size in it; the wm does this under GS. */ NSRect r = [[self window] frame]; if (r.size.height == frameSize.height && r.size.width == frameSize.width) { @@ -7038,12 +7122,12 @@ not_in_argv (NSString *arg) NSTRACE_MSG ("cols: %d rows: %d", cols, rows); - /* Restrict the new size to the text gird. + /* Restrict the new size to the text grid. Don't restrict the width if the user only adjusted the height, and vice versa. (Without this, the frame would shrink, and move slightly, if the window was resized by dragging one of its - borders.) */ + borders.) */ if (!frame_resize_pixelwise) { NSRect r = [[self window] frame]; @@ -7095,8 +7179,8 @@ not_in_argv (NSString *arg) NSWindow *theWindow = [notification object]; /* In GNUstep, at least currently, it's possible to get a didResize - without getting a willResize.. therefore we need to act as if we got - the willResize now */ + without getting a willResize, therefore we need to act as if we got + the willResize now. */ NSSize sz = [theWindow frame].size; sz = [self windowWillResize: theWindow toSize: sz]; #endif /* NS_IMPL_GNUSTEP */ @@ -7167,7 +7251,7 @@ not_in_argv (NSString *arg) ns_frame_rehighlight (emacsframe); /* FIXME: for some reason needed on second and subsequent clicks away - from sole-frame Emacs to get hollow box to show */ + from sole-frame Emacs to get hollow box to show. */ if (!windowClosing && [[self window] isVisible] == YES) { x_update_cursor (emacsframe, 1); @@ -7399,7 +7483,7 @@ not_in_argv (NSString *arg) /* macOS Sierra automatically enables tabbed windows. We can't allow this to be enabled until it's available on a Free system. - Currently it only happens by accident and is buggy anyway. */ + Currently it only happens by accident and is buggy anyway. */ #if defined (NS_IMPL_COCOA) \ && MAC_OS_X_VERSION_MAX_ALLOWED >= 101200 #if MAC_OS_X_VERSION_MIN_REQUIRED < 101200 @@ -7441,7 +7525,7 @@ not_in_argv (NSString *arg) /* Called AFTER method below, but before our windowWillResize call there leads to windowDidResize -> x_set_window_size. Update emacs' notion of frame - location so set_window_size moves the frame. */ + location so set_window_size moves the frame. */ - (BOOL)windowShouldZoom: (NSWindow *)sender toFrame: (NSRect)newFrame { NSTRACE (("[EmacsView windowShouldZoom:toFrame:" NSTRACE_FMT_RECT "]" @@ -7455,7 +7539,7 @@ not_in_argv (NSString *arg) /* Override to do something slightly nonstandard, but nice. First click on zoom button will zoom vertically. Second will zoom completely. Third - returns to original. */ + returns to original. */ - (NSRect)windowWillUseStandardFrame:(NSWindow *)sender defaultFrame:(NSRect)defaultFrame { @@ -7536,7 +7620,7 @@ not_in_argv (NSString *arg) { NSTRACE_MSG ("FULLSCREEN_MAXIMIZED"); - result = defaultFrame; /* second click */ + result = defaultFrame; /* second click */ maximized_width = result.size.width; maximized_height = result.size.height; [self setFSValue: FULLSCREEN_MAXIMIZED]; @@ -7817,7 +7901,7 @@ not_in_argv (NSString *arg) NSScreen *screen = [w screen]; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1090 - /* Hide ghost menu bar on secondary monitor? */ + /* Hide ghost menu bar on secondary monitor? */ if (! onFirstScreen #if MAC_OS_X_VERSION_MIN_REQUIRED < 1090 && [NSScreen respondsToSelector: @selector(screensHaveSeparateSpaces)] @@ -7896,7 +7980,8 @@ not_in_argv (NSString *arg) f->border_width = bwidth; - // to do: consider using [NSNotificationCenter postNotificationName:] to send notifications. + // To do: consider using [NSNotificationCenter postNotificationName:] to + // send notifications. [self windowWillExitFullScreen]; [fw setFrame: [w frame] display:YES animate:ns_use_fullscreen_animation]; @@ -8036,7 +8121,7 @@ not_in_argv (NSString *arg) } -/* this gets called on toolbar button click */ +/* This gets called on toolbar button click. */ - (instancetype)toolbarClicked: (id)item { NSEvent *theEvent; @@ -8047,14 +8132,14 @@ not_in_argv (NSString *arg) if (!emacs_event) return self; - /* send first event (for some reason two needed) */ + /* Send first event (for some reason two needed). */ theEvent = [[self window] currentEvent]; emacs_event->kind = TOOL_BAR_EVENT; XSETFRAME (emacs_event->arg, emacsframe); EV_TRAILER (theEvent); emacs_event->kind = TOOL_BAR_EVENT; -/* XSETINT (emacs_event->code, 0); */ + /* XSETINT (emacs_event->code, 0); */ emacs_event->arg = AREF (emacsframe->tool_bar_items, idx + TOOL_BAR_ITEM_KEY); emacs_event->modifiers = EV_MODIFIERS (theEvent); @@ -8263,13 +8348,13 @@ not_in_argv (NSString *arg) But this should not happen because we override the services menu with our own entries which call ns-perform-service. Nonetheless, it appeared to happen (under strange circumstances): bug#1435. - So let's at least stub them out until further investigation can be done. */ + So let's at least stub them out until further investigation can be done. */ - (BOOL) readSelectionFromPasteboard: (NSPasteboard *)pb { - /* we could call ns_string_from_pasteboard(pboard) here but then it should - be written into the buffer in place of the existing selection.. - ordinary service calls go through functions defined in ns-win.el */ + /* We could call ns_string_from_pasteboard(pboard) here but then it should + be written into the buffer in place of the existing selection. + Ordinary service calls go through functions defined in ns-win.el. */ return NO; } @@ -8280,7 +8365,7 @@ not_in_argv (NSString *arg) NSTRACE ("[EmacsView writeSelectionToPasteboard:types:]"); - /* We only support NSStringPboardType */ + /* We only support NSStringPboardType. */ if ([types containsObject:NSStringPboardType] == NO) { return NO; } @@ -8302,10 +8387,10 @@ not_in_argv (NSString *arg) } -/* setMini =YES means set from internal (gives a finder icon), NO means set nil +/* setMini = YES means set from internal (gives a finder icon), NO means set nil (gives a miniaturized version of the window); currently we use the latter for frames whose active buffer doesn't correspond to any file - (e.g., '*scratch*') */ + (e.g., '*scratch*'). */ - (instancetype)setMiniwindowImage: (BOOL) setMini { id image = [[self window] miniwindowImage]; @@ -8313,7 +8398,7 @@ not_in_argv (NSString *arg) /* NOTE: under Cocoa miniwindowImage always returns nil, documentation about "AppleDockIconEnabled" notwithstanding, however the set message - below has its effect nonetheless. */ + below has its effect nonetheless. */ if (image != emacsframe->output_data.ns->miniimage) { if (image && [image isKindOfClass: [EmacsImage class]]) @@ -8424,7 +8509,7 @@ not_in_argv (NSString *arg) Note that this should work in situations where multiple monitors are present. Common configurations are side-by-side monitors and a monitor on top of another (e.g. when a laptop is placed under a - large screen). */ + large screen). */ - (NSRect)constrainFrameRect:(NSRect)frameRect toScreen:(NSScreen *)screen { NSTRACE ("[EmacsWindow constrainFrameRect:" NSTRACE_FMT_RECT " toScreen:]", @@ -8651,7 +8736,7 @@ not_in_argv (NSString *arg) + (CGFloat) scrollerWidth { /* TODO: if we want to allow variable widths, this is the place to do it, - however neither GNUstep nor Cocoa support it very well */ + however neither GNUstep nor Cocoa support it very well. */ CGFloat r; #if defined (NS_IMPL_COCOA) \ && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 @@ -8687,7 +8772,7 @@ not_in_argv (NSString *arg) /* Ensure auto resizing of scrollbars occurs within the emacs frame's view locked against the top and bottom edges, and right edge on macOS, where - scrollers are on right. */ + scrollers are on right. */ #ifdef NS_IMPL_GNUSTEP [self setAutoresizingMask: NSViewMaxXMargin | NSViewHeightSizable]; #else @@ -8711,7 +8796,7 @@ not_in_argv (NSString *arg) NSView *sview = [[view window] contentView]; NSArray *subs = [sview subviews]; - /* disable optimization stopping redraw of other scrollbars */ + /* Disable optimization stopping redraw of other scrollbars. */ view->scrollbarsNeedingUpdate = 0; for (i =[subs count]-1; i >= 0; i--) if ([[subs objectAtIndex: i] isKindOfClass: [EmacsScroller class]]) @@ -8719,7 +8804,7 @@ not_in_argv (NSString *arg) [sview addSubview: self]; } -/* [self setFrame: r]; */ + /* [self setFrame: r]; */ return self; } @@ -8729,7 +8814,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsScroller setFrame:]"); -/* block_input (); */ + /* block_input (); */ if (horizontal) pixel_length = NSWidth (newRect); else @@ -8737,7 +8822,7 @@ not_in_argv (NSString *arg) if (pixel_length == 0) pixel_length = 1; min_portion = 20 / pixel_length; [super setFrame: newRect]; -/* unblock_input (); */ + /* unblock_input (); */ } @@ -8780,7 +8865,7 @@ not_in_argv (NSString *arg) { EmacsView *view; block_input (); - /* ensure other scrollbar updates after deletion */ + /* Ensure other scrollbar updates after deletion. */ view = (EmacsView *)FRAME_NS_VIEW (frame); if (view != nil) view->scrollbarsNeedingUpdate++; @@ -8807,7 +8892,14 @@ not_in_argv (NSString *arg) if (!NSIsEmptyRect (visible)) [self addCursorRect: visible cursor: [NSCursor arrowCursor]]; - [[NSCursor arrowCursor] setOnMouseEntered: YES]; + +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 + if ([[NSCursor arrowCursor] respondsToSelector: + @selector(setOnMouseEntered)]) +#endif + [[NSCursor arrowCursor] setOnMouseEntered: YES]; +#endif } @@ -8815,7 +8907,7 @@ not_in_argv (NSString *arg) whole: (int) whole { return em_position ==position && em_portion ==portion && em_whole ==whole - && portion != whole; /* needed for resize empty buf */ + && portion != whole; /* Needed for resizing empty buffer. */ } @@ -8854,7 +8946,7 @@ not_in_argv (NSString *arg) return self; } -/* set up emacs_event */ +/* Set up emacs_event. */ - (void) sendScrollEventAtLoc: (float)loc fromEvent: (NSEvent *)e { Lisp_Object win; @@ -8897,7 +8989,8 @@ not_in_argv (NSString *arg) } -/* called manually thru timer to implement repeated button action w/hold-down */ +/* Called manually through timer to implement repeated button action + with hold-down. */ - (instancetype)repeatScroll: (NSTimer *)scrollEntry { NSEvent *e = [[self window] currentEvent]; @@ -8906,7 +8999,7 @@ not_in_argv (NSString *arg) NSTRACE ("[EmacsScroller repeatScroll:]"); - /* clear timer if need be */ + /* Clear timer if need be. */ if (inKnob || [scroll_repeat_entry timeInterval] == SCROLL_BAR_FIRST_DELAY) { [scroll_repeat_entry invalidate]; @@ -8932,11 +9025,11 @@ not_in_argv (NSString *arg) /* Asynchronous mouse tracking for scroller. This allows us to dispatch - mouseDragged events without going into a modal loop. */ + mouseDragged events without going into a modal loop. */ - (void)mouseDown: (NSEvent *)e { NSRect sr, kr; - /* hitPart is only updated AFTER event is passed on */ + /* hitPart is only updated AFTER event is passed on. */ NSScrollerPart part = [self testPart: [e locationInWindow]]; CGFloat loc, kloc, pos UNINIT; int edge = 0; @@ -9035,9 +9128,9 @@ not_in_argv (NSString *arg) } else { - pos = 0; /* ignored */ + pos = 0; /* ignored */ - /* set a timer to repeat, as we can't let superclass do this modally */ + /* 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 @@ -9052,7 +9145,7 @@ not_in_argv (NSString *arg) } -/* Called as we manually track scroller drags, rather than superclass. */ +/* Called as we manually track scroller drags, rather than superclass. */ - (void)mouseDragged: (NSEvent *)e { NSRect sr; @@ -9110,7 +9203,7 @@ not_in_argv (NSString *arg) } -/* treat scrollwheel events in the bar as though they were in the main window */ +/* Treat scrollwheel events in the bar as though they were in the main window. */ - (void) scrollWheel: (NSEvent *)theEvent { NSTRACE ("[EmacsScroller scrollWheel:]"); @@ -9198,7 +9291,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset) /* XLFD: -foundry-family-weight-slant-swidth-adstyle-pxlsz-ptSz-resx-resy-spc-avgWidth-rgstry-encoding */ /* Note: ns_font_to_xlfd and ns_fontname_to_xlfd no longer needed, removed - in 1.43. */ + in 1.43. */ const char * ns_xlfd_to_fontname (const char *xlfd) @@ -9239,7 +9332,7 @@ ns_xlfd_to_fontname (const char *xlfd) name[i+1] = c_toupper (name[i+1]); } } -/*fprintf (stderr, "converted '%s' to '%s'\n",xlfd,name); */ + /* fprintf (stderr, "converted '%s' to '%s'\n",xlfd,name); */ ret = [[NSString stringWithUTF8String: name] UTF8String]; xfree (name); return ret; @@ -9253,7 +9346,7 @@ syms_of_nsterm (void) ns_antialias_threshold = 10.0; - /* from 23+ we need to tell emacs what modifiers there are.. */ + /* From 23+ we need to tell emacs what modifiers there are. */ DEFSYM (Qmodifier_value, "modifier-value"); DEFSYM (Qalt, "alt"); DEFSYM (Qhyper, "hyper"); @@ -9265,11 +9358,11 @@ syms_of_nsterm (void) DEFSYM (Qfile, "file"); DEFSYM (Qurl, "url"); - Fput (Qalt, Qmodifier_value, make_number (alt_modifier)); - Fput (Qhyper, Qmodifier_value, make_number (hyper_modifier)); - Fput (Qmeta, Qmodifier_value, make_number (meta_modifier)); - Fput (Qsuper, Qmodifier_value, make_number (super_modifier)); - Fput (Qcontrol, Qmodifier_value, make_number (ctrl_modifier)); + Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier)); + Fput (Qhyper, Qmodifier_value, make_fixnum (hyper_modifier)); + Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier)); + Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier)); + Fput (Qcontrol, Qmodifier_value, make_fixnum (ctrl_modifier)); DEFVAR_LISP ("ns-input-file", ns_input_file, "The file specified in the last NS event."); @@ -9368,11 +9461,11 @@ allowing it to be used at a lower level for accented character entry."); DEFVAR_LISP ("ns-auto-hide-menu-bar", ns_auto_hide_menu_bar, doc: /* Non-nil means that the menu bar is hidden, but appears when the mouse is near. -Only works on Mac OS X 10.6 or later. */); +Only works on Mac OS X. */); ns_auto_hide_menu_bar = Qnil; DEFVAR_BOOL ("ns-use-native-fullscreen", ns_use_native_fullscreen, - doc: /*Non-nil means to use native fullscreen on Mac OS X 10.7 and later. + doc: /* Non-nil means to use native fullscreen on Mac OS X 10.7 and later. Nil means use fullscreen the old (< 10.7) way. The old way works better with multiple monitors, but lacks tool bar. This variable is ignored on Mac OS X < 10.7. Default is t. */); @@ -9380,60 +9473,51 @@ Mac OS X < 10.7. Default is t. */); ns_last_use_native_fullscreen = ns_use_native_fullscreen; DEFVAR_BOOL ("ns-use-fullscreen-animation", ns_use_fullscreen_animation, - doc: /*Non-nil means use animation on non-native fullscreen. + doc: /* Non-nil means use animation on non-native fullscreen. For native fullscreen, this does nothing. Default is nil. */); ns_use_fullscreen_animation = NO; DEFVAR_BOOL ("ns-use-srgb-colorspace", ns_use_srgb_colorspace, - doc: /*Non-nil means to use sRGB colorspace on Mac OS X 10.7 and later. + doc: /* Non-nil means to use sRGB colorspace on Mac OS X 10.7 and later. Note that this does not apply to images. This variable is ignored on Mac OS X < 10.7 and GNUstep. */); ns_use_srgb_colorspace = YES; DEFVAR_BOOL ("ns-use-mwheel-acceleration", ns_use_mwheel_acceleration, - doc: /*Non-nil means use macOS's standard mouse wheel acceleration. + doc: /* Non-nil means use macOS's standard mouse wheel acceleration. This variable is ignored on macOS < 10.7 and GNUstep. Default is t. */); ns_use_mwheel_acceleration = YES; DEFVAR_LISP ("ns-mwheel-line-height", ns_mwheel_line_height, - doc: /*The number of pixels touchpad scrolling considers one line. + doc: /* The number of pixels touchpad scrolling considers one line. Nil or a non-number means use the default frame line height. This variable is ignored on macOS < 10.7 and GNUstep. Default is nil. */); ns_mwheel_line_height = Qnil; DEFVAR_BOOL ("ns-use-mwheel-momentum", ns_use_mwheel_momentum, - doc: /*Non-nil means mouse wheel scrolling uses momentum. + doc: /* Non-nil means mouse wheel scrolling uses momentum. This variable is ignored on macOS < 10.7 and GNUstep. Default is t. */); ns_use_mwheel_momentum = YES; - /* TODO: move to common code */ + /* TODO: Move to common code. */ DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars, - doc: /* Which toolkit scroll bars Emacs uses, if any. -A value of nil means Emacs doesn't use toolkit scroll bars. -With the X Window system, the value is a symbol describing the -X toolkit. Possible values are: gtk, motif, xaw, or xaw3d. -With MS Windows or Nextstep, the value is t. */); + doc: /* SKIP: real doc in xterm.c. */); Vx_toolkit_scroll_bars = Qt; DEFVAR_BOOL ("x-use-underline-position-properties", x_use_underline_position_properties, - doc: /*Non-nil means make use of UNDERLINE_POSITION font properties. -A value of nil means ignore them. If you encounter fonts with bogus -UNDERLINE_POSITION font properties, for example 7x13 on XFree prior -to 4.1, set this to nil. */); + doc: /* SKIP: real doc in xterm.c. */); x_use_underline_position_properties = 0; + DEFSYM (Qx_use_underline_position_properties, + "x-use-underline-position-properties"); DEFVAR_BOOL ("x-underline-at-descent-line", x_underline_at_descent_line, - doc: /* Non-nil means to draw the underline at the same place as the descent line. -(If `line-spacing' is in effect, that moves the underline lower by -that many pixels.) -A value of nil means to draw the underline according to the value of the -variable `x-use-underline-position-properties', which is usually at the -baseline level. The default value is nil. */); + doc: /* SKIP: real doc in xterm.c. */); x_underline_at_descent_line = 0; + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); /* Tell Emacs about this window system. */ Fprovide (Qns, Qnil); diff --git a/src/print.c b/src/print.c index f626e610d2d..67c4ed03ee8 100644 --- a/src/print.c +++ b/src/print.c @@ -38,6 +38,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <c-ctype.h> #include <float.h> #include <ftoastr.h> +#include <math.h> + +#if IEEE_FLOATING_POINT +# include <ieee754.h> +#endif #ifdef WINDOWSNT # include <sys/socket.h> /* for F_DUPFD_CLOEXEC */ @@ -261,7 +266,7 @@ printchar_to_stream (unsigned int ch, FILE *stream) break; if (! (i < n)) break; - ch = XFASTINT (AREF (dv, i)); + ch = XFIXNAT (AREF (dv, i)); } } @@ -274,7 +279,7 @@ static void printchar (unsigned int ch, Lisp_Object fun) { if (!NILP (fun) && !EQ (fun, Qt)) - call1 (fun, make_number (ch)); + call1 (fun, make_fixnum (ch)); else { unsigned char str[MAX_MULTIBYTE_LENGTH]; @@ -313,6 +318,25 @@ printchar (unsigned int ch, Lisp_Object fun) } } +/* Output an octal escape for C. If C is less than '\100' consult the + following character (if any) to see whether to use three octal + digits to avoid misinterpretation of the next character. The next + character after C will be taken from DATA, starting at byte + location I, if I is less than SIZE. Use PRINTCHARFUN to output + each character. */ + +static void +octalout (unsigned char c, unsigned char *data, ptrdiff_t i, ptrdiff_t size, + Lisp_Object printcharfun) +{ + int digits = (c > '\77' || (i < size && '0' <= data[i] && data[i] <= '7') + ? 3 + : c > '\7' ? 2 : 1); + printchar ('\\', printcharfun); + do + printchar ('0' + ((c >> (3 * --digits)) & 7), printcharfun); + while (digits != 0); +} /* Output SIZE characters, SIZE_BYTE bytes from string PTR using method PRINTCHARFUN. PRINTCHARFUN nil means output to @@ -501,9 +525,9 @@ PRINTCHARFUN defaults to the value of `standard-output' (which see). */) { if (NILP (printcharfun)) printcharfun = Vstandard_output; - CHECK_NUMBER (character); + CHECK_FIXNUM (character); PRINTPREPARE; - printchar (XINT (character), printcharfun); + printchar (XFIXNUM (character), printcharfun); PRINTFINISH; return character; } @@ -752,8 +776,8 @@ You can call `print' while debugging emacs, and pass it this function to make it write to the debugging output. */) (Lisp_Object character) { - CHECK_NUMBER (character); - printchar_to_stream (XINT (character), stderr); + CHECK_FIXNUM (character); + printchar_to_stream (XFIXNUM (character), stderr); return character; } @@ -836,6 +860,17 @@ safe_debug_print (Lisp_Object arg) } } +/* This function formats the given object and returns the result as a + string. Use this in contexts where you can inspect strings, but + where stderr output won't work --- e.g., while replaying rr + recordings. */ +const char * debug_format (const char *, Lisp_Object) EXTERNALLY_VISIBLE; +const char * +debug_format (const char *fmt, Lisp_Object arg) +{ + return SSDATA (CALLN (Fformat, build_string (fmt), arg)); +} + DEFUN ("error-message-string", Ferror_message_string, Serror_message_string, 1, 1, 0, @@ -971,43 +1006,22 @@ float_to_string (char *buf, double data) int width; int len; - /* Check for plus infinity in a way that won't lose - if there is no plus infinity. */ - if (data == data / 2 && data > 1.0) - { - static char const infinity_string[] = "1.0e+INF"; - strcpy (buf, infinity_string); - return sizeof infinity_string - 1; - } - /* Likewise for minus infinity. */ - if (data == data / 2 && data < -1.0) + if (isinf (data)) { static char const minus_infinity_string[] = "-1.0e+INF"; - strcpy (buf, minus_infinity_string); - return sizeof minus_infinity_string - 1; + bool positive = 0 < data; + strcpy (buf, minus_infinity_string + positive); + return sizeof minus_infinity_string - 1 - positive; } - /* Check for NaN in a way that won't fail if there are no NaNs. */ - if (! (data * 0.0 >= 0.0)) +#if IEEE_FLOATING_POINT + if (isnan (data)) { - /* Prepend "-" if the NaN's sign bit is negative. - The sign bit of a double is the bit that is 1 in -0.0. */ - static char const NaN_string[] = "0.0e+NaN"; - int i; - union { double d; char c[sizeof (double)]; } u_data, u_minus_zero; - bool negative = 0; - u_data.d = data; - u_minus_zero.d = - 0.0; - for (i = 0; i < sizeof (double); i++) - if (u_data.c[i] & u_minus_zero.c[i]) - { - *buf = '-'; - negative = 1; - break; - } - - strcpy (buf + negative, NaN_string); - return negative + sizeof NaN_string - 1; + union ieee754_double u = { .d = data }; + uprintmax_t hi = u.ieee_nan.mantissa0; + return sprintf (buf, &"-%"pMu".0e+NaN"[!u.ieee_nan.negative], + (hi << 31 << 1) + u.ieee_nan.mantissa1); } +#endif if (NILP (Vfloat_output_format) || !STRINGP (Vfloat_output_format)) @@ -1194,11 +1208,11 @@ print_preprocess (Lisp_Object obj) && SYMBOLP (obj) && !SYMBOL_INTERNED_P (obj))) { /* OBJ appears more than once. Let's remember that. */ - if (!INTEGERP (num)) + if (!FIXNUMP (num)) { print_number_index++; /* Negative number indicates it hasn't been printed yet. */ - Fputhash (obj, make_number (- print_number_index), + Fputhash (obj, make_fixnum (- print_number_index), Vprint_number_table); } print_depth--; @@ -1298,8 +1312,7 @@ print_check_string_charset_prop (INTERVAL interval, Lisp_Object string) || CONSP (XCDR (XCDR (val)))) print_check_string_result |= PRINT_STRING_NON_CHARSET_FOUND; } - if (NILP (Vprint_charset_text_property) - || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND)) + if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND)) { int i, c; ptrdiff_t charpos = interval->position; @@ -1329,19 +1342,20 @@ print_prune_string_charset (Lisp_Object string) print_check_string_result = 0; traverse_intervals (string_intervals (string), 0, print_check_string_charset_prop, string); - if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND)) + if (NILP (Vprint_charset_text_property) + || ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND)) { string = Fcopy_sequence (string); if (print_check_string_result & PRINT_STRING_NON_CHARSET_FOUND) { if (NILP (print_prune_charset_plist)) print_prune_charset_plist = list1 (Qcharset); - Fremove_text_properties (make_number (0), - make_number (SCHARS (string)), + Fremove_text_properties (make_fixnum (0), + make_fixnum (SCHARS (string)), print_prune_charset_plist, string); } else - Fset_text_properties (make_number (0), make_number (SCHARS (string)), + Fset_text_properties (make_fixnum (0), make_fixnum (SCHARS (string)), Qnil, string); } return string; @@ -1353,6 +1367,78 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, { switch (PSEUDOVECTOR_TYPE (XVECTOR (obj))) { + case PVEC_BIGNUM: + { + ptrdiff_t size = bignum_bufsize (obj, 10); + USE_SAFE_ALLOCA; + char *str = SAFE_ALLOCA (size); + ptrdiff_t len = bignum_to_c_string (str, size, obj, 10); + strout (str, len, len, printcharfun); + SAFE_FREE (); + } + break; + + case PVEC_MARKER: + print_c_string ("#<marker ", printcharfun); + /* Do you think this is necessary? */ + if (XMARKER (obj)->insertion_type != 0) + print_c_string ("(moves after insertion) ", printcharfun); + if (! XMARKER (obj)->buffer) + print_c_string ("in no buffer", printcharfun); + else + { + int len = sprintf (buf, "at %"pD"d in ", marker_position (obj)); + strout (buf, len, len, printcharfun); + print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun); + } + printchar ('>', printcharfun); + break; + + case PVEC_OVERLAY: + print_c_string ("#<overlay ", printcharfun); + if (! XMARKER (OVERLAY_START (obj))->buffer) + print_c_string ("in no buffer", printcharfun); + else + { + int len = sprintf (buf, "from %"pD"d to %"pD"d in ", + marker_position (OVERLAY_START (obj)), + marker_position (OVERLAY_END (obj))); + strout (buf, len, len, printcharfun); + print_string (BVAR (XMARKER (OVERLAY_START (obj))->buffer, name), + printcharfun); + } + printchar ('>', printcharfun); + break; + +#ifdef HAVE_MODULES + case PVEC_USER_PTR: + { + print_c_string ("#<user-ptr ", printcharfun); + int i = sprintf (buf, "ptr=%p finalizer=%p", + XUSER_PTR (obj)->p, + XUSER_PTR (obj)->finalizer); + strout (buf, i, i, printcharfun); + printchar ('>', printcharfun); + } + break; +#endif + + case PVEC_FINALIZER: + print_c_string ("#<finalizer", printcharfun); + if (NILP (XFINALIZER (obj)->function)) + print_c_string (" used", printcharfun); + printchar ('>', printcharfun); + break; + + case PVEC_MISC_PTR: + { + /* This shouldn't happen in normal usage, but let's + print it anyway for the benefit of the debugger. */ + int i = sprintf (buf, "#<ptr %p>", xmint_pointer (obj)); + strout (buf, i, i, printcharfun); + } + break; + case PVEC_PROCESS: if (escapeflag) { @@ -1367,32 +1453,33 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_BOOL_VECTOR: { EMACS_INT size = bool_vector_size (obj); - ptrdiff_t size_in_chars = bool_vector_bytes (size); - ptrdiff_t real_size_in_chars = size_in_chars; + ptrdiff_t size_in_bytes = bool_vector_bytes (size); + ptrdiff_t real_size_in_bytes = size_in_bytes; + unsigned char *data = bool_vector_uchar_data (obj); int len = sprintf (buf, "#&%"pI"d\"", size); strout (buf, len, len, printcharfun); - /* Don't print more characters than the specified maximum. + /* Don't print more bytes than the specified maximum. Negative values of print-length are invalid. Treat them like a print-length of nil. */ - if (NATNUMP (Vprint_length) - && XFASTINT (Vprint_length) < size_in_chars) - size_in_chars = XFASTINT (Vprint_length); + if (FIXNATP (Vprint_length) + && XFIXNAT (Vprint_length) < size_in_bytes) + size_in_bytes = XFIXNAT (Vprint_length); - for (ptrdiff_t i = 0; i < size_in_chars; i++) + for (ptrdiff_t i = 0; i < size_in_bytes; i++) { maybe_quit (); - unsigned char c = bool_vector_uchar_data (obj)[i]; + unsigned char c = data[i]; if (c == '\n' && print_escape_newlines) print_c_string ("\\n", printcharfun); else if (c == '\f' && print_escape_newlines) print_c_string ("\\f", printcharfun); - else if (c > '\177') + else if (c > '\177' + || (print_escape_control_characters && c_iscntrl (c))) { /* Use octal escapes to avoid encoding issues. */ - int len = sprintf (buf, "\\%o", c); - strout (buf, len, len, printcharfun); + octalout (c, data, i + 1, size_in_bytes, printcharfun); } else { @@ -1402,7 +1489,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } } - if (size_in_chars < real_size_in_chars) + if (size_in_bytes < real_size_in_bytes) print_c_string (" ...", printcharfun); printchar ('\"', printcharfun); } @@ -1490,8 +1577,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, ptrdiff_t size = real_size; /* Don't print more elements than the specified maximum. */ - if (NATNUMP (Vprint_length) && XFASTINT (Vprint_length) < size) - size = XFASTINT (Vprint_length); + if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) + size = XFIXNAT (Vprint_length); printchar ('(', printcharfun); for (ptrdiff_t i = 0; i < size; i++) @@ -1621,8 +1708,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, /* Don't print more elements than the specified maximum. */ ptrdiff_t n - = (NATNUMP (Vprint_length) && XFASTINT (Vprint_length) < size - ? XFASTINT (Vprint_length) : size); + = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size + ? XFIXNAT (Vprint_length) : size); print_c_string ("#s(", printcharfun); for (ptrdiff_t i = 0; i < n; i ++) @@ -1682,9 +1769,9 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } /* Don't print more elements than the specified maximum. */ - if (NATNUMP (Vprint_length) - && XFASTINT (Vprint_length) < size) - size = XFASTINT (Vprint_length); + if (FIXNATP (Vprint_length) + && XFIXNAT (Vprint_length) < size) + size = XFIXNAT (Vprint_length); for (int i = idx; i < size; i++) { @@ -1774,16 +1861,16 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* With the print-circle feature. */ Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); - if (INTEGERP (num)) + if (FIXNUMP (num)) { - EMACS_INT n = XINT (num); + EMACS_INT n = XFIXNUM (num); if (n < 0) { /* Add a prefix #n= if OBJ has not yet been printed; that is, its status field is nil. */ int len = sprintf (buf, "#%"pI"d=", -n); strout (buf, len, len, printcharfun); /* OBJ is going to be printed. Remember that fact. */ - Fputhash (obj, make_number (- n), Vprint_number_table); + Fputhash (obj, make_fixnum (- n), Vprint_number_table); } else { @@ -1801,7 +1888,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { case_Lisp_Int: { - int len = sprintf (buf, "%"pI"d", XINT (obj)); + int len = sprintf (buf, "%"pI"d", XFIXNUM (obj)); strout (buf, len, len, printcharfun); } break; @@ -1854,9 +1941,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) (when requested) a non-ASCII character in a unibyte buffer, print single-byte non-ASCII string chars using octal escapes. */ - char outbuf[5]; - int len = sprintf (outbuf, "\\%03o", c + 0u); - strout (outbuf, len, len, printcharfun); + octalout (c, SDATA (obj), i_byte, size_byte, printcharfun); need_nonhex = false; } else if (multibyte @@ -1870,7 +1955,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } else { - bool still_need_nonhex = false; /* If we just had a hex escape, and this character could be taken as part of it, output `\ ' to prevent that. */ @@ -1884,22 +1968,16 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) ? (c = 'n', true) : c == '\f' && print_escape_newlines ? (c = 'f', true) - : c == '\0' && print_escape_control_characters - ? (c = '0', still_need_nonhex = true) : c == '\"' || c == '\\') { printchar ('\\', printcharfun); printchar (c, printcharfun); } else if (print_escape_control_characters && c_iscntrl (c)) - { - char outbuf[1 + 3 + 1]; - int len = sprintf (outbuf, "\\%03o", c + 0u); - strout (outbuf, len, len, printcharfun); - } + octalout (c, SDATA (obj), i_byte, size_byte, printcharfun); else printchar (c, printcharfun); - need_nonhex = still_need_nonhex; + need_nonhex = false; } } printchar ('\"', printcharfun); @@ -1915,39 +1993,17 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) case Lisp_Symbol: { - bool confusing; - unsigned char *p = SDATA (SYMBOL_NAME (obj)); - unsigned char *end = p + SBYTES (SYMBOL_NAME (obj)); - int c; - ptrdiff_t i, i_byte; - ptrdiff_t size_byte; - Lisp_Object name; - - name = SYMBOL_NAME (obj); - - if (p != end && (*p == '-' || *p == '+')) p++; - if (p == end) - confusing = 0; - /* If symbol name begins with a digit, and ends with a digit, - and contains nothing but digits and `e', it could be treated - as a number. So set CONFUSING. - - Symbols that contain periods could also be taken as numbers, - but periods are always escaped, so we don't have to worry - about them here. */ - else if (*p >= '0' && *p <= '9' - && end[-1] >= '0' && end[-1] <= '9') - { - while (p != end && ((*p >= '0' && *p <= '9') - /* Needed for \2e10. */ - || *p == 'e' || *p == 'E')) - p++; - confusing = (end == p); - } - else - confusing = 0; - - size_byte = SBYTES (name); + Lisp_Object name = SYMBOL_NAME (obj); + ptrdiff_t size_byte = SBYTES (name); + + /* Set CONFUSING if NAME looks like a number, calling + string_to_number for non-obvious cases. */ + char *p = SSDATA (name); + bool signedp = *p == '-' || *p == '+'; + ptrdiff_t len; + bool confusing = ((c_isdigit (p[signedp]) || p[signedp] == '.') + && !NILP (string_to_number (p, 10, &len)) + && len == size_byte); if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj)) @@ -1958,10 +2014,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) break; } - for (i = 0, i_byte = 0; i_byte < size_byte;) + ptrdiff_t i = 0; + for (ptrdiff_t i_byte = 0; i_byte < size_byte; ) { /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ + int c; FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte); maybe_quit (); @@ -1971,7 +2029,9 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) || c == ';' || c == '#' || c == '(' || c == ')' || c == ',' || c == '.' || c == '`' || c == '[' || c == ']' || c == '?' || c <= 040 - || confusing) + || c == NO_BREAK_SPACE + || confusing + || (i == 1 && confusable_symbol_character_p (c))) { printchar ('\\', printcharfun); confusing = false; @@ -1984,8 +2044,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) case Lisp_Cons: /* If deeper than spec'd depth, print placeholder. */ - if (INTEGERP (Vprint_level) - && print_depth > XINT (Vprint_level)) + if (FIXNUMP (Vprint_level) + && print_depth > XFIXNUM (Vprint_level)) print_c_string ("...", printcharfun); else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) && EQ (XCAR (obj), Qquote)) @@ -2026,8 +2086,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) /* Negative values of print-length are invalid in CL. Treat them like nil, as CMUCL does. */ - printmax_t print_length = (NATNUMP (Vprint_length) - ? XFASTINT (Vprint_length) + printmax_t print_length = (FIXNATP (Vprint_length) + ? XFIXNAT (Vprint_length) : TYPE_MAXIMUM (printmax_t)); printmax_t i = 0; @@ -2050,7 +2110,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) if (i != 0) { Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); - if (INTEGERP (num)) + if (FIXNUMP (num)) { print_c_string (" . ", printcharfun); print_object (obj, printcharfun, escapeflag); @@ -2089,170 +2149,16 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) break; case Lisp_Vectorlike: - if (! print_vectorlike (obj, printcharfun, escapeflag, buf)) - goto badtype; - break; - - case Lisp_Misc: - switch (XMISCTYPE (obj)) - { - case Lisp_Misc_Marker: - print_c_string ("#<marker ", printcharfun); - /* Do you think this is necessary? */ - if (XMARKER (obj)->insertion_type != 0) - print_c_string ("(moves after insertion) ", printcharfun); - if (! XMARKER (obj)->buffer) - print_c_string ("in no buffer", printcharfun); - else - { - int len = sprintf (buf, "at %"pD"d in ", marker_position (obj)); - strout (buf, len, len, printcharfun); - print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun); - } - printchar ('>', printcharfun); - break; - - case Lisp_Misc_Overlay: - print_c_string ("#<overlay ", printcharfun); - if (! XMARKER (OVERLAY_START (obj))->buffer) - print_c_string ("in no buffer", printcharfun); - else - { - int len = sprintf (buf, "from %"pD"d to %"pD"d in ", - marker_position (OVERLAY_START (obj)), - marker_position (OVERLAY_END (obj))); - strout (buf, len, len, printcharfun); - print_string (BVAR (XMARKER (OVERLAY_START (obj))->buffer, name), - printcharfun); - } - printchar ('>', printcharfun); - break; - -#ifdef HAVE_MODULES - case Lisp_Misc_User_Ptr: - { - print_c_string ("#<user-ptr ", printcharfun); - int i = sprintf (buf, "ptr=%p finalizer=%p", - XUSER_PTR (obj)->p, - XUSER_PTR (obj)->finalizer); - strout (buf, i, i, printcharfun); - printchar ('>', printcharfun); - break; - } -#endif - - case Lisp_Misc_Finalizer: - print_c_string ("#<finalizer", printcharfun); - if (NILP (XFINALIZER (obj)->function)) - print_c_string (" used", printcharfun); - printchar ('>', printcharfun); - break; - - /* Remaining cases shouldn't happen in normal usage, but let's - print them anyway for the benefit of the debugger. */ - - case Lisp_Misc_Free: - print_c_string ("#<misc free cell>", printcharfun); - break; - - case Lisp_Misc_Save_Value: - { - int i; - struct Lisp_Save_Value *v = XSAVE_VALUE (obj); - - print_c_string ("#<save-value ", printcharfun); - - if (v->save_type == SAVE_TYPE_MEMORY) - { - ptrdiff_t amount = v->data[1].integer; - - /* valid_lisp_object_p is reliable, so try to print up - to 8 saved objects. This code is rarely used, so - it's OK that valid_lisp_object_p is slow. */ - - int limit = min (amount, 8); - Lisp_Object *area = v->data[0].pointer; - - i = sprintf (buf, "with %"pD"d objects", amount); - strout (buf, i, i, printcharfun); - - for (i = 0; i < limit; i++) - { - Lisp_Object maybe = area[i]; - int valid = valid_lisp_object_p (maybe); - - printchar (' ', printcharfun); - if (0 < valid) - print_object (maybe, printcharfun, escapeflag); - else - print_c_string (valid < 0 ? "<some>" : "<invalid>", - printcharfun); - } - if (i == limit && i < amount) - print_c_string (" ...", printcharfun); - } - else - { - /* Print each slot according to its type. */ - int index; - for (index = 0; index < SAVE_VALUE_SLOTS; index++) - { - if (index) - printchar (' ', printcharfun); - - switch (save_type (v, index)) - { - case SAVE_UNUSED: - i = sprintf (buf, "<unused>"); - break; - - case SAVE_POINTER: - i = sprintf (buf, "<pointer %p>", - v->data[index].pointer); - break; - - case SAVE_FUNCPOINTER: - i = sprintf (buf, "<funcpointer %p>", - ((void *) (intptr_t) - v->data[index].funcpointer)); - break; - - case SAVE_INTEGER: - i = sprintf (buf, "<integer %"pD"d>", - v->data[index].integer); - break; - - case SAVE_OBJECT: - print_object (v->data[index].object, printcharfun, - escapeflag); - continue; - - default: - emacs_abort (); - } - - strout (buf, i, i, printcharfun); - } - } - printchar ('>', printcharfun); - } - break; - - default: - goto badtype; - } - break; - + if (print_vectorlike (obj, printcharfun, escapeflag, buf)) + break; + FALLTHROUGH; default: - badtype: { int len; /* We're in trouble if this happens! Probably should just emacs_abort (). */ print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun); - if (MISCP (obj)) - len = sprintf (buf, "(MISC 0x%04x)", (unsigned) XMISCTYPE (obj)); - else if (VECTORLIKEP (obj)) + if (VECTORLIKEP (obj)) len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj)); else len = sprintf (buf, "(0x%02x)", (unsigned) XTYPE (obj)); @@ -2276,9 +2182,9 @@ print_interval (INTERVAL interval, Lisp_Object printcharfun) if (NILP (interval->plist)) return; printchar (' ', printcharfun); - print_object (make_number (interval->position), printcharfun, 1); + print_object (make_fixnum (interval->position), printcharfun, 1); printchar (' ', printcharfun); - print_object (make_number (interval->position + LENGTH (interval)), + print_object (make_fixnum (interval->position + LENGTH (interval)), printcharfun, 1); printchar (' ', printcharfun); print_object (interval->plist, printcharfun, 1); @@ -2366,7 +2272,7 @@ This affects only `prin1'. */); DEFVAR_BOOL ("print-quoted", print_quoted, doc: /* Non-nil means print quoted forms with reader syntax. I.e., (quote foo) prints as \\='foo, (function foo) as #\\='foo. */); - print_quoted = 0; + print_quoted = true; DEFVAR_LISP ("print-gensym", Vprint_gensym, doc: /* Non-nil means print uninterned symbols so they will read as uninterned. @@ -2411,7 +2317,7 @@ that need to be recorded in the table. */); DEFVAR_LISP ("print-charset-text-property", Vprint_charset_text_property, doc: /* A flag to control printing of `charset' text property on printing a string. -The value must be nil, t, or `default'. +The value should be nil, t, or `default'. If the value is nil, don't print the text property `charset'. @@ -2419,7 +2325,8 @@ If the value is t, always print the text property `charset'. If the value is `default', print the text property `charset' only when the value is different from what is guessed in the current charset -priorities. */); +priorities. Values other than nil or t are also treated as +`default'. */); Vprint_charset_text_property = Qdefault; /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ @@ -2435,10 +2342,8 @@ priorities. */); defsubr (&Sredirect_debugging_output); defsubr (&Sprint_preprocess); - DEFSYM (Qprint_escape_newlines, "print-escape-newlines"); DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte"); DEFSYM (Qprint_escape_nonascii, "print-escape-nonascii"); - DEFSYM (Qprint_escape_control_characters, "print-escape-control-characters"); print_prune_charset_plist = Qnil; staticpro (&print_prune_charset_plist); diff --git a/src/process.c b/src/process.c index 7f32150e8ec..b2a7f38317a 100644 --- a/src/process.c +++ b/src/process.c @@ -160,6 +160,18 @@ static bool kbd_is_on_hold; when exiting. */ bool inhibit_sentinels; +union u_sockaddr +{ + struct sockaddr sa; + struct sockaddr_in in; +#ifdef AF_INET6 + struct sockaddr_in6 in6; +#endif +#ifdef HAVE_LOCAL_SOCKETS + struct sockaddr_un un; +#endif +}; + #ifdef subprocesses #ifndef SOCK_CLOEXEC @@ -240,7 +252,7 @@ static EMACS_INT update_tick; # define HAVE_SEQPACKET #endif -#define READ_OUTPUT_DELAY_INCREMENT (TIMESPEC_RESOLUTION / 100) +#define READ_OUTPUT_DELAY_INCREMENT (TIMESPEC_HZ / 100) #define READ_OUTPUT_DELAY_MAX (READ_OUTPUT_DELAY_INCREMENT * 5) #define READ_OUTPUT_DELAY_MAX_MAX (READ_OUTPUT_DELAY_INCREMENT * 7) @@ -672,12 +684,12 @@ static Lisp_Object status_convert (int w) { if (WIFSTOPPED (w)) - return Fcons (Qstop, Fcons (make_number (WSTOPSIG (w)), Qnil)); + return Fcons (Qstop, Fcons (make_fixnum (WSTOPSIG (w)), Qnil)); else if (WIFEXITED (w)) - return Fcons (Qexit, Fcons (make_number (WEXITSTATUS (w)), + return Fcons (Qexit, Fcons (make_fixnum (WEXITSTATUS (w)), WCOREDUMP (w) ? Qt : Qnil)); else if (WIFSIGNALED (w)) - return Fcons (Qsignal, Fcons (make_number (WTERMSIG (w)), + return Fcons (Qsignal, Fcons (make_fixnum (WTERMSIG (w)), WCOREDUMP (w) ? Qt : Qnil)); else return Qrun; @@ -706,7 +718,7 @@ decode_status (Lisp_Object l, Lisp_Object *symbol, Lisp_Object *code, if (SYMBOLP (l)) { *symbol = l; - *code = make_number (0); + *code = make_fixnum (0); *coredump = 0; } else @@ -735,7 +747,7 @@ status_message (struct Lisp_Process *p) { char const *signame; synchronize_system_messages_locale (); - signame = strsignal (XFASTINT (code)); + signame = strsignal (XFIXNAT (code)); if (signame == 0) string = build_string ("unknown"); else @@ -749,7 +761,7 @@ status_message (struct Lisp_Process *p) c1 = STRING_CHAR (SDATA (string)); c2 = downcase (c1); if (c1 != c2) - Faset (string, make_number (0), make_number (c2)); + Faset (string, make_fixnum (0), make_fixnum (c2)); } AUTO_STRING (suffix, coredump ? " (core dumped)\n" : "\n"); return concat2 (string, suffix); @@ -757,10 +769,10 @@ status_message (struct Lisp_Process *p) else if (EQ (symbol, Qexit)) { if (NETCONN1_P (p)) - return build_string (XFASTINT (code) == 0 + return build_string (XFIXNAT (code) == 0 ? "deleted\n" : "connection broken by remote peer\n"); - if (XFASTINT (code) == 0) + if (XFIXNAT (code) == 0) return build_string ("finished\n"); AUTO_STRING (prefix, "exited abnormally with code "); string = Fnumber_to_string (code); @@ -1013,7 +1025,7 @@ static Lisp_Object deleted_pid_list; void record_deleted_pid (pid_t pid, Lisp_Object filename) { - deleted_pid_list = Fcons (Fcons (make_fixnum_or_float (pid), filename), + deleted_pid_list = Fcons (Fcons (INT_TO_INTEGER (pid), filename), /* GC treated elements set to nil. */ Fdelq (Qnil, deleted_pid_list)); @@ -1052,7 +1064,7 @@ nil, indicating the current buffer's process. */) p->raw_status_new = 0; if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) { - pset_status (p, list2 (Qexit, make_number (0))); + pset_status (p, list2 (Qexit, make_fixnum (0))); p->tick = ++process_tick; status_notify (p, NULL); redisplay_preserve_echo_area (13); @@ -1071,7 +1083,7 @@ nil, indicating the current buffer's process. */) update_status (p); symbol = CONSP (p->status) ? XCAR (p->status) : p->status; if (! (EQ (symbol, Qsignal) || EQ (symbol, Qexit))) - pset_status (p, list2 (Qsignal, make_number (SIGKILL))); + pset_status (p, list2 (Qsignal, make_fixnum (SIGKILL))); p->tick = ++process_tick; status_notify (p, NULL); @@ -1139,12 +1151,13 @@ If PROCESS has not yet exited or died, return 0. */) update_status (XPROCESS (process)); if (CONSP (XPROCESS (process)->status)) return XCAR (XCDR (XPROCESS (process)->status)); - return make_number (0); + return make_fixnum (0); } DEFUN ("process-id", Fprocess_id, Sprocess_id, 1, 1, 0, doc: /* Return the process id of PROCESS. This is the pid of the external process which PROCESS uses or talks to. +It is a fixnum if the value is small enough, otherwise a bignum. For a network, serial, and pipe connections, this value is nil. */) (register Lisp_Object process) { @@ -1152,7 +1165,7 @@ For a network, serial, and pipe connections, this value is nil. */) CHECK_PROCESS (process); pid = XPROCESS (process)->pid; - return (pid ? make_fixnum_or_float (pid) : Qnil); + return pid ? INT_TO_INTEGER (pid) : Qnil; } DEFUN ("process-name", Fprocess_name, Sprocess_name, 1, 1, 0, @@ -1248,10 +1261,7 @@ passed to the filter. The filter gets two arguments: the process and the string of output. The string argument is normally a multibyte string, except: - if the process's input coding system is no-conversion or raw-text, - it is a unibyte string (the non-converted input), or else -- 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'). */) + it is a unibyte string (the non-converted input). */) (Lisp_Object process, Lisp_Object filter) { CHECK_PROCESS (process); @@ -1374,7 +1384,7 @@ nil otherwise. */) if (NETCONN_P (process) || XPROCESS (process)->infd < 0 || (set_window_size (XPROCESS (process)->infd, - XINT (height), XINT (width)) + XFIXNUM (height), XFIXNUM (width)) < 0)) return Qnil; else @@ -1575,12 +1585,12 @@ Return nil if format of ADDRESS is invalid. */) for (i = 0; i < nargs; i++) { - if (! RANGED_INTEGERP (0, p->contents[i], 65535)) + if (! RANGED_FIXNUMP (0, p->contents[i], 65535)) return Qnil; if (nargs <= 5 /* IPv4 */ && i < 4 /* host, not port */ - && XINT (p->contents[i]) > 255) + && XFIXNUM (p->contents[i]) > 255) return Qnil; args[i + 1] = p->contents[i]; @@ -1648,7 +1658,13 @@ to use a pty, or nil to use the default specified through :stderr STDERR -- STDERR is either a buffer or a pipe process attached to the standard error of subprocess. Specifying this implies -`:connection-type' is set to `pipe'. +`:connection-type' is set to `pipe'. If STDERR is nil, standard error +is mixed with standard output and sent to BUFFER or FILTER. + +:file-handler FILE-HANDLER -- If FILE-HANDLER is non-nil, then look +for a file name handler for the current buffer's `default-directory' +and invoke that file name handler to make the process. If there is no +such handler, proceed as if FILE-HANDLER were nil. usage: (make-process &rest ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) @@ -1663,6 +1679,15 @@ usage: (make-process &rest ARGS) */) /* Save arguments for process-contact and clone-process. */ contact = Flist (nargs, args); + if (!NILP (Fplist_get (contact, QCfile_handler))) + { + Lisp_Object file_handler + = Ffind_file_name_handler (BVAR (current_buffer, directory), + Qmake_process); + if (!NILP (file_handler)) + return CALLN (Fapply, file_handler, Qmake_process, contact); + } + buffer = Fplist_get (contact, QCbuffer); if (!NILP (buffer)) buffer = Fget_buffer_create (buffer); @@ -1779,7 +1804,7 @@ usage: (make-process &rest ARGS) */) val = Vcoding_system_for_read; if (NILP (val)) { - ptrdiff_t nargs2 = 3 + XINT (Flength (command)); + ptrdiff_t nargs2 = 3 + XFIXNUM (Flength (command)); Lisp_Object tem2; SAFE_ALLOCA_LISP (args2, nargs2); ptrdiff_t i = 0; @@ -1809,7 +1834,7 @@ usage: (make-process &rest ARGS) */) { if (EQ (coding_systems, Qt)) { - ptrdiff_t nargs2 = 3 + XINT (Flength (command)); + ptrdiff_t nargs2 = 3 + XFIXNUM (Flength (command)); Lisp_Object tem2; SAFE_ALLOCA_LISP (args2, nargs2); ptrdiff_t i = 0; @@ -1854,7 +1879,7 @@ usage: (make-process &rest ARGS) */) { tem = Qnil; openp (Vexec_path, program, Vexec_suffixes, &tem, - make_number (X_OK), false); + make_fixnum (X_OK), false); if (NILP (tem)) report_file_error ("Searching for program", program); tem = Fexpand_file_name (tem, Qnil); @@ -1913,8 +1938,7 @@ usage: (make-process &rest ARGS) */) else create_pty (proc); - SAFE_FREE (); - return unbind_to (count, proc); + return SAFE_FREE_UNBIND_TO (count, proc); } /* If PROC doesn't have its pid set, then an error was signaled and @@ -1939,6 +1963,26 @@ close_process_fd (int *fd_addr) } } +void +dissociate_controlling_tty (void) +{ + if (setsid () < 0) + { +#ifdef TIOCNOTTY + /* Needed on Darwin after vfork, since setsid fails in a vforked + child that has not execed. + I wonder: would just ioctl (fd, TIOCNOTTY, 0) work here, for + some fd that the caller already has? */ + int ttyfd = emacs_open (DEV_TTY, O_RDWR, 0); + if (0 <= ttyfd) + { + ioctl (ttyfd, TIOCNOTTY, 0); + emacs_close (ttyfd); + } +#endif + } +} + /* Indexes of file descriptors in open_fds. */ enum { @@ -2087,9 +2131,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. - Do this even if !PTY_FLAG; see Bug#30762. */ - setsid (); + dissociate_controlling_tty (); + /* Make the pty's terminal the controlling terminal. */ if (pty_flag && forkin >= 0) { @@ -2118,21 +2161,6 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) } #endif #endif -#ifdef TIOCNOTTY - /* In 4.3BSD, the TIOCSPGRP bug has been fixed, and now you - can do TIOCSPGRP only to the process's controlling tty. */ - if (pty_flag) - { - /* 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); - if (j >= 0) - { - ioctl (j, TIOCNOTTY, 0); - emacs_close (j); - } - } -#endif /* TIOCNOTTY */ #if !defined (DONT_REOPEN_PTY) /*** There is a suggestion that this ought to be a @@ -2478,7 +2506,6 @@ Lisp_Object conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len) { Lisp_Object address; - ptrdiff_t i; unsigned char *cp; struct Lisp_Vector *p; @@ -2494,9 +2521,9 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len) { DECLARE_POINTER_ALIAS (sin, struct sockaddr_in, sa); len = sizeof (sin->sin_addr) + 1; - address = Fmake_vector (make_number (len), Qnil); + address = make_uninit_vector (len); p = XVECTOR (address); - p->contents[--len] = make_number (ntohs (sin->sin_port)); + p->contents[--len] = make_fixnum (ntohs (sin->sin_port)); cp = (unsigned char *) &sin->sin_addr; break; } @@ -2506,11 +2533,11 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len) DECLARE_POINTER_ALIAS (sin6, struct sockaddr_in6, sa); DECLARE_POINTER_ALIAS (ip6, uint16_t, &sin6->sin6_addr); len = sizeof (sin6->sin6_addr) / 2 + 1; - address = Fmake_vector (make_number (len), Qnil); + address = make_uninit_vector (len); p = XVECTOR (address); - p->contents[--len] = make_number (ntohs (sin6->sin6_port)); - for (i = 0; i < len; i++) - p->contents[i] = make_number (ntohs (ip6[i])); + p->contents[--len] = make_fixnum (ntohs (sin6->sin6_port)); + for (ptrdiff_t i = 0; i < len; i++) + p->contents[i] = make_fixnum (ntohs (ip6[i])); return address; } #endif @@ -2538,16 +2565,14 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len) #endif default: len -= offsetof (struct sockaddr, sa_family) + sizeof (sa->sa_family); - address = Fcons (make_number (sa->sa_family), - Fmake_vector (make_number (len), Qnil)); + address = Fcons (make_fixnum (sa->sa_family), make_nil_vector (len)); p = XVECTOR (XCDR (address)); cp = (unsigned char *) &sa->sa_family + sizeof (sa->sa_family); break; } - i = 0; - while (i < len) - p->contents[i++] = make_number (*cp++); + for (ptrdiff_t i = 0; i < len; i++) + p->contents[i] = make_fixnum (*cp++); return address; } @@ -2557,8 +2582,8 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len) static Lisp_Object conv_addrinfo_to_lisp (struct addrinfo *res) { - Lisp_Object protocol = make_number (res->ai_protocol); - eassert (XINT (protocol) == res->ai_protocol); + Lisp_Object protocol = make_fixnum (res->ai_protocol); + eassert (XFIXNUM (protocol) == res->ai_protocol); return Fcons (protocol, conv_sockaddr_to_lisp (res->ai_addr, res->ai_addrlen)); } @@ -2593,14 +2618,14 @@ get_lisp_to_sockaddr_size (Lisp_Object address, int *familyp) return sizeof (struct sockaddr_un); } #endif - else if (CONSP (address) && TYPE_RANGED_INTEGERP (int, XCAR (address)) + else if (CONSP (address) && TYPE_RANGED_FIXNUMP (int, XCAR (address)) && VECTORP (XCDR (address))) { struct sockaddr *sa; p = XVECTOR (XCDR (address)); if (MAX_ALLOCA - sizeof sa->sa_family < p->header.size) return 0; - *familyp = XINT (XCAR (address)); + *familyp = XFIXNUM (XCAR (address)); return p->header.size + sizeof (sa->sa_family); } return 0; @@ -2630,7 +2655,7 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int { DECLARE_POINTER_ALIAS (sin, struct sockaddr_in, sa); len = sizeof (sin->sin_addr) + 1; - hostport = XINT (p->contents[--len]); + hostport = XFIXNUM (p->contents[--len]); sin->sin_port = htons (hostport); cp = (unsigned char *)&sin->sin_addr; sa->sa_family = family; @@ -2641,12 +2666,12 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int DECLARE_POINTER_ALIAS (sin6, struct sockaddr_in6, sa); DECLARE_POINTER_ALIAS (ip6, uint16_t, &sin6->sin6_addr); len = sizeof (sin6->sin6_addr) / 2 + 1; - hostport = XINT (p->contents[--len]); + hostport = XFIXNUM (p->contents[--len]); sin6->sin6_port = htons (hostport); for (i = 0; i < len; i++) - if (INTEGERP (p->contents[i])) + if (FIXNUMP (p->contents[i])) { - int j = XFASTINT (p->contents[i]) & 0xffff; + int j = XFIXNAT (p->contents[i]) & 0xffff; ip6[i] = ntohs (j); } sa->sa_family = family; @@ -2677,8 +2702,8 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int } for (i = 0; i < len; i++) - if (INTEGERP (p->contents[i])) - *cp++ = XFASTINT (p->contents[i]) & 0xff; + if (FIXNUMP (p->contents[i])) + *cp++ = XFIXNAT (p->contents[i]) & 0xff; } #ifdef DATAGRAM_SOCKETS @@ -2809,8 +2834,8 @@ set_socket_option (int s, Lisp_Object opt, Lisp_Object val) case SOPT_INT: { int optval; - if (TYPE_RANGED_INTEGERP (int, val)) - optval = XINT (val); + if (TYPE_RANGED_FIXNUMP (int, val)) + optval = XFIXNUM (val); else error ("Bad option value for %s", name); ret = setsockopt (s, sopt->optlevel, sopt->optnum, @@ -2848,8 +2873,8 @@ set_socket_option (int s, Lisp_Object opt, Lisp_Object val) linger.l_onoff = 1; linger.l_linger = 0; - if (TYPE_RANGED_INTEGERP (int, val)) - linger.l_linger = XINT (val); + if (TYPE_RANGED_FIXNUMP (int, val)) + linger.l_linger = XFIXNUM (val); else linger.l_onoff = NILP (val) ? 0 : 1; ret = setsockopt (s, sopt->optlevel, sopt->optnum, @@ -3093,7 +3118,7 @@ usage: (make-serial-process &rest ARGS) */) if (NILP (Fplist_member (contact, QCspeed))) error (":speed not specified"); if (!NILP (Fplist_get (contact, QCspeed))) - CHECK_NUMBER (Fplist_get (contact, QCspeed)); + CHECK_FIXNUM (Fplist_get (contact, QCspeed)); name = Fplist_get (contact, QCname); if (NILP (name)) @@ -3325,7 +3350,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, int xerrno = 0; int family; int ret; - ptrdiff_t addrlen; + ptrdiff_t addrlen UNINIT; struct Lisp_Process *p = XPROCESS (proc); Lisp_Object contact = p->childp; int optbits = 0; @@ -3351,7 +3376,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, { Lisp_Object addrinfo = XCAR (addrinfos); addrinfos = XCDR (addrinfos); - int protocol = XINT (XCAR (addrinfo)); + int protocol = XFIXNUM (XCAR (addrinfo)); Lisp_Object ip_address = XCDR (addrinfo); #ifdef WINDOWSNT @@ -3457,7 +3482,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, DECLARE_POINTER_ALIAS (psa1, struct sockaddr, &sa1); if (getsockname (s, psa1, &len1) == 0) { - Lisp_Object service = make_number (ntohs (sa1.sin_port)); + Lisp_Object service = make_fixnum (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. */ @@ -3773,8 +3798,7 @@ The stopped state is cleared by `continue-process' and set by :filter-multibyte BOOL -- If BOOL is non-nil, strings given to the process filter are multibyte, otherwise they are unibyte. -If this keyword is not specified, the strings are multibyte if -the default value of `enable-multibyte-characters' is non-nil. +If this keyword is not specified, the strings are multibyte. :sentinel SENTINEL -- Install SENTINEL as the process sentinel. @@ -3851,7 +3875,6 @@ usage: (make-network-process &rest ARGS) */) Lisp_Object contact; struct Lisp_Process *p; const char *portstring UNINIT; - ptrdiff_t portstringlen ATTRIBUTE_UNUSED; char portbuf[INT_BUFSIZE_BOUND (EMACS_INT)]; #ifdef HAVE_LOCAL_SOCKETS struct sockaddr_un address_un; @@ -3919,7 +3942,7 @@ usage: (make-network-process &rest ARGS) */) if (!get_lisp_to_sockaddr_size (address, &family)) error ("Malformed :address"); - addrinfos = list1 (Fcons (make_number (any_protocol), address)); + addrinfos = list1 (Fcons (make_fixnum (any_protocol), address)); goto open_socket; } @@ -3943,8 +3966,8 @@ usage: (make-network-process &rest ARGS) */) #endif else if (EQ (tem, Qipv4)) family = AF_INET; - else if (TYPE_RANGED_INTEGERP (int, tem)) - family = XINT (tem); + else if (TYPE_RANGED_FIXNUMP (int, tem)) + family = XFIXNUM (tem); else error ("Unknown address family"); @@ -3983,7 +4006,7 @@ usage: (make-network-process &rest ARGS) */) CHECK_STRING (service); if (sizeof address_un.sun_path <= SBYTES (service)) error ("Service name too long"); - addrinfos = list1 (Fcons (make_number (any_protocol), service)); + addrinfos = list1 (Fcons (make_fixnum (any_protocol), service)); goto open_socket; } #endif @@ -4001,6 +4024,8 @@ usage: (make-network-process &rest ARGS) */) if (!NILP (host)) { + ptrdiff_t portstringlen ATTRIBUTE_UNUSED; + /* SERVICE can either be a string or int. Convert to a C string for later use by getaddrinfo. */ if (EQ (service, Qt)) @@ -4008,10 +4033,10 @@ usage: (make-network-process &rest ARGS) */) portstring = "0"; portstringlen = 1; } - else if (INTEGERP (service)) + else if (FIXNUMP (service)) { portstring = portbuf; - portstringlen = sprintf (portbuf, "%"pI"d", XINT (service)); + portstringlen = sprintf (portbuf, "%"pI"d", XFIXNUM (service)); } else { @@ -4019,37 +4044,38 @@ usage: (make-network-process &rest ARGS) */) portstring = SSDATA (service); portstringlen = SBYTES (service); } - } #ifdef HAVE_GETADDRINFO_A - if (!NILP (host) && nowait) - { - 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) - error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret); - - goto open_socket; - } + if (nowait) + { + 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) + error ("%s/%s getaddrinfo_a error %d", + SSDATA (host), portstring, ret); + + goto open_socket; + } #endif /* HAVE_GETADDRINFO_A */ + } /* If we have a host, use getaddrinfo to resolve both host and service. Otherwise, use getservbyname to lookup the service. */ @@ -4095,8 +4121,8 @@ usage: (make-network-process &rest ARGS) */) if (EQ (service, Qt)) port = 0; - else if (INTEGERP (service)) - port = XINT (service); + else if (FIXNUMP (service)) + port = XFIXNUM (service); else { CHECK_STRING (service); @@ -4169,8 +4195,8 @@ usage: (make-network-process &rest ARGS) */) /* :server QLEN */ p->is_server = !NILP (server); - if (TYPE_RANGED_INTEGERP (int, server)) - p->backlog = XINT (server); + if (TYPE_RANGED_FIXNUMP (int, server)) + p->backlog = XFIXNUM (server); /* :nowait BOOL */ if (!p->is_server && socktype != SOCK_DGRAM && nowait) @@ -4348,7 +4374,7 @@ network_interface_info (Lisp_Object ifname) Lisp_Object res = Qnil; Lisp_Object elt; int s; - bool any = 0; + bool any = false; ptrdiff_t count; #if (! (defined SIOCGIFHWADDR && defined HAVE_STRUCT_IFREQ_IFR_HWADDR) \ && defined HAVE_GETIFADDRS && defined LLADDR) @@ -4381,7 +4407,7 @@ network_interface_info (Lisp_Object ifname) if (flags < 0 && sizeof (rq.ifr_flags) < sizeof (flags)) flags = (unsigned short) rq.ifr_flags; - any = 1; + any = true; for (fp = ifflag_table; flags != 0 && fp->flag_sym; fp++) { if (flags & fp->flag_bit) @@ -4394,7 +4420,7 @@ network_interface_info (Lisp_Object ifname) { if (flags & 1) { - elt = Fcons (make_number (fnum), elt); + elt = Fcons (make_fixnum (fnum), elt); } } } @@ -4405,25 +4431,23 @@ network_interface_info (Lisp_Object ifname) #if defined (SIOCGIFHWADDR) && defined (HAVE_STRUCT_IFREQ_IFR_HWADDR) if (ioctl (s, SIOCGIFHWADDR, &rq) == 0) { - Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil); - register struct Lisp_Vector *p = XVECTOR (hwaddr); - int n; + Lisp_Object hwaddr = make_uninit_vector (6); + struct Lisp_Vector *p = XVECTOR (hwaddr); - any = 1; - for (n = 0; n < 6; n++) - p->contents[n] = make_number (((unsigned char *) + any = true; + for (int n = 0; n < 6; n++) + p->contents[n] = make_fixnum (((unsigned char *) &rq.ifr_hwaddr.sa_data[0]) [n]); - elt = Fcons (make_number (rq.ifr_hwaddr.sa_family), hwaddr); + elt = Fcons (make_fixnum (rq.ifr_hwaddr.sa_family), hwaddr); } #elif defined (HAVE_GETIFADDRS) && defined (LLADDR) if (getifaddrs (&ifap) != -1) { - Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil); - register struct Lisp_Vector *p = XVECTOR (hwaddr); - struct ifaddrs *it; + Lisp_Object hwaddr = make_nil_vector (6); + struct Lisp_Vector *p = XVECTOR (hwaddr); - for (it = ifap; it != NULL; it = it->ifa_next) + for (struct ifaddrs *it = ifap; it != NULL; it = it->ifa_next) { DECLARE_POINTER_ALIAS (sdl, struct sockaddr_dl, it->ifa_addr); unsigned char linkaddr[6]; @@ -4436,9 +4460,9 @@ network_interface_info (Lisp_Object ifname) memcpy (linkaddr, LLADDR (sdl), sdl->sdl_alen); for (n = 0; n < 6; n++) - p->contents[n] = make_number (linkaddr[n]); + p->contents[n] = make_fixnum (linkaddr[n]); - elt = Fcons (make_number (it->ifa_addr->sa_family), hwaddr); + elt = Fcons (make_fixnum (it->ifa_addr->sa_family), hwaddr); break; } } @@ -4451,10 +4475,12 @@ network_interface_info (Lisp_Object ifname) res = Fcons (elt, res); elt = Qnil; -#if defined (SIOCGIFNETMASK) && (defined (HAVE_STRUCT_IFREQ_IFR_NETMASK) || defined (HAVE_STRUCT_IFREQ_IFR_ADDR)) +#if (defined SIOCGIFNETMASK \ + && (defined HAVE_STRUCT_IFREQ_IFR_NETMASK \ + || defined HAVE_STRUCT_IFREQ_IFR_ADDR)) if (ioctl (s, SIOCGIFNETMASK, &rq) == 0) { - any = 1; + any = true; #ifdef HAVE_STRUCT_IFREQ_IFR_NETMASK elt = conv_sockaddr_to_lisp (&rq.ifr_netmask, sizeof (rq.ifr_netmask)); #else @@ -4468,8 +4494,8 @@ network_interface_info (Lisp_Object ifname) #if defined (SIOCGIFBRDADDR) && defined (HAVE_STRUCT_IFREQ_IFR_BROADADDR) if (ioctl (s, SIOCGIFBRDADDR, &rq) == 0) { - any = 1; - elt = conv_sockaddr_to_lisp (&rq.ifr_broadaddr, sizeof (rq.ifr_broadaddr)); + any = true; + elt = conv_sockaddr_to_lisp (&rq.ifr_broadaddr, sizeof rq.ifr_broadaddr); } #endif res = Fcons (elt, res); @@ -4478,7 +4504,7 @@ network_interface_info (Lisp_Object ifname) #if defined (SIOCGIFADDR) && defined (HAVE_STRUCT_IFREQ_IFR_ADDR) if (ioctl (s, SIOCGIFADDR, &rq) == 0) { - any = 1; + any = true; elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr)); } #endif @@ -4609,7 +4635,7 @@ corresponding connection was closed. */) /* Can't wait for a process that is dedicated to a different thread. */ - if (!EQ (proc->thread, Qnil) && !EQ (proc->thread, Fcurrent_thread ())) + if (!NILP (proc->thread) && !EQ (proc->thread, Fcurrent_thread ())) { Lisp_Object proc_thread_name = XTHREAD (proc->thread)->name; @@ -4625,13 +4651,13 @@ corresponding connection was closed. */) if (!NILP (millisec)) { /* Obsolete calling convention using integers rather than floats. */ - CHECK_NUMBER (millisec); + CHECK_FIXNUM (millisec); if (NILP (seconds)) - seconds = make_float (XINT (millisec) / 1000.0); + seconds = make_float (XFIXNUM (millisec) / 1000.0); else { - CHECK_NUMBER (seconds); - seconds = make_float (XINT (millisec) / 1000.0 + XINT (seconds)); + CHECK_FIXNUM (seconds); + seconds = make_float (XFIXNUM (millisec) / 1000.0 + XFIXNUM (seconds)); } } @@ -4640,11 +4666,11 @@ corresponding connection was closed. */) if (!NILP (seconds)) { - if (INTEGERP (seconds)) + if (FIXNUMP (seconds)) { - if (XINT (seconds) > 0) + if (XFIXNUM (seconds) > 0) { - secs = XINT (seconds); + secs = XFIXNUM (seconds); nsecs = 0; } } @@ -4668,7 +4694,7 @@ corresponding connection was closed. */) Qnil, !NILP (process) ? XPROCESS (process) : NULL, (NILP (just_this_one) ? 0 - : !INTEGERP (just_this_one) ? 1 : -1)) + : !FIXNUMP (just_this_one) ? 1 : -1)) <= 0) ? Qnil : Qt); } @@ -4685,16 +4711,7 @@ server_accept_connection (Lisp_Object server, int channel) struct Lisp_Process *ps = XPROCESS (server); struct Lisp_Process *p; int s; - union u_sockaddr { - struct sockaddr sa; - struct sockaddr_in in; -#ifdef AF_INET6 - struct sockaddr_in6 in6; -#endif -#ifdef HAVE_LOCAL_SOCKETS - struct sockaddr_un un; -#endif - } saddr; + union u_sockaddr saddr; socklen_t len = sizeof saddr; ptrdiff_t count; @@ -4706,7 +4723,7 @@ server_accept_connection (Lisp_Object server, int channel) if (!would_block (code) && !NILP (ps->log)) call3 (ps->log, server, Qnil, concat3 (build_string ("accept failed with code"), - Fnumber_to_string (make_number (code)), + Fnumber_to_string (make_fixnum (code)), build_string ("\n"))); return; } @@ -4734,9 +4751,9 @@ server_accept_connection (Lisp_Object server, int channel) args[nargs++] = procname_format_in; nargs++; unsigned char *ip = (unsigned char *)&saddr.in.sin_addr.s_addr; - service = make_number (ntohs (saddr.in.sin_port)); + service = make_fixnum (ntohs (saddr.in.sin_port)); for (int i = 0; i < 4; i++) - args[nargs++] = make_number (ip[i]); + args[nargs++] = make_fixnum (ip[i]); args[nargs++] = service; } break; @@ -4747,9 +4764,9 @@ server_accept_connection (Lisp_Object server, int channel) args[nargs++] = procname_format_in6; nargs++; DECLARE_POINTER_ALIAS (ip6, uint16_t, &saddr.in6.sin6_addr); - service = make_number (ntohs (saddr.in.sin_port)); + service = make_fixnum (ntohs (saddr.in.sin_port)); for (int i = 0; i < 8; i++) - args[nargs++] = make_number (ip6[i]); + args[nargs++] = make_fixnum (ip6[i]); args[nargs++] = service; } break; @@ -4758,7 +4775,7 @@ server_accept_connection (Lisp_Object server, int channel) default: args[nargs++] = procname_format_default; nargs++; - args[nargs++] = make_number (connect_counter); + args[nargs++] = make_fixnum (connect_counter); break; } @@ -5013,7 +5030,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, Lisp_Object proc; struct timespec timeout, end_time, timer_delay; struct timespec got_output_end_time = invalid_timespec (); - enum { MINIMUM = -1, TIMEOUT, INFINITY } wait; + enum { MINIMUM = -1, TIMEOUT, FOREVER } wait; int got_some_output = -1; uintmax_t prev_wait_proc_nbytes_read = wait_proc ? wait_proc->nbytes_read : 0; #if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS @@ -5025,7 +5042,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, struct timespec now = invalid_timespec (); eassert (wait_proc == NULL - || EQ (wait_proc->thread, Qnil) + || NILP (wait_proc->thread) || XTHREAD (wait_proc->thread) == current_thread); FD_ZERO (&Available); @@ -5052,7 +5069,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, end_time = timespec_add (now, make_timespec (time_limit, nsecs)); } else - wait = INFINITY; + wait = FOREVER; while (1) { @@ -5477,7 +5494,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, have waited a long amount of time due to repeated timers. */ struct timespec huge_timespec - = make_timespec (TYPE_MAXIMUM (time_t), 2 * TIMESPEC_RESOLUTION); + = make_timespec (TYPE_MAXIMUM (time_t), 2 * TIMESPEC_HZ); struct timespec cmp_time = huge_timespec; if (wait < TIMEOUT || (wait_proc @@ -5642,16 +5659,6 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else if (nread == -1 && would_block (errno)) ; -#ifdef WINDOWSNT - /* FIXME: Is this special case still needed? */ - /* Note that we cannot distinguish between no input - available now and a closed pipe. - With luck, a closed pipe will be accompanied by - subprocess termination and SIGCHLD. */ - else if (nread == 0 && !NETCONN_P (proc) && !SERIALCONN_P (proc) - && !PIPECONN_P (proc)) - ; -#endif #ifdef HAVE_PTYS /* On some OSs with ptys, when the process on one end of a pty exits, the other end gets an error reading with @@ -5690,7 +5697,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, deactivate_process (proc); if (EQ (XPROCESS (proc)->status, Qrun)) pset_status (XPROCESS (proc), - list2 (Qexit, make_number (0))); + list2 (Qexit, make_fixnum (0))); } else { @@ -5701,7 +5708,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, update_status (XPROCESS (proc)); if (EQ (XPROCESS (proc)->status, Qrun)) pset_status (XPROCESS (proc), - list2 (Qexit, make_number (256))); + list2 (Qexit, make_fixnum (256))); } } if (FD_ISSET (channel, &Writeok) @@ -5753,7 +5760,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, else { p->tick = ++process_tick; - pset_status (p, list2 (Qfailed, make_number (xerrno))); + pset_status (p, list2 (Qfailed, make_fixnum (xerrno))); } deactivate_process (proc); if (!NILP (addrinfos)) @@ -5822,7 +5829,7 @@ read_process_output_error_handler (Lisp_Object error_val) cmd_error_internal (error_val, "error in process filter: "); Vinhibit_quit = Qt; update_echo_area (); - Fsleep_for (make_number (2), Qnil); + Fsleep_for (make_fixnum (2), Qnil); return Qt; } @@ -6140,7 +6147,7 @@ Otherwise it discards the output. */) /* If the restriction isn't what it should be, set it. */ if (old_begv != BEGV || old_zv != ZV) - Fnarrow_to_region (make_number (old_begv), make_number (old_zv)); + Fnarrow_to_region (make_fixnum (old_begv), make_fixnum (old_zv)); bset_read_only (current_buffer, old_read_only); SET_PT_BOTH (opoint, opoint_byte); @@ -6187,7 +6194,7 @@ write_queue_push (struct Lisp_Process *p, Lisp_Object input_obj, obj = make_unibyte_string (buf, len); } - entry = Fcons (obj, Fcons (make_number (offset), make_number (len))); + entry = Fcons (obj, Fcons (make_fixnum (offset), make_fixnum (len))); if (front) pset_write_queue (p, Fcons (entry, p->write_queue)); @@ -6215,8 +6222,8 @@ write_queue_pop (struct Lisp_Process *p, Lisp_Object *obj, *obj = XCAR (entry); offset_length = XCDR (entry); - *len = XINT (XCDR (offset_length)); - offset = XINT (XCAR (offset_length)); + *len = XFIXNUM (XCDR (offset_length)); + offset = XFIXNUM (XCAR (offset_length)); *buf = SSDATA (*obj) + offset; return 1; @@ -6424,7 +6431,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, } #endif /* BROKEN_PTY_READ_AFTER_EAGAIN */ - /* Put what we should have written in wait_queue. */ + /* Put what we should have written in write_queue. */ write_queue_push (p, cur_object, cur_buf, cur_len, 1); wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0); @@ -6434,7 +6441,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, else if (errno == EPIPE) { p->raw_status_new = 0; - pset_status (p, list2 (Qexit, make_number (256))); + pset_status (p, list2 (Qexit, make_fixnum (256))); p->tick = ++process_tick; deactivate_process (proc); error ("process %s no longer connected to pipe; closed it", @@ -6472,11 +6479,11 @@ set up yet, this function will block until socket setup has completed. */) validate_region (&start, &end); - start_byte = CHAR_TO_BYTE (XINT (start)); - end_byte = CHAR_TO_BYTE (XINT (end)); + start_byte = CHAR_TO_BYTE (XFIXNUM (start)); + end_byte = CHAR_TO_BYTE (XFIXNUM (end)); - if (XINT (start) < GPT && XINT (end) > GPT) - move_gap_both (XINT (start), start_byte); + if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) + move_gap_both (XFIXNUM (start), start_byte); if (NETCONN_P (proc)) wait_while_connecting (proc); @@ -6559,7 +6566,7 @@ process group. */) if (gid == p->pid) return Qnil; if (gid != -1) - return make_number (gid); + return make_fixnum (gid); return Qt; } @@ -6865,10 +6872,10 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) Lisp_Object tem = Fget_process (process); if (NILP (tem)) { - Lisp_Object process_number - = string_to_number (SSDATA (process), 10, 1); - if (NUMBERP (process_number)) - tem = process_number; + ptrdiff_t len; + tem = string_to_number (SSDATA (process), 10, &len); + if (NILP (tem) || len != SBYTES (process)) + return Qnil; } process = tem; } @@ -6888,10 +6895,10 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) error ("Cannot signal process %s", SDATA (XPROCESS (process)->name)); } - if (INTEGERP (sigcode)) + if (FIXNUMP (sigcode)) { CHECK_TYPE_RANGED_INTEGER (int, sigcode); - signo = XINT (sigcode); + signo = XFIXNUM (sigcode); } else { @@ -6905,7 +6912,7 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) error ("Undefined signal name %s", name); } - return make_number (kill (pid, signo)); + return make_fixnum (kill (pid, signo)); } DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0, @@ -7075,13 +7082,11 @@ handle_child_signal (int sig) if (! CONSP (head)) continue; xpid = XCAR (head); - if (all_pids_are_fixnums ? INTEGERP (xpid) : NUMBERP (xpid)) + if (all_pids_are_fixnums ? FIXNUMP (xpid) : INTEGERP (xpid)) { - pid_t deleted_pid; - if (INTEGERP (xpid)) - deleted_pid = XINT (xpid); - else - deleted_pid = XFLOAT_DATA (xpid); + intmax_t deleted_pid; + bool ok = integer_to_intmax (xpid, &deleted_pid); + eassert (ok); if (child_status_changed (deleted_pid, 0, 0)) { if (STRINGP (XCDR (head))) @@ -7145,7 +7150,7 @@ exec_sentinel_error_handler (Lisp_Object error_val) cmd_error_internal (error_val, "error in process sentinel: "); Vinhibit_quit = Qt; update_echo_area (); - Fsleep_for (make_number (2), Qnil); + Fsleep_for (make_fixnum (2), Qnil); return Qt; } @@ -7540,7 +7545,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, { register int nfds; struct timespec end_time, timeout; - enum { MINIMUM = -1, TIMEOUT, INFINITY } wait; + enum { MINIMUM = -1, TIMEOUT, FOREVER } wait; if (TYPE_MAXIMUM (time_t) < time_limit) time_limit = TYPE_MAXIMUM (time_t); @@ -7554,7 +7559,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, make_timespec (time_limit, nsecs)); } else - wait = INFINITY; + wait = FOREVER; /* Turn off periodic alarms (in case they are in use) and then turn off any other atimers, @@ -7660,7 +7665,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, /* If we woke up due to SIGWINCH, actually change size now. */ do_pending_window_change (0); - if (wait < INFINITY && nfds == 0 && ! timeout_reduced_for_timers) + if (wait < FOREVER && nfds == 0 && ! timeout_reduced_for_timers) /* We waited the full specified time, so return now. */ break; @@ -7953,8 +7958,7 @@ integer or floating point values. majflt -- number of major page faults (number) cminflt -- cumulative number of minor page faults (number) cmajflt -- cumulative number of major page faults (number) - utime -- user time used by the process, in (current-time) format, - which is a list of integers (HIGH LOW USEC PSEC) + utime -- user time used by the process, in `current-time' format stime -- system time used by the process (current-time) time -- sum of utime and stime (current-time) cutime -- user time used by the process and its children (current-time) @@ -7966,7 +7970,7 @@ integer or floating point values. start -- time the process started (current-time) vsize -- virtual memory size of the process in KB's (number) rss -- resident set size of the process in KB's (number) - etime -- elapsed time the process is running, in (HIGH LOW USEC PSEC) format + etime -- elapsed time the process is running (current-time) pcpu -- percents of CPU time used by the process (floating-point number) pmem -- percents of total physical memory used by process's resident set (floating-point number) @@ -8052,6 +8056,18 @@ init_process_emacs (int sockfd) #endif external_sock_fd = sockfd; + Lisp_Object sockname = Qnil; +# if HAVE_GETSOCKNAME + if (0 <= sockfd) + { + union u_sockaddr sa; + socklen_t salen = sizeof sa; + if (getsockname (sockfd, &sa.sa, &salen) == 0) + sockname = conv_sockaddr_to_lisp (&sa.sa, salen); + } +# endif + Vinternal__daemon_sockname = sockname; + max_desc = -1; memset (fd_callback_info, 0, sizeof (fd_callback_info)); @@ -8100,6 +8116,8 @@ init_process_emacs (int sockfd) void syms_of_process (void) { + DEFSYM (Qmake_process, "make-process"); + #ifdef subprocesses DEFSYM (Qprocessp, "processp"); @@ -8140,6 +8158,7 @@ syms_of_process (void) DEFSYM (Qreal, "real"); DEFSYM (Qnetwork, "network"); DEFSYM (Qserial, "serial"); + DEFSYM (QCfile_handler, ":file-handler"); DEFSYM (QCbuffer, ":buffer"); DEFSYM (QChost, ":host"); DEFSYM (QCservice, ":service"); @@ -8244,6 +8263,10 @@ These functions are called in the order of the list, until one of them returns non-`nil'. */); Vinterrupt_process_functions = list1 (Qinternal_default_interrupt_process); + DEFVAR_LISP ("internal--daemon-sockname", Vinternal__daemon_sockname, + doc: /* Name of external socket passed to Emacs, or nil if none. */); + Vinternal__daemon_sockname = Qnil; + DEFSYM (Qinternal_default_interrupt_process, "internal-default-interrupt-process"); DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions"); diff --git a/src/process.h b/src/process.h index 3d0f5f6fc58..d66aa062a54 100644 --- a/src/process.h +++ b/src/process.h @@ -194,7 +194,8 @@ struct Lisp_Process gnutls_session_t gnutls_state; gnutls_certificate_client_credentials gnutls_x509_cred; gnutls_anon_client_credentials_t gnutls_anon_cred; - gnutls_x509_crt_t gnutls_certificate; + gnutls_x509_crt_t *gnutls_certificates; + int gnutls_certificates_length; unsigned int gnutls_peer_verification; unsigned int gnutls_extra_peer_verification; int gnutls_log_level; @@ -202,7 +203,7 @@ struct Lisp_Process bool_bf gnutls_p : 1; bool_bf gnutls_complete_negotiation_p : 1; #endif -}; + } GCALIGNED_STRUCT; INLINE bool PROCESSP (Lisp_Object a) @@ -220,7 +221,7 @@ INLINE struct Lisp_Process * XPROCESS (Lisp_Object a) { eassert (PROCESSP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Process); } /* Every field in the preceding structure except for the first two @@ -299,6 +300,7 @@ 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); +extern void dissociate_controlling_tty (void); INLINE_HEADER_END diff --git a/src/profiler.c b/src/profiler.c index 41896257557..ff4143383ce 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -54,8 +54,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth) with the vectors we'll put in them. */ ptrdiff_t i = ASIZE (h->key_and_value) >> 1; while (i > 0) - set_hash_key_slot (h, --i, - Fmake_vector (make_number (max_stack_depth), Qnil)); + set_hash_key_slot (h, --i, make_nil_vector (max_stack_depth)); return log; } @@ -80,12 +79,12 @@ static EMACS_INT approximate_median (log_t *log, { eassert (size > 0); if (size < 2) - return XINT (HASH_VALUE (log, start)); + return XFIXNUM (HASH_VALUE (log, start)); if (size < 3) /* Not an actual median, but better for our application than choosing either of the two numbers. */ - return ((XINT (HASH_VALUE (log, start)) - + XINT (HASH_VALUE (log, start + 1))) + return ((XFIXNUM (HASH_VALUE (log, start)) + + XFIXNUM (HASH_VALUE (log, start + 1))) / 2); else { @@ -110,7 +109,7 @@ static void evict_lower_half (log_t *log) for (i = 0; i < size; i++) /* Evict not only values smaller but also values equal to the median, so as to make sure we evict something no matter what. */ - if (XINT (HASH_VALUE (log, i)) <= median) + if (XFIXNUM (HASH_VALUE (log, i)) <= median) { Lisp_Object key = HASH_KEY (log, i); { /* FIXME: we could make this more efficient. */ @@ -156,15 +155,15 @@ record_backtrace (log_t *log, EMACS_INT count) ptrdiff_t j = hash_lookup (log, backtrace, &hash); if (j >= 0) { - EMACS_INT old_val = XINT (HASH_VALUE (log, j)); + EMACS_INT old_val = XFIXNUM (HASH_VALUE (log, j)); EMACS_INT new_val = saturated_add (old_val, count); - set_hash_value_slot (log, j, make_number (new_val)); + set_hash_value_slot (log, j, make_fixnum (new_val)); } else { /* BEWARE! hash_put in general can allocate memory. But currently it only does that if log->next_free is -1. */ eassert (0 <= log->next_free); - ptrdiff_t j = hash_put (log, backtrace, make_number (count), hash); + ptrdiff_t j = hash_put (log, backtrace, make_fixnum (count), hash); /* Let's make sure we've put `backtrace' right where it already was to start with. */ eassert (index == j); @@ -266,14 +265,14 @@ setup_cpu_timer (Lisp_Object sampling_interval) struct timespec interval; int billion = 1000000000; - if (! RANGED_INTEGERP (1, sampling_interval, + if (! RANGED_FIXNUMP (1, sampling_interval, (TYPE_MAXIMUM (time_t) < EMACS_INT_MAX / billion ? ((EMACS_INT) TYPE_MAXIMUM (time_t) * billion + (billion - 1)) : EMACS_INT_MAX))) return -1; - current_sampling_interval = XINT (sampling_interval); + current_sampling_interval = XFIXNUM (sampling_interval); interval = make_timespec (current_sampling_interval / billion, current_sampling_interval % billion); emacs_sigaction_init (&action, deliver_profiler_signal); @@ -422,8 +421,8 @@ 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), - make_number (cpu_gc_count), + Fputhash (make_vector (1, QAutomatic_GC), + make_fixnum (cpu_gc_count), result); cpu_gc_count = 0; return result; diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h new file mode 100644 index 00000000000..8cbd58d72b0 --- /dev/null +++ b/src/ptr-bounds.h @@ -0,0 +1,79 @@ +/* Pointer bounds checking for GNU Emacs + +Copyright 2017-2018 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 <https://www.gnu.org/licenses/>. */ + +/* Pointer bounds checking is a no-op unless running on hardware + supporting Intel MPX (Intel Skylake or better). Also, it requires + GCC 5 and Linux kernel 3.19, or later. Configure with + CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with + -fchkp-first-field-has-own-bounds thrown in. + + Although pointer bounds checking can help during debugging, it is + disabled by default because it hurts performance significantly. + The checking does not detect all pointer errors. For example, a + dumped Emacs might not detect a bounds violation of a pointer that + was created before Emacs was dumped. */ + +#ifndef PTR_BOUNDS_H +#define PTR_BOUNDS_H + +#include <stddef.h> + +/* When not checking pointer bounds, the following macros simply + return their first argument. These macros return either void *, or + the same type as their first argument. */ + +INLINE_HEADER_BEGIN + +/* Return a copy of P, with bounds narrowed to [P, P + N). */ +#ifdef __CHKP__ +INLINE void * +ptr_bounds_clip (void const *p, size_t n) +{ + return __builtin___bnd_narrow_ptr_bounds (p, p, n); +} +#else +# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p) +#endif + +/* Return a copy of P, but with the bounds of Q. */ +#ifdef __CHKP__ +# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q) +#else +# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p) +#endif + +/* Return a copy of P, but with infinite bounds. + This is a loophole in pointer bounds checking. */ +#ifdef __CHKP__ +# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p) +#else +# define ptr_bounds_init(p) (p) +#endif + +/* Return a copy of P, but with bounds [P, P + N). + This is a loophole in pointer bounds checking. */ +#ifdef __CHKP__ +# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n) +#else +# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p) +#endif + +INLINE_HEADER_END + +#endif /* PTR_BOUNDS_H */ diff --git a/src/puresize.h b/src/puresize.h index f96b2c8d7f0..f120a4b3307 100644 --- a/src/puresize.h +++ b/src/puresize.h @@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN #endif #ifndef BASE_PURESIZE -#define BASE_PURESIZE (1900000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA) +#define BASE_PURESIZE (2000000 + 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 c8db91f2b8f..66ea2ec4119 100644 --- a/src/ralloc.c +++ b/src/ralloc.c @@ -26,11 +26,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <stddef.h> -#ifdef emacs -# include "lisp.h" -# include "blockinput.h" -# include <unistd.h> -#endif +#include "lisp.h" +#include "blockinput.h" +#include <unistd.h> #include "getpagesize.h" @@ -924,9 +922,7 @@ r_alloc_free (void **ptr) free_bloc (dead_bloc); *ptr = 0; -#ifdef emacs refill_memory_reserve (); -#endif } /* Given a pointer at address PTR to relocatable data, resize it to SIZE. @@ -1000,7 +996,7 @@ r_re_alloc (void **ptr, size_t size) } -#if defined (emacs) && defined (DOUG_LEA_MALLOC) +#ifdef DOUG_LEA_MALLOC /* Reinitialize the morecore hook variables after restarting a dumped Emacs. This is needed when using Doug Lea's malloc from GNU libc. */ diff --git a/src/regex.c b/src/regex-emacs.c index 09ed64a6e13..b667a43a37f 100644 --- a/src/regex.c +++ b/src/regex-emacs.c @@ -1,6 +1,4 @@ -/* Extended regular expression matching and search library, version - 0.12. (Implements POSIX draft P1003.2/D11.2, except for some of the - internationalization features.) +/* Emacs regular expression matching and search Copyright (C) 1993-2019 Free Software Foundation, Inc. @@ -19,165 +17,64 @@ /* TODO: - structure the opcode space into opcode+flag. - - merge with glibc's regex.[ch]. - replace (succeed_n + jump_n + set_number_at) with something that doesn't - need to modify the compiled regexp so that re_match can be reentrant. + need to modify the compiled regexp so that re_search can be reentrant. - get rid of on_failure_jump_smart by doing the optimization in re_comp - rather than at run-time, so that re_match can be reentrant. + rather than at run-time, so that re_search can be reentrant. */ -/* AIX requires this to be the first thing in the file. */ -#if defined _AIX && !defined REGEX_MALLOC - #pragma alloca -#endif - -/* Ignore some GCC warnings for now. This section should go away - once the Emacs and Gnulib regex code is merged. */ -#if 4 < __GNUC__ + (5 <= __GNUC_MINOR__) || defined __clang__ -# pragma GCC diagnostic ignored "-Wstrict-overflow" -# ifndef emacs -# pragma GCC diagnostic ignored "-Wunused-function" -# pragma GCC diagnostic ignored "-Wunused-macros" -# pragma GCC diagnostic ignored "-Wunused-result" -# pragma GCC diagnostic ignored "-Wunused-variable" -# endif -#endif - -#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) && ! defined __clang__ -# pragma GCC diagnostic ignored "-Wunused-but-set-variable" -#endif - #include <config.h> -#include <stddef.h> -#include <stdlib.h> - -#ifdef emacs -/* We need this for `regex.h', and perhaps for the Emacs include files. */ -# include <sys/types.h> -#endif - -/* Whether to use ISO C Amendment 1 wide char functions. - Those should not be used for Emacs since it uses its own. */ -#if defined _LIBC -#define WIDE_CHAR_SUPPORT 1 -#else -#define WIDE_CHAR_SUPPORT \ - (HAVE_WCTYPE_H && HAVE_WCHAR_H && HAVE_BTOWC && !emacs) -#endif +#include "regex-emacs.h" -/* For platform which support the ISO C amendment 1 functionality we - support user defined character classes. */ -#if WIDE_CHAR_SUPPORT -/* Solaris 2.5 has a bug: <wchar.h> must be included before <wctype.h>. */ -# include <wchar.h> -# include <wctype.h> -#endif - -#ifdef _LIBC -/* We have to keep the namespace clean. */ -# define regfree(preg) __regfree (preg) -# define regexec(pr, st, nm, pm, ef) __regexec (pr, st, nm, pm, ef) -# define regcomp(preg, pattern, cflags) __regcomp (preg, pattern, cflags) -# define regerror(err_code, preg, errbuf, errbuf_size) \ - __regerror (err_code, preg, errbuf, errbuf_size) -# define re_set_registers(bu, re, nu, st, en) \ - __re_set_registers (bu, re, nu, st, en) -# define re_match_2(bufp, string1, size1, string2, size2, pos, regs, stop) \ - __re_match_2 (bufp, string1, size1, string2, size2, pos, regs, stop) -# define re_match(bufp, string, size, pos, regs) \ - __re_match (bufp, string, size, pos, regs) -# define re_search(bufp, string, size, startpos, range, regs) \ - __re_search (bufp, string, size, startpos, range, regs) -# define re_compile_pattern(pattern, length, bufp) \ - __re_compile_pattern (pattern, length, bufp) -# define re_set_syntax(syntax) __re_set_syntax (syntax) -# define re_search_2(bufp, st1, s1, st2, s2, startpos, range, regs, stop) \ - __re_search_2 (bufp, st1, s1, st2, s2, startpos, range, regs, stop) -# define re_compile_fastmap(bufp) __re_compile_fastmap (bufp) - -/* Make sure we call libc's function even if the user overrides them. */ -# define btowc __btowc -# define iswctype __iswctype -# define wctype __wctype - -# define WEAK_ALIAS(a,b) weak_alias (a, b) - -/* We are also using some library internals. */ -# include <locale/localeinfo.h> -# include <locale/elem-hash.h> -# include <langinfo.h> -#else -# define WEAK_ALIAS(a,b) -#endif - -/* This is for other GNU distributions with internationalized messages. */ -#if HAVE_LIBINTL_H || defined _LIBC -# include <libintl.h> -#else -# define gettext(msgid) (msgid) -#endif +#include <stdlib.h> -#ifndef gettext_noop -/* This define is so xgettext can find the internationalizable - strings. */ -# define gettext_noop(String) String +#include "character.h" +#include "buffer.h" +#include "syntax.h" +#include "category.h" + +/* Maximum number of duplicates an interval can allow. Some systems + define this in other header files, but we want our value, so remove + any previous define. Repeat counts are stored in opcodes as 2-byte + unsigned integers. */ +#ifdef RE_DUP_MAX +# undef RE_DUP_MAX #endif - -/* The `emacs' switch turns on certain matching commands - that make sense only in Emacs. */ -#ifdef emacs - -# include "lisp.h" -# include "character.h" -# include "buffer.h" - -# include "syntax.h" -# include "category.h" +#define RE_DUP_MAX (0xffff) /* Make syntax table lookup grant data in gl_state. */ -# define SYNTAX(c) syntax_property (c, 1) - -# ifdef malloc -# undef malloc -# endif -# define malloc xmalloc -# ifdef realloc -# undef realloc -# endif -# define realloc xrealloc -# ifdef free -# undef free -# endif -# define free xfree - -/* Converts the pointer to the char to BEG-based offset from the start. */ -# define PTR_TO_OFFSET(d) POS_AS_IN_BUFFER (POINTER_TO_OFFSET (d)) -/* Strings are 0-indexed, buffers are 1-indexed; we pun on the boolean +#define SYNTAX(c) syntax_property (c, 1) + +/* Convert the pointer to the char to BEG-based offset from the start. */ +#define PTR_TO_OFFSET(d) POS_AS_IN_BUFFER (POINTER_TO_OFFSET (d)) +/* Strings are 0-indexed, buffers are 1-indexed; pun on the boolean result to get the right base index. */ -# define POS_AS_IN_BUFFER(p) ((p) + (NILP (re_match_object) || BUFFERP (re_match_object))) +#define POS_AS_IN_BUFFER(p) \ + ((p) + (NILP (gl_state.object) || BUFFERP (gl_state.object))) -# define RE_MULTIBYTE_P(bufp) ((bufp)->multibyte) -# define RE_TARGET_MULTIBYTE_P(bufp) ((bufp)->target_multibyte) -# define RE_STRING_CHAR(p, multibyte) \ - (multibyte ? (STRING_CHAR (p)) : (*(p))) -# define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) \ - (multibyte ? (STRING_CHAR_AND_LENGTH (p, len)) : ((len) = 1, *(p))) +#define RE_MULTIBYTE_P(bufp) ((bufp)->multibyte) +#define RE_TARGET_MULTIBYTE_P(bufp) ((bufp)->target_multibyte) +#define RE_STRING_CHAR(p, multibyte) \ + (multibyte ? STRING_CHAR (p) : *(p)) +#define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) \ + (multibyte ? STRING_CHAR_AND_LENGTH (p, len) : ((len) = 1, *(p))) -# define RE_CHAR_TO_MULTIBYTE(c) UNIBYTE_TO_CHAR (c) +#define RE_CHAR_TO_MULTIBYTE(c) UNIBYTE_TO_CHAR (c) -# define RE_CHAR_TO_UNIBYTE(c) CHAR_TO_BYTE_SAFE (c) +#define RE_CHAR_TO_UNIBYTE(c) CHAR_TO_BYTE_SAFE (c) /* Set C a (possibly converted to multibyte) character before P. P points into a string which is the virtual concatenation of STR1 (which ends at END1) or STR2 (which ends at END2). */ -# define GET_CHAR_BEFORE_2(c, p, str1, end1, str2, end2) \ +#define GET_CHAR_BEFORE_2(c, p, str1, end1, str2, end2) \ do { \ if (target_multibyte) \ { \ re_char *dtemp = (p) == (str2) ? (end1) : (p); \ - re_char *dlimit = ((p) > (str2) && (p) <= (end2)) ? (str2) : (str1); \ - while (dtemp-- > dlimit && !CHAR_HEAD_P (*dtemp)); \ + re_char *dlimit = (p) > (str2) && (p) <= (end2) ? (str2) : (str1); \ + while (dtemp-- > dlimit && !CHAR_HEAD_P (*dtemp)) \ + continue; \ c = STRING_CHAR (dtemp); \ } \ else \ @@ -185,11 +82,11 @@ (c = ((p) == (str2) ? (end1) : (p))[-1]); \ (c) = RE_CHAR_TO_MULTIBYTE (c); \ } \ - } while (0) + } while (false) /* Set C a (possibly converted to multibyte) character at P, and set LEN to the byte length of that character. */ -# define GET_CHAR_AFTER(c, p, len) \ +#define GET_CHAR_AFTER(c, p, len) \ do { \ if (target_multibyte) \ (c) = STRING_CHAR_AND_LENGTH (p, len); \ @@ -199,342 +96,108 @@ len = 1; \ (c) = RE_CHAR_TO_MULTIBYTE (c); \ } \ - } while (0) - -#else /* not emacs */ - -/* If we are not linking with Emacs proper, - we can't use the relocating allocator - even if config.h says that we can. */ -# undef REL_ALLOC - -# include <unistd.h> - -/* When used in Emacs's lib-src, we need xmalloc and xrealloc. */ - -static void * -xmalloc (size_t size) -{ - void *val = malloc (size); - if (!val && size) - { - write (STDERR_FILENO, "virtual memory exhausted\n", 25); - exit (1); - } - return val; -} - -static void * -xrealloc (void *block, size_t size) -{ - void *val; - /* We must call malloc explicitly when BLOCK is 0, since some - reallocs don't do this. */ - if (! block) - val = malloc (size); - else - val = realloc (block, size); - if (!val && size) - { - write (STDERR_FILENO, "virtual memory exhausted\n", 25); - exit (1); - } - return val; -} - -# ifdef malloc -# undef malloc -# endif -# define malloc xmalloc -# ifdef realloc -# undef realloc -# endif -# define realloc xrealloc - -# include <stdbool.h> -# include <string.h> - -/* Define the syntax stuff for \<, \>, etc. */ - -/* Sword must be nonzero for the wordchar pattern commands in re_match_2. */ -enum syntaxcode { Swhitespace = 0, Sword = 1, Ssymbol = 2 }; - -/* Dummy macros for non-Emacs environments. */ -# define MAX_MULTIBYTE_LENGTH 1 -# define RE_MULTIBYTE_P(x) 0 -# define RE_TARGET_MULTIBYTE_P(x) 0 -# define WORD_BOUNDARY_P(c1, c2) (0) -# define BYTES_BY_CHAR_HEAD(p) (1) -# define PREV_CHAR_BOUNDARY(p, limit) ((p)--) -# define STRING_CHAR(p) (*(p)) -# define RE_STRING_CHAR(p, multibyte) STRING_CHAR (p) -# define CHAR_STRING(c, s) (*(s) = (c), 1) -# define STRING_CHAR_AND_LENGTH(p, actual_len) ((actual_len) = 1, *(p)) -# define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) STRING_CHAR_AND_LENGTH (p, len) -# define RE_CHAR_TO_MULTIBYTE(c) (c) -# define RE_CHAR_TO_UNIBYTE(c) (c) -# define GET_CHAR_BEFORE_2(c, p, str1, end1, str2, end2) \ - (c = ((p) == (str2) ? *((end1) - 1) : *((p) - 1))) -# define GET_CHAR_AFTER(c, p, len) \ - (c = *p, len = 1) -# define CHAR_BYTE8_P(c) (0) -# define CHAR_LEADING_CODE(c) (c) - -#endif /* not emacs */ - -#ifndef RE_TRANSLATE -# define RE_TRANSLATE(TBL, C) ((unsigned char)(TBL)[C]) -# define RE_TRANSLATE_P(TBL) (TBL) -#endif + } while (false) -/* Get the interface, including the syntax bits. */ -#include "regex.h" - -/* isalpha etc. are used for the character classes. */ -#include <ctype.h> - -#ifdef emacs - /* 1 if C is an ASCII character. */ -# define IS_REAL_ASCII(c) ((c) < 0200) +#define IS_REAL_ASCII(c) ((c) < 0200) /* 1 if C is a unibyte character. */ -# define ISUNIBYTE(c) (SINGLE_BYTE_CHAR_P ((c))) +#define ISUNIBYTE(c) (SINGLE_BYTE_CHAR_P ((c))) /* The Emacs definitions should not be directly affected by locales. */ /* In Emacs, these are only used for single-byte characters. */ -# define ISDIGIT(c) ((c) >= '0' && (c) <= '9') -# define ISCNTRL(c) ((c) < ' ') -# define ISXDIGIT(c) (0 <= char_hexdigit (c)) +#define ISDIGIT(c) ((c) >= '0' && (c) <= '9') +#define ISCNTRL(c) ((c) < ' ') +#define ISXDIGIT(c) (0 <= char_hexdigit (c)) /* The rest must handle multibyte characters. */ -# define ISBLANK(c) (IS_REAL_ASCII (c) \ +#define ISBLANK(c) (IS_REAL_ASCII (c) \ ? ((c) == ' ' || (c) == '\t') \ : blankp (c)) -# define ISGRAPH(c) (SINGLE_BYTE_CHAR_P (c) \ +#define ISGRAPH(c) (SINGLE_BYTE_CHAR_P (c) \ ? (c) > ' ' && !((c) >= 0177 && (c) <= 0240) \ : graphicp (c)) -# define ISPRINT(c) (SINGLE_BYTE_CHAR_P (c) \ +#define ISPRINT(c) (SINGLE_BYTE_CHAR_P (c) \ ? (c) >= ' ' && !((c) >= 0177 && (c) <= 0237) \ : printablep (c)) -# define ISALNUM(c) (IS_REAL_ASCII (c) \ +#define ISALNUM(c) (IS_REAL_ASCII (c) \ ? (((c) >= 'a' && (c) <= 'z') \ || ((c) >= 'A' && (c) <= 'Z') \ || ((c) >= '0' && (c) <= '9')) \ : alphanumericp (c)) -# define ISALPHA(c) (IS_REAL_ASCII (c) \ +#define ISALPHA(c) (IS_REAL_ASCII (c) \ ? (((c) >= 'a' && (c) <= 'z') \ || ((c) >= 'A' && (c) <= 'Z')) \ : alphabeticp (c)) -# define ISLOWER(c) lowercasep (c) +#define ISLOWER(c) lowercasep (c) -# define ISPUNCT(c) (IS_REAL_ASCII (c) \ +#define ISPUNCT(c) (IS_REAL_ASCII (c) \ ? ((c) > ' ' && (c) < 0177 \ && !(((c) >= 'a' && (c) <= 'z') \ || ((c) >= 'A' && (c) <= 'Z') \ || ((c) >= '0' && (c) <= '9'))) \ : SYNTAX (c) != Sword) -# define ISSPACE(c) (SYNTAX (c) == Swhitespace) - -# define ISUPPER(c) uppercasep (c) - -# define ISWORD(c) (SYNTAX (c) == Sword) - -#else /* not emacs */ - -/* 1 if C is an ASCII character. */ -# define IS_REAL_ASCII(c) ((c) < 0200) - -/* This distinction is not meaningful, except in Emacs. */ -# define ISUNIBYTE(c) 1 - -# ifdef isblank -# define ISBLANK(c) isblank (c) -# else -# define ISBLANK(c) ((c) == ' ' || (c) == '\t') -# endif -# ifdef isgraph -# define ISGRAPH(c) isgraph (c) -# else -# define ISGRAPH(c) (isprint (c) && !isspace (c)) -# endif - -/* Solaris defines ISPRINT so we must undefine it first. */ -# undef ISPRINT -# define ISPRINT(c) isprint (c) -# define ISDIGIT(c) isdigit (c) -# define ISALNUM(c) isalnum (c) -# define ISALPHA(c) isalpha (c) -# define ISCNTRL(c) iscntrl (c) -# define ISLOWER(c) islower (c) -# define ISPUNCT(c) ispunct (c) -# define ISSPACE(c) isspace (c) -# define ISUPPER(c) isupper (c) -# define ISXDIGIT(c) isxdigit (c) - -# define ISWORD(c) ISALPHA (c) - -# ifdef _tolower -# define TOLOWER(c) _tolower (c) -# else -# define TOLOWER(c) tolower (c) -# endif - -/* How many characters in the character set. */ -# define CHAR_SET_SIZE 256 - -# ifdef SYNTAX_TABLE - -extern char *re_syntax_table; - -# else /* not SYNTAX_TABLE */ - -static char re_syntax_table[CHAR_SET_SIZE]; - -static void -init_syntax_once (void) -{ - register int c; - static int done = 0; - - if (done) - return; - - memset (re_syntax_table, 0, sizeof re_syntax_table); - - for (c = 0; c < CHAR_SET_SIZE; ++c) - if (ISALNUM (c)) - re_syntax_table[c] = Sword; +#define ISSPACE(c) (SYNTAX (c) == Swhitespace) - re_syntax_table['_'] = Ssymbol; +#define ISUPPER(c) uppercasep (c) - done = 1; -} - -# endif /* not SYNTAX_TABLE */ - -# define SYNTAX(c) re_syntax_table[(c)] - -#endif /* not emacs */ +#define ISWORD(c) (SYNTAX (c) == Sword) #define SIGN_EXTEND_CHAR(c) ((signed char) (c)) -/* Should we use malloc or alloca? If REGEX_MALLOC is not defined, we - use `alloca' instead of `malloc'. This is because using malloc in +/* Use alloca instead of malloc. This is because using malloc in re_search* or re_match* could cause memory leaks when C-g is used in Emacs (note that SAFE_ALLOCA could also call malloc, but does so - via `record_xmalloc' which uses `unwind_protect' to ensure the + via 'record_xmalloc' which uses 'unwind_protect' to ensure the memory is freed even in case of non-local exits); also, malloc is slower and causes storage fragmentation. On the other hand, malloc is more portable, and easier to debug. Because we sometimes use alloca, some routines have to be macros, - not functions -- `alloca'-allocated space disappears at the end of the + not functions -- 'alloca'-allocated space disappears at the end of the function it is called in. */ -#ifdef REGEX_MALLOC - -# define REGEX_ALLOCATE malloc -# define REGEX_REALLOCATE(source, osize, nsize) realloc (source, nsize) -# define REGEX_FREE free - -#else /* not REGEX_MALLOC */ - -# ifdef emacs /* This may be adjusted in main(), if the stack is successfully grown. */ ptrdiff_t emacs_re_safe_alloca = MAX_ALLOCA; /* Like USE_SAFE_ALLOCA, but use emacs_re_safe_alloca. */ -# define REGEX_USE_SAFE_ALLOCA \ - ptrdiff_t sa_avail = emacs_re_safe_alloca; \ - ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false - -# define REGEX_SAFE_FREE() SAFE_FREE () -# define REGEX_ALLOCATE SAFE_ALLOCA -# else -# include <alloca.h> -# define REGEX_ALLOCATE alloca -# endif - -/* Assumes a `char *destination' variable. */ -# define REGEX_REALLOCATE(source, osize, nsize) \ - (destination = REGEX_ALLOCATE (nsize), \ - memcpy (destination, source, osize)) - -/* No need to do anything to free, after alloca. */ -# define REGEX_FREE(arg) ((void)0) /* Do nothing! But inhibit gcc warning. */ - -#endif /* not REGEX_MALLOC */ - -#ifndef REGEX_USE_SAFE_ALLOCA -# define REGEX_USE_SAFE_ALLOCA ((void) 0) -# define REGEX_SAFE_FREE() ((void) 0) -#endif - -/* Define how to allocate the failure stack. */ - -#if defined REL_ALLOC && defined REGEX_MALLOC - -# define REGEX_ALLOCATE_STACK(size) \ - r_alloc (&failure_stack_ptr, (size)) -# define REGEX_REALLOCATE_STACK(source, osize, nsize) \ - r_re_alloc (&failure_stack_ptr, (nsize)) -# define REGEX_FREE_STACK(ptr) \ - r_alloc_free (&failure_stack_ptr) - -#else /* not using relocating allocator */ - -# define REGEX_ALLOCATE_STACK(size) REGEX_ALLOCATE (size) -# define REGEX_REALLOCATE_STACK(source, o, n) REGEX_REALLOCATE (source, o, n) -# define REGEX_FREE_STACK(ptr) REGEX_FREE (ptr) - -#endif /* not using relocating allocator */ +#define REGEX_USE_SAFE_ALLOCA \ + USE_SAFE_ALLOCA; sa_avail = emacs_re_safe_alloca +/* Assumes a 'char *destination' variable. */ +#define REGEX_REALLOCATE(source, osize, nsize) \ + (destination = SAFE_ALLOCA (nsize), \ + memcpy (destination, source, osize)) -/* True if `size1' is non-NULL and PTR is pointing anywhere inside - `string1' or just past its end. This works if PTR is NULL, which is +/* True if 'size1' is non-NULL and PTR is pointing anywhere inside + 'string1' or just past its end. This works if PTR is NULL, which is a good thing. */ #define FIRST_STRING_P(ptr) \ (size1 && string1 <= (ptr) && (ptr) <= string1 + size1) /* (Re)Allocate N items of type T using malloc, or fail. */ -#define TALLOC(n, t) ((t *) malloc ((n) * sizeof (t))) -#define RETALLOC(addr, n, t) ((addr) = (t *) realloc (addr, (n) * sizeof (t))) -#define REGEX_TALLOC(n, t) ((t *) REGEX_ALLOCATE ((n) * sizeof (t))) +#define TALLOC(n, t) ((t *) xmalloc ((n) * sizeof (t))) +#define RETALLOC(addr, n, t) ((addr) = (t *) xrealloc (addr, (n) * sizeof (t))) #define BYTEWIDTH 8 /* In bits. */ -#ifndef emacs -# undef max -# undef min -# define max(a, b) ((a) > (b) ? (a) : (b)) -# define min(a, b) ((a) < (b) ? (a) : (b)) -#endif - /* Type of source-pattern and string chars. */ -#ifdef _MSC_VER -typedef unsigned char re_char; -typedef const re_char const_re_char; -#else typedef const unsigned char re_char; -typedef re_char const_re_char; -#endif -typedef char boolean; - -static regoff_t re_match_2_internal (struct re_pattern_buffer *bufp, +static void re_compile_fastmap (struct re_pattern_buffer *); +static ptrdiff_t re_match_2_internal (struct re_pattern_buffer *bufp, re_char *string1, size_t size1, re_char *string2, size_t size2, - ssize_t pos, + ptrdiff_t pos, struct re_registers *regs, - ssize_t stop); + ptrdiff_t stop); /* These are the command codes that appear in compiled regular expressions. Some opcodes are followed by argument bytes. A @@ -582,7 +245,7 @@ typedef enum /* Stop remembering the text that is matched and store it in a memory register. Followed by one byte with the register - number, in the range 0 to one less than `re_nsub' in the + number, in the range 0 to one less than 're_nsub' in the pattern buffer. */ stop_memory, @@ -596,8 +259,7 @@ typedef enum /* Fail unless at end of line. */ endline, - /* Succeeds if at beginning of buffer (if emacs) or at beginning - of string to be matched (if not). */ + /* Succeeds if at beginning of buffer. */ begbuf, /* Analogously, for end of buffer/string. */ @@ -614,23 +276,23 @@ typedef enum current string position when executed. */ on_failure_keep_string_jump, - /* Just like `on_failure_jump', except that it checks that we + /* Just like 'on_failure_jump', except that it checks that we don't get stuck in an infinite loop (matching an empty string indefinitely). */ on_failure_jump_loop, - /* Just like `on_failure_jump_loop', except that it checks for + /* Just like 'on_failure_jump_loop', except that it checks for a different kind of loop (the kind that shows up with non-greedy operators). This operation has to be immediately preceded - by a `no_op'. */ + by a 'no_op'. */ on_failure_jump_nastyloop, - /* A smart `on_failure_jump' used for greedy * and + operators. + /* A smart 'on_failure_jump' used for greedy * and + operators. It analyzes the loop before which it is put and if the loop does not require backtracking, it changes itself to - `on_failure_keep_string_jump' and short-circuits the loop, - else it just defaults to changing itself into `on_failure_jump'. - It assumes that it is pointing to just past a `jump'. */ + 'on_failure_keep_string_jump' and short-circuits the loop, + else it just defaults to changing itself into 'on_failure_jump'. + It assumes that it is pointing to just past a 'jump'. */ on_failure_jump_smart, /* Followed by two-byte relative address and two-byte number n. @@ -662,10 +324,9 @@ typedef enum syntaxspec, /* Matches any character whose syntax is not that specified. */ - notsyntaxspec + notsyntaxspec, -#ifdef emacs - , at_dot, /* Succeeds if at 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 @@ -676,7 +337,6 @@ typedef enum specified category. The operator is followed by a byte which contains the category code (mnemonic ASCII character). */ notcategoryspec -#endif /* emacs */ } re_opcode_t; /* Common operations on the compiled pattern. */ @@ -687,7 +347,7 @@ typedef enum do { \ (destination)[0] = (number) & 0377; \ (destination)[1] = (number) >> 8; \ - } while (0) + } while (false) /* Same as STORE_NUMBER, except increment DESTINATION to the byte after where the number is stored. Therefore, DESTINATION @@ -697,7 +357,7 @@ typedef enum do { \ STORE_NUMBER (destination, number); \ (destination) += 2; \ - } while (0) + } while (false) /* Put into DESTINATION a number stored in two contiguous bytes starting at SOURCE. */ @@ -736,7 +396,7 @@ extract_number_and_incr (re_char **source) (destination)[1] = ((character) >> 8) & 0377; \ (destination)[2] = (character) >> 16; \ (destination) += 3; \ - } while (0) + } while (false) /* Put into DESTINATION a character stored in three contiguous bytes starting at SOURCE. */ @@ -746,7 +406,7 @@ extract_number_and_incr (re_char **source) (destination) = ((source)[0] \ | ((source)[1] << 8) \ | ((source)[2] << 16)); \ - } while (0) + } while (false) /* Macros for charset. */ @@ -760,47 +420,39 @@ extract_number_and_incr (re_char **source) /* Return the address of range table of charset P. But not the start of table itself, but the before where the number of ranges is - stored. `2 +' means to skip re_opcode_t and size of bitmap, + stored. '2 +' means to skip re_opcode_t and size of bitmap, and the 2 bytes of flags at the start of the range table. */ #define CHARSET_RANGE_TABLE(p) (&(p)[4 + CHARSET_BITMAP_SIZE (p)]) -#ifdef emacs /* Extract the bit flags that start a range table. */ #define CHARSET_RANGE_TABLE_BITS(p) \ ((p)[2 + CHARSET_BITMAP_SIZE (p)] \ + (p)[3 + CHARSET_BITMAP_SIZE (p)] * 0x100) -#endif /* Return the address of end of RANGE_TABLE. COUNT is number of - ranges (which is a pair of (start, end)) in the RANGE_TABLE. `* 2' - is start of range and end of range. `* 3' is size of each start + ranges (which is a pair of (start, end)) in the RANGE_TABLE. '* 2' + is start of range and end of range. '* 3' is size of each start and end. */ #define CHARSET_RANGE_TABLE_END(range_table, count) \ ((range_table) + (count) * 2 * 3) -/* If DEBUG is defined, Regex prints many voluminous messages about what - it is doing (if the variable `debug' is nonzero). If linked with the - main program in `iregex.c', you can enter patterns and strings - interactively. And if linked with the main program in `main.c' and - the other test files, you can run the already-written tests. */ +/* If REGEX_EMACS_DEBUG is defined, print many voluminous messages + (if the variable regex_emacs_debug is positive). */ -#ifdef DEBUG +#ifdef REGEX_EMACS_DEBUG -/* We use standard I/O for debugging. */ +/* Use standard I/O for debugging. */ # include <stdio.h> -/* It is useful to test things that ``must'' be true when debugging. */ -# include <assert.h> - -static int debug = -100000; +static int regex_emacs_debug = -100000; # define DEBUG_STATEMENT(e) e -# define DEBUG_PRINT(...) if (debug > 0) printf (__VA_ARGS__) +# define DEBUG_PRINT(...) if (regex_emacs_debug > 0) printf (__VA_ARGS__) # define DEBUG_COMPILES_ARGUMENTS # define DEBUG_PRINT_COMPILED_PATTERN(p, s, e) \ - if (debug > 0) print_partial_compiled_pattern (s, e) + if (regex_emacs_debug > 0) print_partial_compiled_pattern (s, e) # define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2) \ - if (debug > 0) print_double_string (w, s1, sz1, s2, sz2) + if (regex_emacs_debug > 0) print_double_string (w, s1, sz1, s2, sz2) /* Print the fastmap in human-readable form. */ @@ -1046,7 +698,6 @@ print_partial_compiled_pattern (re_char *start, re_char *end) fprintf (stderr, "/%d", mcnt); break; -# ifdef emacs case at_dot: fprintf (stderr, "/at_dot"); break; @@ -1062,7 +713,6 @@ print_partial_compiled_pattern (re_char *start, re_char *end) mcnt = *p++; fprintf (stderr, "/%d", mcnt); break; -# endif /* emacs */ case begbuf: fprintf (stderr, "/begbuf"); @@ -1089,7 +739,7 @@ print_compiled_pattern (struct re_pattern_buffer *bufp) re_char *buffer = bufp->buffer; print_partial_compiled_pattern (buffer, buffer + bufp->used); - printf ("%ld bytes used/%ld bytes allocated.\n", + printf ("%zu bytes used/%zu bytes allocated.\n", bufp->used, bufp->allocated); if (bufp->fastmap_accurate && bufp->fastmap) @@ -1101,12 +751,6 @@ print_compiled_pattern (struct re_pattern_buffer *bufp) printf ("re_nsub: %zu\t", bufp->re_nsub); printf ("regs_alloc: %d\t", bufp->regs_allocated); printf ("can_be_null: %d\t", bufp->can_be_null); - 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? */ } @@ -1135,141 +779,105 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1, } } -#else /* not DEBUG */ - -# undef assert -# define assert(e) +#else /* not REGEX_EMACS_DEBUG */ # define DEBUG_STATEMENT(e) # define DEBUG_PRINT(...) # define DEBUG_PRINT_COMPILED_PATTERN(p, s, e) # define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2) -#endif /* not DEBUG */ +#endif /* not REGEX_EMACS_DEBUG */ -#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. */ -/* This has no initializer because initialized variables in Emacs - become read-only after dumping. */ -reg_syntax_t re_syntax_options; - - -/* Specify the precise syntax of regexps for compilation. This provides - for compatibility for various utilities which historically have - different, incompatible syntaxes. - - The argument SYNTAX is a bit mask comprised of the various bits - defined in regex.h. We return the old syntax. */ - -reg_syntax_t -re_set_syntax (reg_syntax_t syntax) +typedef enum { - reg_syntax_t ret = re_syntax_options; - - re_syntax_options = syntax; - return ret; -} -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. - POSIX doesn't require that we do anything for REG_NOERROR, - but why not be nice? */ + REG_NOERROR = 0, /* Success. */ + REG_NOMATCH, /* Didn't find a match (for regexec). */ + + /* POSIX regcomp return error codes. (In the order listed in the + standard.) An older version of this code supported the POSIX + API; this version continues to use these names internally. */ + REG_BADPAT, /* Invalid pattern. */ + REG_ECOLLATE, /* Not implemented. */ + REG_ECTYPE, /* Invalid character class name. */ + REG_EESCAPE, /* Trailing backslash. */ + REG_ESUBREG, /* Invalid back reference. */ + REG_EBRACK, /* Unmatched left bracket. */ + REG_EPAREN, /* Parenthesis imbalance. */ + REG_EBRACE, /* Unmatched \{. */ + REG_BADBR, /* Invalid contents of \{\}. */ + REG_ERANGE, /* Invalid range end. */ + REG_ESPACE, /* Ran out of memory. */ + REG_BADRPT, /* No preceding re for repetition op. */ + + /* Error codes we've added. */ + REG_EEND, /* Premature end. */ + REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */ + REG_ERPAREN, /* Unmatched ) or \); not returned from regcomp. */ + REG_ERANGEX, /* Range striding over charsets. */ + REG_ESIZEBR /* n or m too big in \{n,m\} */ +} reg_errcode_t; static const char *re_error_msgid[] = { - gettext_noop ("Success"), /* REG_NOERROR */ - gettext_noop ("No match"), /* REG_NOMATCH */ - gettext_noop ("Invalid regular expression"), /* REG_BADPAT */ - gettext_noop ("Invalid collation character"), /* REG_ECOLLATE */ - gettext_noop ("Invalid character class name"), /* REG_ECTYPE */ - gettext_noop ("Trailing backslash"), /* REG_EESCAPE */ - gettext_noop ("Invalid back reference"), /* REG_ESUBREG */ - gettext_noop ("Unmatched [ or [^"), /* REG_EBRACK */ - gettext_noop ("Unmatched ( or \\("), /* REG_EPAREN */ - gettext_noop ("Unmatched \\{"), /* REG_EBRACE */ - gettext_noop ("Invalid content of \\{\\}"), /* REG_BADBR */ - gettext_noop ("Invalid range end"), /* REG_ERANGE */ - gettext_noop ("Memory exhausted"), /* REG_ESPACE */ - gettext_noop ("Invalid preceding regular expression"), /* REG_BADRPT */ - gettext_noop ("Premature end of regular expression"), /* REG_EEND */ - gettext_noop ("Regular expression too big"), /* REG_ESIZE */ - gettext_noop ("Unmatched ) or \\)"), /* REG_ERPAREN */ - gettext_noop ("Range striding over charsets") /* REG_ERANGEX */ + [REG_NOERROR] = "Success", + [REG_NOMATCH] = "No match", + [REG_BADPAT] = "Invalid regular expression", + [REG_ECOLLATE] = "Invalid collation character", + [REG_ECTYPE] = "Invalid character class name", + [REG_EESCAPE] = "Trailing backslash", + [REG_ESUBREG] = "Invalid back reference", + [REG_EBRACK] = "Unmatched [ or [^", + [REG_EPAREN] = "Unmatched ( or \\(", + [REG_EBRACE] = "Unmatched \\{", + [REG_BADBR] = "Invalid content of \\{\\}", + [REG_ERANGE] = "Invalid range end", + [REG_ESPACE] = "Memory exhausted", + [REG_BADRPT] = "Invalid preceding regular expression", + [REG_EEND] = "Premature end of regular expression", + [REG_ESIZE] = "Regular expression too big", + [REG_ERPAREN] = "Unmatched ) or \\)", + [REG_ERANGEX ] = "Range striding over charsets", + [REG_ESIZEBR ] = "Invalid content of \\{\\}", }; - -/* Whether to allocate memory during matching. */ - -/* Define MATCH_MAY_ALLOCATE to allow the searching and matching - functions allocate memory for the failure stack and registers. - Normally should be defined, because otherwise searching and - matching routines will have much smaller memory resources at their - disposal, and therefore might fail to handle complex regexps. - Therefore undefine MATCH_MAY_ALLOCATE only in the following - exceptional situations: - - . When running on a system where memory is at premium. - . When alloca cannot be used at all, perhaps due to bugs in - its implementation, or its being unavailable, or due to a - very small stack size. This requires to define REGEX_MALLOC - to use malloc instead, which in turn could lead to memory - leaks if search is interrupted by a signal. (For these - reasons, defining REGEX_MALLOC when building Emacs - automatically undefines MATCH_MAY_ALLOCATE, but outside - Emacs you may not care about memory leaks.) If you want to - prevent the memory leaks, undefine MATCH_MAY_ALLOCATE. - . When code that calls the searching and matching functions - cannot allow memory allocation, for whatever reasons. */ - -/* Normally, this is fine. */ -#define MATCH_MAY_ALLOCATE - -/* The match routines may not allocate if (1) they would do it with malloc - and (2) it's not safe for them to use malloc. - Note that if REL_ALLOC is defined, matching would not use malloc for the - failure stack, but we would still use it for the register vectors; - so REL_ALLOC should not affect this. */ -#if defined REGEX_MALLOC && defined emacs -# undef MATCH_MAY_ALLOCATE -#endif +/* For 'regs_allocated'. */ +enum { REGS_UNALLOCATED, REGS_REALLOCATE, REGS_FIXED }; + +/* If 'regs_allocated' is REGS_UNALLOCATED in the pattern buffer, + 're_match_2' returns information about at least this many registers + the first time a 'regs' structure is passed. */ +enum { RE_NREGS = 30 }; +/* The searching and matching functions allocate memory for the + failure stack and registers. Otherwise searching and matching + routines would have much smaller memory resources at their + disposal, and therefore might fail to handle complex regexps. */ + /* Failure stack declarations and macros; both re_compile_fastmap and re_match_2 use a failure stack. These have to be macros because of - REGEX_ALLOCATE_STACK. */ + SAFE_ALLOCA. */ /* Approximate number of failure points for which to initially allocate space when matching. If this number is exceeded, we allocate more space, so it is not a hard limit. */ -#ifndef INIT_FAILURE_ALLOC -# define INIT_FAILURE_ALLOC 20 -#endif +#define INIT_FAILURE_ALLOC 20 /* Roughly the maximum number of failure points on the stack. Would be - exactly that if always used TYPICAL_FAILURE_SIZE items each time we failed. + exactly that if failure always used TYPICAL_FAILURE_SIZE items. This is a variable only so users of regex can assign to it; we never change it ourselves. We always multiply it by TYPICAL_FAILURE_SIZE before using it, so it should probably be a byte-count instead. */ -# if defined MATCH_MAY_ALLOCATE /* Note that 4400 was enough to cause a crash on Alpha OSF/1, whose default stack limit is 2mb. In order for a larger value to work reliably, you have to try to make it accord with the process stack limit. */ size_t emacs_re_max_failures = 40000; -# else -size_t emacs_re_max_failures = 4000; -# endif union fail_stack_elt { re_char *pointer; - /* This should be the biggest `int' that's no bigger than a pointer. */ + /* This should be the biggest 'int' that's no bigger than a pointer. */ long integer; }; @@ -1286,45 +894,28 @@ typedef struct #define FAIL_STACK_EMPTY() (fail_stack.frame == 0) -/* Define macros to initialize and free the failure stack. - Do `return -2' if the alloc fails. */ +/* Define macros to initialize and free the failure stack. */ -#ifdef MATCH_MAY_ALLOCATE -# define INIT_FAIL_STACK() \ +#define INIT_FAIL_STACK() \ do { \ fail_stack.stack = \ - REGEX_ALLOCATE_STACK (INIT_FAILURE_ALLOC * TYPICAL_FAILURE_SIZE \ - * sizeof (fail_stack_elt_t)); \ - \ - if (fail_stack.stack == NULL) \ - return -2; \ - \ + SAFE_ALLOCA (INIT_FAILURE_ALLOC * TYPICAL_FAILURE_SIZE \ + * sizeof (fail_stack_elt_t)); \ fail_stack.size = INIT_FAILURE_ALLOC; \ fail_stack.avail = 0; \ fail_stack.frame = 0; \ - } while (0) -#else -# define INIT_FAIL_STACK() \ - do { \ - fail_stack.avail = 0; \ - fail_stack.frame = 0; \ - } while (0) - -# define RETALLOC_IF(addr, n, t) \ - if (addr) RETALLOC((addr), (n), t); else (addr) = TALLOC ((n), t) -#endif + } while (false) /* Double the size of FAIL_STACK, up to a limit - which allows approximately `emacs_re_max_failures' items. + which allows approximately 'emacs_re_max_failures' items. Return 1 if succeeds, and 0 if either ran out of memory allocating space for it or it was already too large. - REGEX_REALLOCATE_STACK requires `destination' be declared. */ + REGEX_REALLOCATE requires 'destination' be declared. */ -/* Factor to increase the failure stack size by - when we increase it. +/* Factor to increase the failure stack size by. This used to be 2, but 2 was too wasteful because the old discarded stacks added up to as much space were as ultimate, maximum-size stack. */ @@ -1334,34 +925,31 @@ typedef struct (((fail_stack).size >= emacs_re_max_failures * TYPICAL_FAILURE_SIZE) \ ? 0 \ : ((fail_stack).stack \ - = REGEX_REALLOCATE_STACK ((fail_stack).stack, \ + = REGEX_REALLOCATE ((fail_stack).stack, \ (fail_stack).size * sizeof (fail_stack_elt_t), \ min (emacs_re_max_failures * TYPICAL_FAILURE_SIZE, \ ((fail_stack).size * FAIL_STACK_GROWTH_FACTOR)) \ * sizeof (fail_stack_elt_t)), \ - \ - (fail_stack).stack == NULL \ - ? 0 \ - : ((fail_stack).size \ - = (min (emacs_re_max_failures * TYPICAL_FAILURE_SIZE, \ - ((fail_stack).size * FAIL_STACK_GROWTH_FACTOR))), \ - 1))) + ((fail_stack).size \ + = (min (emacs_re_max_failures * TYPICAL_FAILURE_SIZE, \ + ((fail_stack).size * FAIL_STACK_GROWTH_FACTOR)))), \ + 1)) /* Push a pointer value onto the failure stack. - Assumes the variable `fail_stack'. Probably should only - be called from within `PUSH_FAILURE_POINT'. */ + Assumes the variable 'fail_stack'. Probably should only + be called from within 'PUSH_FAILURE_POINT'. */ #define PUSH_FAILURE_POINTER(item) \ fail_stack.stack[fail_stack.avail++].pointer = (item) /* This pushes an integer-valued item onto the failure stack. - Assumes the variable `fail_stack'. Probably should only - be called from within `PUSH_FAILURE_POINT'. */ + Assumes the variable 'fail_stack'. Probably should only + be called from within 'PUSH_FAILURE_POINT'. */ #define PUSH_FAILURE_INT(item) \ fail_stack.stack[fail_stack.avail++].integer = (item) /* These POP... operations complement the PUSH... operations. - All assume that `fail_stack' is nonempty. */ + All assume that 'fail_stack' is nonempty. */ #define POP_FAILURE_POINTER() fail_stack.stack[--fail_stack.avail].pointer #define POP_FAILURE_INT() fail_stack.stack[--fail_stack.avail].integer @@ -1379,8 +967,8 @@ typedef struct while (REMAINING_AVAIL_SLOTS <= space) { \ if (!GROW_FAIL_STACK (fail_stack)) \ return -2; \ - DEBUG_PRINT ("\n Doubled stack; size now: %zd\n", (fail_stack).size);\ - DEBUG_PRINT (" slots available: %zd\n", REMAINING_AVAIL_SLOTS);\ + DEBUG_PRINT ("\n Doubled stack; size now: %zu\n", (fail_stack).size);\ + DEBUG_PRINT (" slots available: %zu\n", REMAINING_AVAIL_SLOTS);\ } /* Push register NUM onto the stack. */ @@ -1394,7 +982,7 @@ do { \ PUSH_FAILURE_POINTER (regstart[n]); \ PUSH_FAILURE_POINTER (regend[n]); \ PUSH_FAILURE_INT (n); \ -} while (0) +} while (false) /* Change the counter's value to VAL, but make sure that it will be reset when backtracking. */ @@ -1409,7 +997,7 @@ do { \ PUSH_FAILURE_POINTER (ptr); \ PUSH_FAILURE_INT (-1); \ STORE_NUMBER (ptr, val); \ -} while (0) +} while (false) /* Pop a saved register off the stack. */ #define POP_FAILURE_REG_OR_COUNT() \ @@ -1418,7 +1006,7 @@ do { \ if (pfreg == -1) \ { \ /* It's a counter. */ \ - /* Here, we discard `const', making re_match non-reentrant. */ \ + /* Discard 'const', making re_search non-reentrant. */ \ unsigned char *ptr = (unsigned char *) POP_FAILURE_POINTER (); \ pfreg = POP_FAILURE_INT (); \ STORE_NUMBER (ptr, pfreg); \ @@ -1431,19 +1019,19 @@ do { \ DEBUG_PRINT (" Pop reg %ld (spanning %p -> %p)\n", \ pfreg, regstart[pfreg], regend[pfreg]); \ } \ -} while (0) +} while (false) /* Check that we are not stuck in an infinite loop. */ #define CHECK_INFINITE_LOOP(pat_cur, string_place) \ do { \ - ssize_t failure = TOP_FAILURE_HANDLE (); \ + ptrdiff_t failure = TOP_FAILURE_HANDLE (); \ /* Check for infinite matching loops */ \ while (failure > 0 \ && (FAILURE_STR (failure) == string_place \ || FAILURE_STR (failure) == NULL)) \ { \ - assert (FAILURE_PAT (failure) >= bufp->buffer \ - && FAILURE_PAT (failure) <= bufp->buffer + bufp->used); \ + eassert (FAILURE_PAT (failure) >= bufp->buffer \ + && FAILURE_PAT (failure) <= bufp->buffer + bufp->used); \ if (FAILURE_PAT (failure) == pat_cur) \ { \ cycle = 1; \ @@ -1453,47 +1041,44 @@ do { \ failure = NEXT_FAILURE_HANDLE(failure); \ } \ DEBUG_PRINT (" Other string: %p\n", FAILURE_STR (failure)); \ -} while (0) +} while (false) /* Push the information about the state we will need if we ever fail back to it. Requires variables fail_stack, regstart, regend and - num_regs be declared. GROW_FAIL_STACK requires `destination' be + num_regs be declared. GROW_FAIL_STACK requires 'destination' be declared. - Does `return FAILURE_CODE' if runs out of memory. */ + Does 'return FAILURE_CODE' if runs out of memory. */ #define PUSH_FAILURE_POINT(pattern, string_place) \ do { \ char *destination; \ - /* Must be int, so when we don't save any registers, the arithmetic \ - of 0 + -1 isn't done as unsigned. */ \ - \ DEBUG_STATEMENT (nfailure_points_pushed++); \ DEBUG_PRINT ("\nPUSH_FAILURE_POINT:\n"); \ - DEBUG_PRINT (" Before push, next avail: %zd\n", (fail_stack).avail); \ - DEBUG_PRINT (" size: %zd\n", (fail_stack).size);\ - \ + DEBUG_PRINT (" Before push, next avail: %zu\n", (fail_stack).avail); \ + DEBUG_PRINT (" size: %zu\n", (fail_stack).size);\ + \ ENSURE_FAIL_STACK (NUM_NONREG_ITEMS); \ - \ + \ DEBUG_PRINT ("\n"); \ - \ - DEBUG_PRINT (" Push frame index: %zd\n", fail_stack.frame); \ + \ + DEBUG_PRINT (" Push frame index: %zu\n", fail_stack.frame); \ PUSH_FAILURE_INT (fail_stack.frame); \ - \ + \ DEBUG_PRINT (" Push string %p: \"", string_place); \ DEBUG_PRINT_DOUBLE_STRING (string_place, string1, size1, string2, size2);\ DEBUG_PRINT ("\"\n"); \ PUSH_FAILURE_POINTER (string_place); \ - \ + \ DEBUG_PRINT (" Push pattern %p: ", pattern); \ DEBUG_PRINT_COMPILED_PATTERN (bufp, pattern, pend); \ PUSH_FAILURE_POINTER (pattern); \ - \ + \ /* Close the frame by moving the frame pointer past it. */ \ fail_stack.frame = fail_stack.avail; \ -} while (0) +} while (false) /* Estimate the size of data pushed by a typical failure stack entry. An estimate is all we need, because all we use this for @@ -1505,24 +1090,24 @@ do { \ #define REMAINING_AVAIL_SLOTS ((fail_stack).size - (fail_stack).avail) -/* Pops what PUSH_FAIL_STACK pushes. +/* Pop what PUSH_FAIL_STACK pushes. - We restore into the parameters, all of which should be lvalues: + Restore into the parameters, all of which should be lvalues: STR -- the saved data position. PAT -- the saved pattern position. REGSTART, REGEND -- arrays of string positions. - Also assumes the variables `fail_stack' and (if debugging), `bufp', - `pend', `string1', `size1', `string2', and `size2'. */ + Also assume the variables FAIL_STACK and (if debugging) BUFP, PEND, + STRING1, SIZE1, STRING2, and SIZE2. */ #define POP_FAILURE_POINT(str, pat) \ do { \ - assert (!FAIL_STACK_EMPTY ()); \ + eassert (!FAIL_STACK_EMPTY ()); \ \ /* Remove failure points and point to how many regs pushed. */ \ DEBUG_PRINT ("POP_FAILURE_POINT:\n"); \ - DEBUG_PRINT (" Before pop, next avail: %zd\n", fail_stack.avail); \ - DEBUG_PRINT (" size: %zd\n", fail_stack.size); \ + DEBUG_PRINT (" Before pop, next avail: %zu\n", fail_stack.avail); \ + DEBUG_PRINT (" size: %zu\n", fail_stack.size); \ \ /* Pop the saved registers. */ \ while (fail_stack.frame < fail_stack.avail) \ @@ -1541,13 +1126,13 @@ do { \ DEBUG_PRINT ("\"\n"); \ \ fail_stack.frame = POP_FAILURE_INT (); \ - DEBUG_PRINT (" Popping frame index: %zd\n", fail_stack.frame); \ + DEBUG_PRINT (" Popping frame index: %zu\n", fail_stack.frame); \ \ - assert (fail_stack.avail >= 0); \ - assert (fail_stack.frame <= fail_stack.avail); \ + eassert (fail_stack.avail >= 0); \ + eassert (fail_stack.frame <= fail_stack.avail); \ \ DEBUG_STATEMENT (nfailure_points_popped++); \ -} while (0) /* POP_FAILURE_POINT */ +} while (false) /* POP_FAILURE_POINT */ @@ -1557,12 +1142,8 @@ 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); @@ -1570,10 +1151,8 @@ static void insert_op1 (re_opcode_t op, unsigned char *loc, int arg, unsigned char *end); static void insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, unsigned char *end); -static boolean at_begline_loc_p (re_char *pattern, re_char *p, - reg_syntax_t syntax); -static boolean at_endline_loc_p (re_char *p, re_char *pend, - reg_syntax_t syntax); +static bool at_begline_loc_p (re_char *pattern, re_char *p); +static bool at_endline_loc_p (re_char *p, re_char *pend); static re_char *skip_one_char (re_char *p); static int analyze_first (re_char *p, re_char *pend, char *fastmap, const int multibyte); @@ -1586,35 +1165,28 @@ static int analyze_first (re_char *p, re_char *pend, if (p == pend) return REG_EEND; \ c = RE_STRING_CHAR_AND_LENGTH (p, len, multibyte); \ p += len; \ - } while (0) + } while (false) -/* If `translate' is non-null, return translate[D], else just D. We - cast the subscript to translate because some data is declared as - `char *', to avoid warnings when a string constant is passed. But - when we use a character as a subscript we must make it unsigned. */ -#ifndef TRANSLATE -# define TRANSLATE(d) \ - (RE_TRANSLATE_P (translate) ? RE_TRANSLATE (translate, (d)) : (d)) -#endif - +#define RE_TRANSLATE(TBL, C) char_table_translate (TBL, C) +#define TRANSLATE(d) (!NILP (translate) ? RE_TRANSLATE (translate, d) : (d)) -/* Macros for outputting the compiled pattern into `buffer'. */ +/* Macros for outputting the compiled pattern into 'buffer'. */ /* If the buffer isn't allocated when it comes in, use this. */ #define INIT_BUF_SIZE 32 -/* Make sure we have at least N more bytes of space in buffer. */ +/* Ensure at least N more bytes of space in buffer. */ #define GET_BUFFER_SPACE(n) \ while ((size_t) (b - bufp->buffer + (n)) > bufp->allocated) \ EXTEND_BUFFER () -/* Make sure we have one more byte of buffer space and then add C to it. */ +/* Ensure one more byte of buffer space and then add C to it. */ #define BUF_PUSH(c) \ do { \ GET_BUFFER_SPACE (1); \ *b++ = (unsigned char) (c); \ - } while (0) + } while (false) /* Ensure we have two more bytes of buffer space and then append C1 and C2. */ @@ -1623,10 +1195,10 @@ static int analyze_first (re_char *p, re_char *pend, GET_BUFFER_SPACE (2); \ *b++ = (unsigned char) (c1); \ *b++ = (unsigned char) (c2); \ - } while (0) + } while (false) -/* Store a jump with opcode OP at LOC to location TO. We store a +/* Store a jump with opcode OP at LOC to location TO. Store a relative address offset by the three bytes the jump itself occupies. */ #define STORE_JUMP(op, loc, to) \ store_op1 (op, loc, (to) - (loc) - 3) @@ -1635,11 +1207,11 @@ static int analyze_first (re_char *p, re_char *pend, #define STORE_JUMP2(op, loc, to, arg) \ store_op2 (op, loc, (to) - (loc) - 3, arg) -/* Like `STORE_JUMP', but for inserting. Assume `b' is the buffer end. */ +/* Like 'STORE_JUMP', but for inserting. Assume B is the buffer end. */ #define INSERT_JUMP(op, loc, to) \ insert_op1 (op, loc, (to) - (loc) - 3, b) -/* Like `STORE_JUMP2', but for inserting. Assume `b' is the buffer end. */ +/* Like 'STORE_JUMP2', but for inserting. Assume B is the buffer end. */ #define INSERT_JUMP2(op, loc, to, arg) \ insert_op2 (op, loc, (to) - (loc) - 3, arg, b) @@ -1647,7 +1219,7 @@ static int analyze_first (re_char *p, re_char *pend, /* This is not an arbitrary limit: the arguments which represent offsets into the pattern are two bytes long. So if 2^15 bytes turns out to be too small, many things would have to change. */ -# define MAX_BUF_SIZE (1L << 15) +# define MAX_BUF_SIZE (1 << 15) /* Extend the buffer by twice its current size via realloc and reset the pointers that pointed into the old block to point to the @@ -1671,15 +1243,13 @@ static int analyze_first (re_char *p, re_char *pend, 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; \ 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) + } while (false) /* Since we have one byte reserved for the register number argument to @@ -1687,7 +1257,7 @@ static int analyze_first (re_char *p, re_char *pend, things about is what fits in that byte. */ #define MAX_REGNUM 255 -/* But patterns can have more than `MAX_REGNUM' registers. We just +/* But patterns can have more than 'MAX_REGNUM' registers. Just ignore the excess. */ typedef int regnum_t; @@ -1696,7 +1266,6 @@ typedef int regnum_t; /* Since offsets can go either forwards or backwards, this type needs to be able to hold values from -(MAX_BUF_SIZE - 1) to MAX_BUF_SIZE - 1. */ -/* int may be not enough when sizeof(int) == 2. */ typedef long pattern_offset_t; typedef struct @@ -1723,12 +1292,6 @@ typedef struct /* The next available element. */ #define COMPILE_STACK_TOP (compile_stack.stack[compile_stack.avail]) - -/* Explicit quit checking is needed for Emacs, which uses polling to - process input events. */ -#ifndef emacs -static void maybe_quit (void) {} -#endif /* Structure to manage work area for range table. */ struct range_table_work_area @@ -1739,8 +1302,6 @@ struct range_table_work_area int bits; /* flag to record character classes */ }; -#ifdef emacs - /* Make sure that WORK_AREA can hold more N multibyte characters. This is used only in set_image_of_range and set_image_of_range_1. It expects WORK_AREA to be a pointer. @@ -1754,7 +1315,7 @@ struct range_table_work_area if ((work_area).table == 0) \ return (REG_ESPACE); \ } \ - } while (0) + } while (false) #define SET_RANGE_TABLE_WORK_AREA_BIT(work_area, bit) \ (work_area).bits |= (bit) @@ -1765,18 +1326,17 @@ struct range_table_work_area EXTEND_RANGE_TABLE ((work_area), 2); \ (work_area).table[(work_area).used++] = (range_start); \ (work_area).table[(work_area).used++] = (range_end); \ - } while (0) - -#endif /* emacs */ + } while (false) /* Free allocated memory for WORK_AREA. */ #define FREE_RANGE_TABLE_WORK_AREA(work_area) \ do { \ if ((work_area).table) \ - free ((work_area).table); \ - } while (0) + xfree ((work_area).table); \ + } while (false) -#define CLEAR_RANGE_TABLE_WORK_USED(work_area) ((work_area).used = 0, (work_area).bits = 0) +#define CLEAR_RANGE_TABLE_WORK_USED(work_area) \ + ((work_area).used = 0, (work_area).bits = 0) #define RANGE_TABLE_WORK_USED(work_area) ((work_area).used) #define RANGE_TABLE_WORK_BITS(work_area) ((work_area).bits) #define RANGE_TABLE_WORK_ELT(work_area, i) ((work_area).table[i]) @@ -1801,8 +1361,6 @@ struct range_table_work_area #define SET_LIST_BIT(c) (b[((c)) / BYTEWIDTH] |= 1 << ((c) % BYTEWIDTH)) -#ifdef emacs - /* Store characters in the range FROM to TO in the bitmap at B (for ASCII and unibyte characters) and WORK_AREA (for multibyte characters) while translating them and paying attention to the @@ -1817,7 +1375,7 @@ struct range_table_work_area #define SETUP_ASCII_RANGE(work_area, FROM, TO) \ do { \ int C0, C1; \ - \ + \ for (C0 = (FROM); C0 <= (TO); C0++) \ { \ C1 = TRANSLATE (C0); \ @@ -1829,7 +1387,7 @@ struct range_table_work_area } \ SET_LIST_BIT (C1); \ } \ - } while (0) + } while (false) /* Both FROM and TO are unibyte characters (0x80..0xFF). */ @@ -1838,7 +1396,7 @@ struct range_table_work_area do { \ int C0, C1, C2, I; \ int USED = RANGE_TABLE_WORK_USED (work_area); \ - \ + \ for (C0 = (FROM); C0 <= (TO); C0++) \ { \ C1 = RE_CHAR_TO_MULTIBYTE (C0); \ @@ -1869,7 +1427,7 @@ struct range_table_work_area SET_RANGE_TABLE_WORK_AREA ((work_area), C2, C2); \ } \ } \ - } while (0) + } while (false) /* Both FROM and TO are multibyte characters. */ @@ -1877,7 +1435,7 @@ struct range_table_work_area #define SETUP_MULTIBYTE_RANGE(work_area, FROM, TO) \ do { \ int C0, C1, C2, I, USED = RANGE_TABLE_WORK_USED (work_area); \ - \ + \ SET_RANGE_TABLE_WORK_AREA ((work_area), (FROM), (TO)); \ for (C0 = (FROM); C0 <= (TO); C0++) \ { \ @@ -1891,7 +1449,7 @@ struct range_table_work_area { \ int from = RANGE_TABLE_WORK_ELT (work_area, I); \ int to = RANGE_TABLE_WORK_ELT (work_area, I + 1); \ - \ + \ if (C1 >= from - 1 && C1 <= to + 1) \ { \ if (C1 == from - 1) \ @@ -1904,9 +1462,7 @@ struct range_table_work_area if (I < USED) \ SET_RANGE_TABLE_WORK_AREA ((work_area), C1, C1); \ } \ - } while (0) - -#endif /* emacs */ + } while (false) /* Get the next unsigned number in the uncompiled pattern. */ #define GET_INTERVAL_COUNT(num) \ @@ -1921,17 +1477,15 @@ struct range_table_work_area if (num < 0) \ num = 0; \ if (RE_DUP_MAX / 10 - (RE_DUP_MAX % 10 < c - '0') < num) \ - FREE_STACK_RETURN (REG_BADBR); \ + FREE_STACK_RETURN (REG_ESIZEBR); \ num = num * 10 + c - '0'; \ if (p == pend) \ FREE_STACK_RETURN (REG_EBRACE); \ PATFETCH (c); \ } \ } \ - } while (0) + } while (false) -#if ! WIDE_CHAR_SUPPORT - /* 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. @@ -2025,7 +1579,7 @@ re_wctype_parse (const unsigned char **strp, unsigned limit) } /* True if CH is in the char class CC. */ -boolean +bool re_iswctype (int ch, re_wctype_t cc) { switch (cc) @@ -2078,7 +1632,6 @@ re_wctype_to_bit (re_wctype_t cc) abort (); } } -#endif /* Filling in the work area of a range. */ @@ -2088,357 +1641,75 @@ static void extend_range_table_work_area (struct range_table_work_area *work_area) { work_area->allocated += 16 * sizeof (int); - work_area->table = realloc (work_area->table, work_area->allocated); + work_area->table = xrealloc (work_area->table, work_area->allocated); } - -#if 0 -#ifdef emacs - -/* Carefully find the ranges of codes that are equivalent - under case conversion to the range start..end when passed through - TRANSLATE. Handle the case where non-letters can come in between - two upper-case letters (which happens in Latin-1). - Also handle the case of groups of more than 2 case-equivalent chars. - - The basic method is to look at consecutive characters and see - if they can form a run that can be handled as one. - - Returns -1 if successful, REG_ESPACE if ran out of space. */ - -static int -set_image_of_range_1 (struct range_table_work_area *work_area, - re_wchar_t start, re_wchar_t end, - RE_TRANSLATE_TYPE translate) -{ - /* `one_case' indicates a character, or a run of characters, - each of which is an isolate (no case-equivalents). - This includes all ASCII non-letters. - - `two_case' indicates a character, or a run of characters, - each of which has two case-equivalent forms. - This includes all ASCII letters. - - `strange' indicates a character that has more than one - case-equivalent. */ - - enum case_type {one_case, two_case, strange}; - - /* Describe the run that is in progress, - which the next character can try to extend. - If run_type is strange, that means there really is no run. - If run_type is one_case, then run_start...run_end is the run. - If run_type is two_case, then the run is run_start...run_end, - and the case-equivalents end at run_eqv_end. */ - - enum case_type run_type = strange; - int run_start, run_end, run_eqv_end; - - Lisp_Object eqv_table; - - if (!RE_TRANSLATE_P (translate)) - { - EXTEND_RANGE_TABLE (work_area, 2); - work_area->table[work_area->used++] = (start); - work_area->table[work_area->used++] = (end); - return -1; - } - - eqv_table = XCHAR_TABLE (translate)->extras[2]; - - for (; start <= end; start++) - { - enum case_type this_type; - int eqv = RE_TRANSLATE (eqv_table, start); - int minchar, maxchar; - - /* Classify this character */ - if (eqv == start) - this_type = one_case; - else if (RE_TRANSLATE (eqv_table, eqv) == start) - this_type = two_case; - else - this_type = strange; - - if (start < eqv) - minchar = start, maxchar = eqv; - else - minchar = eqv, maxchar = start; - - /* Can this character extend the run in progress? */ - if (this_type == strange || this_type != run_type - || !(minchar == run_end + 1 - && (run_type == two_case - ? maxchar == run_eqv_end + 1 : 1))) - { - /* No, end the run. - Record each of its equivalent ranges. */ - if (run_type == one_case) - { - EXTEND_RANGE_TABLE (work_area, 2); - work_area->table[work_area->used++] = run_start; - work_area->table[work_area->used++] = run_end; - } - else if (run_type == two_case) - { - EXTEND_RANGE_TABLE (work_area, 4); - work_area->table[work_area->used++] = run_start; - work_area->table[work_area->used++] = run_end; - work_area->table[work_area->used++] - = RE_TRANSLATE (eqv_table, run_start); - work_area->table[work_area->used++] - = RE_TRANSLATE (eqv_table, run_end); - } - run_type = strange; - } - - if (this_type == strange) - { - /* For a strange character, add each of its equivalents, one - by one. Don't start a range. */ - do - { - EXTEND_RANGE_TABLE (work_area, 2); - work_area->table[work_area->used++] = eqv; - work_area->table[work_area->used++] = eqv; - eqv = RE_TRANSLATE (eqv_table, eqv); - } - while (eqv != start); - } - - /* Add this char to the run, or start a new run. */ - else if (run_type == strange) - { - /* Initialize a new range. */ - run_type = this_type; - run_start = start; - run_end = start; - run_eqv_end = RE_TRANSLATE (eqv_table, run_end); - } - else - { - /* Extend a running range. */ - run_end = minchar; - run_eqv_end = RE_TRANSLATE (eqv_table, run_end); - } - } - - /* If a run is still in progress at the end, finish it now - by recording its equivalent ranges. */ - if (run_type == one_case) - { - EXTEND_RANGE_TABLE (work_area, 2); - work_area->table[work_area->used++] = run_start; - work_area->table[work_area->used++] = run_end; - } - else if (run_type == two_case) - { - EXTEND_RANGE_TABLE (work_area, 4); - work_area->table[work_area->used++] = run_start; - work_area->table[work_area->used++] = run_end; - work_area->table[work_area->used++] - = RE_TRANSLATE (eqv_table, run_start); - work_area->table[work_area->used++] - = RE_TRANSLATE (eqv_table, run_end); - } - - return -1; -} - -#endif /* emacs */ - -/* Record the image of the range start..end when passed through - TRANSLATE. This is not necessarily TRANSLATE(start)..TRANSLATE(end) - and is not even necessarily contiguous. - Normally we approximate it with the smallest contiguous range that contains - all the chars we need. However, for Latin-1 we go to extra effort - to do a better job. - - This function is not called for ASCII ranges. - - Returns -1 if successful, REG_ESPACE if ran out of space. */ - -static int -set_image_of_range (struct range_table_work_area *work_area, - re_wchar_t start, re_wchar_t end, - RE_TRANSLATE_TYPE translate) -{ - re_wchar_t cmin, cmax; - -#ifdef emacs - /* For Latin-1 ranges, use set_image_of_range_1 - to get proper handling of ranges that include letters and nonletters. - For a range that includes the whole of Latin-1, this is not necessary. - For other character sets, we don't bother to get this right. */ - if (RE_TRANSLATE_P (translate) && start < 04400 - && !(start < 04200 && end >= 04377)) - { - int newend; - int tem; - newend = end; - if (newend > 04377) - newend = 04377; - tem = set_image_of_range_1 (work_area, start, newend, translate); - if (tem > 0) - return tem; - - start = 04400; - if (end < 04400) - return -1; - } -#endif - - EXTEND_RANGE_TABLE (work_area, 2); - work_area->table[work_area->used++] = (start); - work_area->table[work_area->used++] = (end); - - cmin = -1, cmax = -1; - - if (RE_TRANSLATE_P (translate)) - { - int ch; - - for (ch = start; ch <= end; ch++) - { - re_wchar_t c = TRANSLATE (ch); - if (! (start <= c && c <= end)) - { - if (cmin == -1) - cmin = c, cmax = c; - else - { - cmin = min (cmin, c); - cmax = max (cmax, c); - } - } - } - - if (cmin != -1) - { - EXTEND_RANGE_TABLE (work_area, 2); - work_area->table[work_area->used++] = (cmin); - work_area->table[work_area->used++] = (cmax); - } - } - - return -1; -} -#endif /* 0 */ - -#ifndef MATCH_MAY_ALLOCATE - -/* If we cannot allocate large objects within re_match_2_internal, - we make the fail stack and register vectors global. - The fail stack, we grow to the maximum size when a regexp - is compiled. - The register vectors, we adjust in size each time we - compile a regexp, according to the number of registers it needs. */ - -static fail_stack_type fail_stack; - -/* Size with which the following vectors are currently allocated. - That is so we can make them bigger as needed, - but never make them smaller. */ -static int regs_allocated_size; - -static re_char ** regstart, ** regend; -static re_char **best_regstart, **best_regend; - -/* Make the register vectors big enough for NUM_REGS registers, - but don't make them smaller. */ - -static -regex_grow_registers (int num_regs) -{ - if (num_regs > regs_allocated_size) - { - RETALLOC_IF (regstart, num_regs, re_char *); - RETALLOC_IF (regend, num_regs, re_char *); - RETALLOC_IF (best_regstart, num_regs, re_char *); - RETALLOC_IF (best_regend, num_regs, re_char *); - - regs_allocated_size = num_regs; - } -} - -#endif /* not MATCH_MAY_ALLOCATE */ -static boolean group_in_compile_stack (compile_stack_type compile_stack, - regnum_t regnum); - -/* `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. +/* regex_compile and helpers. */ - Assumes the `allocated' (and perhaps `buffer') and `translate' - fields are set in BUFP on entry. - - If it succeeds, results are put in BUFP (if it returns an error, the - contents of BUFP are undefined): - `buffer' is the compiled pattern; - `syntax' is set to SYNTAX; - `used' is set to the length of the compiled pattern; - `fastmap_accurate' is zero; - `re_nsub' is the number of subexpressions in PATTERN; - `not_bol' and `not_eol' are zero; +static bool group_in_compile_stack (compile_stack_type, regnum_t); - The `fastmap' field is neither examined nor set. */ - -/* Insert the `jump' from the end of last alternative to "here". +/* Insert the 'jump' from the end of last alternative to "here". The space for the jump has already been allocated. */ #define FIXUP_ALT_JUMP() \ do { \ if (fixup_alt_jump) \ STORE_JUMP (jump, fixup_alt_jump, b); \ -} while (0) +} while (false) /* Return, freeing storage we allocated. */ #define FREE_STACK_RETURN(value) \ do { \ FREE_RANGE_TABLE_WORK_AREA (range_table_work); \ - free (compile_stack.stack); \ + xfree (compile_stack.stack); \ return value; \ - } while (0) + } while (false) + +/* Compile PATTERN (of length SIZE) according to SYNTAX. + Return a nonzero error code on failure, or zero for success. + + If WHITESPACE_REGEXP is given, use it instead of a space + character in PATTERN. + + Assume the 'allocated' (and perhaps 'buffer') and 'translate' + fields are set in BUFP on entry. + + If successful, put results in *BUFP (otherwise the + contents of *BUFP are undefined): + 'buffer' is the compiled pattern; + 'syntax' is set to SYNTAX; + 'used' is set to the length of the compiled pattern; + 'fastmap_accurate' is zero; + 're_nsub' is the number of subexpressions in PATTERN; + + The 'fastmap' field is neither examined nor set. */ static reg_errcode_t -regex_compile (const_re_char *pattern, size_t size, -#ifdef emacs -# define syntax RE_SYNTAX_EMACS +regex_compile (re_char *pattern, size_t size, 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. */ - register re_wchar_t c, c1; + /* Fetch characters from PATTERN here. */ + int c, c1; /* Points to the end of the buffer, where we should append. */ - register unsigned char *b; + unsigned char *b; /* Keeps track of unclosed groups. */ compile_stack_type compile_stack; /* Points to the current (ending) position in the pattern. */ -#ifdef AIX - /* `const' makes AIX compiler fail. */ - unsigned char *p = pattern; -#else re_char *p = pattern; -#endif re_char *pend = pattern + size; /* How to translate the characters in the pattern. */ - RE_TRANSLATE_TYPE translate = bufp->translate; + Lisp_Object translate = bufp->translate; - /* Address of the count-byte of the most recently inserted `exactn' + /* Address of the count-byte of the most recently inserted 'exactn' command. This makes it possible to tell if a new exact-match character can be added to that command or if the character requires - a new `exactn' command. */ + a new 'exactn' command. */ unsigned char *pending_exact = 0; /* Address of start of the most recently finished expression. @@ -2454,7 +1725,7 @@ regex_compile (const_re_char *pattern, size_t size, re_char *beg_interval; /* Address of the place where a forward jump should go to the end of - the containing expression. Each alternative of an `or' -- except the + the containing expression. Each alternative of an 'or' -- except the last -- ends with a forward jump of this sort. */ unsigned char *fixup_alt_jump = 0; @@ -2462,9 +1733,8 @@ regex_compile (const_re_char *pattern, size_t size, struct range_table_work_area range_table_work; /* If the object matched can contain multibyte characters. */ - const boolean multibyte = RE_MULTIBYTE_P (bufp); + bool multibyte = RE_MULTIBYTE_P (bufp); -#ifdef emacs /* Nonzero if we have pushed down into a subpattern. */ int in_subpattern = 0; @@ -2473,26 +1743,22 @@ regex_compile (const_re_char *pattern, size_t size, re_char *main_p; re_char *main_pattern; re_char *main_pend; -#endif -#ifdef DEBUG - debug++; +#ifdef REGEX_EMACS_DEBUG + regex_emacs_debug++; DEBUG_PRINT ("\nCompiling pattern: "); - if (debug > 0) + if (regex_emacs_debug > 0) { - unsigned debug_count; + size_t debug_count; for (debug_count = 0; debug_count < size; debug_count++) putchar (pattern[debug_count]); putchar ('\n'); } -#endif /* DEBUG */ +#endif /* Initialize the compile stack. */ compile_stack.stack = TALLOC (INIT_COMPILE_STACK_SIZE, compile_stack_elt_t); - if (compile_stack.stack == NULL) - return REG_ESPACE; - compile_stack.size = INIT_COMPILE_STACK_SIZE; compile_stack.avail = 0; @@ -2500,26 +1766,16 @@ regex_compile (const_re_char *pattern, size_t size, 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; - /* Set `used' to zero, so that if we return an error, the pattern + /* Set 'used' to zero, so that if we return an error, the pattern printer (for debugging) will think there's no pattern. We reset it at the end. */ bufp->used = 0; - /* Always count groups, whether or not bufp->no_sub is set. */ bufp->re_nsub = 0; -#if !defined emacs && !defined SYNTAX_TABLE - /* Initialize the syntax table. */ - init_syntax_once (); -#endif - if (bufp->allocated == 0) { if (bufp->buffer) @@ -2532,8 +1788,6 @@ regex_compile (const_re_char *pattern, size_t size, { /* Caller did not allocate a buffer. Do it for them. */ bufp->buffer = TALLOC (INIT_BUF_SIZE, unsigned char); } - if (!bufp->buffer) FREE_STACK_RETURN (REG_ESPACE); - bufp->allocated = INIT_BUF_SIZE; } @@ -2544,7 +1798,6 @@ regex_compile (const_re_char *pattern, size_t size, { 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,7 +1808,6 @@ regex_compile (const_re_char *pattern, size_t size, pend = main_pend; continue; } -#endif /* If this is the end of the main regexp, we are done. */ break; } @@ -2564,7 +1816,6 @@ regex_compile (const_re_char *pattern, size_t size, switch (c) { -#ifdef emacs case ' ': { re_char *p1 = p; @@ -2597,95 +1848,51 @@ regex_compile (const_re_char *pattern, size_t size, pend = p + strlen (whitespace_regexp); break; } -#endif case '^': - { - if ( /* If at start of pattern, it's an operator. */ - p == pattern + 1 - /* If context independent, it's an operator. */ - || syntax & RE_CONTEXT_INDEP_ANCHORS - /* Otherwise, depends on what's come before. */ - || at_begline_loc_p (pattern, p, syntax)) - BUF_PUSH ((syntax & RE_NO_NEWLINE_ANCHOR) ? begbuf : begline); - else - goto normal_char; - } + if (! (p == pattern + 1 || at_begline_loc_p (pattern, p))) + goto normal_char; + BUF_PUSH (begline); break; - case '$': - { - if ( /* If at end of pattern, it's an operator. */ - p == pend - /* If context independent, it's an operator. */ - || syntax & RE_CONTEXT_INDEP_ANCHORS - /* Otherwise, depends on what's next. */ - || at_endline_loc_p (p, pend, syntax)) - BUF_PUSH ((syntax & RE_NO_NEWLINE_ANCHOR) ? endbuf : endline); - else - goto normal_char; - } - break; + if (! (p == pend || at_endline_loc_p (p, pend))) + goto normal_char; + BUF_PUSH (endline); + break; case '+': case '?': - if ((syntax & RE_BK_PLUS_QM) - || (syntax & RE_LIMITED_OPS)) - goto normal_char; - FALLTHROUGH; case '*': - handle_plus: /* If there is no previous pattern... */ if (!laststart) - { - if (syntax & RE_CONTEXT_INVALID_OPS) - FREE_STACK_RETURN (REG_BADRPT); - else if (!(syntax & RE_CONTEXT_INDEP_OPS)) - goto normal_char; - } + goto normal_char; { /* 1 means zero (many) matches is allowed. */ - boolean zero_times_ok = 0, many_times_ok = 0; - boolean greedy = 1; + bool zero_times_ok = false, many_times_ok = false; + bool greedy = true; /* If there is a sequence of repetition chars, collapse it down to just one (the right one). We can't combine - interval operators with these because of, e.g., `a{2}*', - which should only match an even number of `a's. */ + interval operators with these because of, e.g., 'a{2}*', + which should only match an even number of 'a's. */ for (;;) { - if ((syntax & RE_FRUGAL) - && c == '?' && (zero_times_ok || many_times_ok)) - greedy = 0; + if (c == '?' && (zero_times_ok || many_times_ok)) + greedy = false; else { zero_times_ok |= c != '+'; many_times_ok |= c != '?'; } - if (p == pend) - break; - else if (*p == '*' - || (!(syntax & RE_BK_PLUS_QM) - && (*p == '+' || *p == '?'))) - ; - else if (syntax & RE_BK_PLUS_QM && *p == '\\') - { - if (p+1 == pend) - FREE_STACK_RETURN (REG_EESCAPE); - if (p[1] == '+' || p[1] == '?') - PATFETCH (c); /* Gobble up the backslash. */ - else - break; - } - else + if (! (p < pend && (*p == '*' || *p == '+' || *p == '?'))) break; /* If we get here, we found another repeat character. */ - PATFETCH (c); + c = *p++; } /* Star, etc. applied to an empty pattern is equivalent @@ -2699,25 +1906,25 @@ regex_compile (const_re_char *pattern, size_t size, { if (many_times_ok) { - boolean simple = skip_one_char (laststart) == b; + bool simple = skip_one_char (laststart) == b; size_t startoffset = 0; re_opcode_t ofj = /* Check if the loop can match the empty string. */ (simple || !analyze_first (laststart, b, NULL, 0)) ? on_failure_jump : on_failure_jump_loop; - assert (skip_one_char (laststart) <= b); + eassert (skip_one_char (laststart) <= b); if (!zero_times_ok && simple) { /* Since simple * loops can be made faster by using - on_failure_keep_string_jump, we turn simple P+ - into PP* if P is simple. */ - unsigned char *p1, *p2; - startoffset = b - laststart; - GET_BUFFER_SPACE (startoffset); - p1 = b; p2 = laststart; - while (p2 < p1) - *b++ = *p2++; - zero_times_ok = 1; + on_failure_keep_string_jump, we turn simple P+ + into PP* if P is simple. */ + unsigned char *p1, *p2; + startoffset = b - laststart; + GET_BUFFER_SPACE (startoffset); + p1 = b; p2 = laststart; + while (p2 < p1) + *b++ = *p2++; + zero_times_ok = 1; } GET_BUFFER_SPACE (6); @@ -2738,7 +1945,7 @@ regex_compile (const_re_char *pattern, size_t size, else { /* A simple ? pattern. */ - assert (zero_times_ok); + eassert (zero_times_ok); GET_BUFFER_SPACE (3); INSERT_JUMP (on_failure_jump, laststart, b + 3); b += 3; @@ -2750,7 +1957,7 @@ regex_compile (const_re_char *pattern, size_t size, GET_BUFFER_SPACE (7); /* We might use less. */ if (many_times_ok) { - boolean emptyp = analyze_first (laststart, b, NULL, 0); + bool emptyp = analyze_first (laststart, b, NULL, 0); /* The non-greedy multiple match looks like a repeat..until: we only need a conditional jump @@ -2802,8 +2009,8 @@ regex_compile (const_re_char *pattern, size_t size, laststart = b; - /* We test `*p == '^' twice, instead of using an if - statement, so we only need one BUF_PUSH. */ + /* Test '*p == '^' twice, instead of using an if + statement, so we need only one BUF_PUSH. */ BUF_PUSH (*p == '^' ? charset_not : charset); if (*p == '^') p++; @@ -2817,25 +2024,18 @@ regex_compile (const_re_char *pattern, size_t size, /* Clear the whole map. */ memset (b, 0, (1 << BYTEWIDTH) / BYTEWIDTH); - /* charset_not matches newline according to a syntax bit. */ - if ((re_opcode_t) b[-2] == charset_not - && (syntax & RE_HAT_LISTS_NOT_NEWLINE)) - SET_LIST_BIT ('\n'); - /* Read in characters and ranges, setting map bits. */ for (;;) { - boolean escaped_char = false; const unsigned char *p2 = p; - re_wctype_t cc; - re_wchar_t ch; + int 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) + re_wctype_t cc = re_wctype_parse (&p, pend - p); + if (cc != -1) { if (cc == 0) FREE_STACK_RETURN (REG_ECTYPE); @@ -2843,15 +2043,6 @@ regex_compile (const_re_char *pattern, size_t size, 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. @@ -2878,7 +2069,7 @@ regex_compile (const_re_char *pattern, size_t size, } 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 @@ -2896,60 +2087,33 @@ regex_compile (const_re_char *pattern, size_t size, (let ((case-fold-search t)) (string-match "[A-_]" "A")) */ PATFETCH (c); - /* \ might escape characters inside [...] and [^...]. */ - if ((syntax & RE_BACKSLASH_ESCAPE_IN_LISTS) && c == '\\') - { - if (p == pend) FREE_STACK_RETURN (REG_EESCAPE); - - PATFETCH (c); - escaped_char = true; - } - else - { - /* Could be the end of the bracket expression. If it's - not (i.e., when the bracket expression is `[]' so - far), the ']' character bit gets set way below. */ - if (c == ']' && p2 != p1) - break; - } + /* Could be the end of the bracket expression. If it's + not (i.e., when the bracket expression is '[]' so + far), the ']' character bit gets set way below. */ + if (c == ']' && p2 != p1) + break; if (p < pend && p[0] == '-' && p[1] != ']') { - /* Discard the `-'. */ + /* Discard the '-'. */ PATFETCH (c1); /* Fetch the character which ends the range. */ PATFETCH (c1); -#ifdef emacs + if (CHAR_BYTE8_P (c1) && ! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c)) /* Treat the range from a multibyte character to raw-byte character as empty. */ c = c1 + 1; -#endif /* emacs */ } else /* Range from C to C. */ c1 = c; - if (c > c1) + if (c <= c1) { - if (syntax & RE_NO_EMPTY_RANGES) - FREE_STACK_RETURN (REG_ERANGEX); - /* Else, repeat the loop. */ - } - else - { -#ifndef emacs - /* Set the range into bitmap */ - for (; c <= c1; c++) - { - ch = TRANSLATE (c); - if (ch < (1 << BYTEWIDTH)) - SET_LIST_BIT (ch); - } -#else /* emacs */ if (c < 128) { ch = min (127, c1); @@ -2958,25 +2122,17 @@ regex_compile (const_re_char *pattern, size_t size, if (CHAR_BYTE8_P (c1)) c = BYTE8_TO_CHAR (128); } - if (c <= c1) + if (CHAR_BYTE8_P (c)) { - if (CHAR_BYTE8_P (c)) - { - c = CHAR_TO_BYTE8 (c); - c1 = CHAR_TO_BYTE8 (c1); - for (; c <= c1; c++) - SET_LIST_BIT (c); - } - else if (multibyte) - { - SETUP_MULTIBYTE_RANGE (range_table_work, c, c1); - } - else - { - SETUP_UNIBYTE_RANGE (range_table_work, c, c1); - } + c = CHAR_TO_BYTE8 (c); + c1 = CHAR_TO_BYTE8 (c1); + for (; c <= c1; c++) + SET_LIST_BIT (c); } -#endif /* emacs */ + else if (multibyte) + SETUP_MULTIBYTE_RANGE (range_table_work, c, c1); + else + SETUP_UNIBYTE_RANGE (range_table_work, c, c1); } } @@ -3001,8 +2157,7 @@ regex_compile (const_re_char *pattern, size_t size, /* Indicate the existence of range table. */ laststart[1] |= 0x80; - /* Store the character class flag bits into the range table. - If not in emacs, these flag bits are always 0. */ + /* Store the character class flag bits into the range table. */ *b++ = RANGE_TABLE_WORK_BITS (range_table_work) & 0xff; *b++ = RANGE_TABLE_WORK_BITS (range_table_work) >> 8; @@ -3015,41 +2170,6 @@ regex_compile (const_re_char *pattern, size_t size, break; - case '(': - if (syntax & RE_NO_BK_PARENS) - goto handle_open; - else - goto normal_char; - - - case ')': - if (syntax & RE_NO_BK_PARENS) - goto handle_close; - else - goto normal_char; - - - case '\n': - if (syntax & RE_NEWLINE_ALT) - goto handle_alt; - else - goto normal_char; - - - case '|': - if (syntax & RE_NO_BK_VBAR) - goto handle_alt; - else - goto normal_char; - - - case '{': - if (syntax & RE_INTERVALS && syntax & RE_NO_BK_BRACES) - goto handle_interval; - else - goto normal_char; - - case '\\': if (p == pend) FREE_STACK_RETURN (REG_EESCAPE); @@ -3061,17 +2181,13 @@ regex_compile (const_re_char *pattern, size_t size, switch (c) { case '(': - if (syntax & RE_NO_BK_PARENS) - goto normal_backslash; - - handle_open: { int shy = 0; regnum_t regnum = 0; if (p+1 < pend) { /* Look for a special (?...) construct */ - if ((syntax & RE_SHY_GROUPS) && *p == '?') + if (*p == '?') { PATFETCH (c); /* Gobble up the '?'. */ while (!shy) @@ -3121,8 +2237,6 @@ regex_compile (const_re_char *pattern, size_t size, { RETALLOC (compile_stack.stack, compile_stack.size << 1, compile_stack_elt_t); - if (compile_stack.stack == NULL) return REG_ESPACE; - compile_stack.size <<= 1; } @@ -3154,35 +2268,22 @@ regex_compile (const_re_char *pattern, size_t size, } case ')': - if (syntax & RE_NO_BK_PARENS) goto normal_backslash; - if (COMPILE_STACK_EMPTY) - { - if (syntax & RE_UNMATCHED_RIGHT_PAREN_ORD) - goto normal_backslash; - else - FREE_STACK_RETURN (REG_ERPAREN); - } + FREE_STACK_RETURN (REG_ERPAREN); - handle_close: FIXUP_ALT_JUMP (); /* See similar code for backslashed left paren above. */ if (COMPILE_STACK_EMPTY) - { - if (syntax & RE_UNMATCHED_RIGHT_PAREN_ORD) - goto normal_char; - else - FREE_STACK_RETURN (REG_ERPAREN); - } + FREE_STACK_RETURN (REG_ERPAREN); /* Since we just checked for an empty stack above, this - ``can't happen''. */ - assert (compile_stack.avail != 0); + "can't happen". */ + eassert (compile_stack.avail != 0); { - /* We don't just want to restore into `regnum', because + /* We don't just want to restore into 'regnum', because later groups should continue to be numbered higher, - as in `(ab)c(de)' -- the second group is #2. */ + as in '(ab)c(de)' -- the second group is #2. */ regnum_t regnum; compile_stack.avail--; @@ -3206,13 +2307,7 @@ regex_compile (const_re_char *pattern, size_t size, break; - case '|': /* `\|'. */ - if (syntax & RE_LIMITED_OPS || syntax & RE_NO_BK_VBAR) - goto normal_backslash; - handle_alt: - if (syntax & RE_LIMITED_OPS) - goto normal_char; - + case '|': /* '\|'. */ /* Insert before the previous alternative a jump which jumps to this alternative if the former fails. */ GET_BUFFER_SPACE (3); @@ -3229,12 +2324,12 @@ regex_compile (const_re_char *pattern, size_t size, _____ _____ | | | | | v | v - a | b | c + A | B | C - If we are at `b', then fixup_alt_jump right now points to a - three-byte space after `a'. We'll put in the jump, set - fixup_alt_jump to right after `b', and leave behind three - bytes which we'll fill in when we get to after `c'. */ + If we are at B, then fixup_alt_jump right now points to a + three-byte space after A. We'll put in the jump, set + fixup_alt_jump to right after B, and leave behind three + bytes which we'll fill in when we get to after C. */ FIXUP_ALT_JUMP (); @@ -3251,17 +2346,7 @@ regex_compile (const_re_char *pattern, size_t size, case '{': - /* If \{ is a literal. */ - if (!(syntax & RE_INTERVALS) - /* If we're at `\{' and it's not the open-interval - operator. */ - || (syntax & RE_NO_BK_BRACES)) - goto normal_backslash; - - handle_interval: { - /* If got here, then the syntax allows intervals. */ - /* At least (most) this many matches must be made. */ int lower_bound = 0, upper_bound = -1; @@ -3272,37 +2357,23 @@ regex_compile (const_re_char *pattern, size_t size, if (c == ',') GET_INTERVAL_COUNT (upper_bound); else - /* Interval such as `{1}' => match exactly once. */ + /* Interval such as '{1}' => match exactly once. */ upper_bound = lower_bound; if (lower_bound < 0 - || (0 <= upper_bound && upper_bound < lower_bound)) + || (0 <= upper_bound && upper_bound < lower_bound) + || c != '\\') FREE_STACK_RETURN (REG_BADBR); - - if (!(syntax & RE_NO_BK_BRACES)) - { - if (c != '\\') - FREE_STACK_RETURN (REG_BADBR); - if (p == pend) - FREE_STACK_RETURN (REG_EESCAPE); - PATFETCH (c); - } - - if (c != '}') + if (p == pend) + FREE_STACK_RETURN (REG_EESCAPE); + if (*p++ != '}') FREE_STACK_RETURN (REG_BADBR); /* We just parsed a valid interval. */ /* If it's invalid to have no preceding re. */ if (!laststart) - { - if (syntax & RE_CONTEXT_INVALID_OPS) - FREE_STACK_RETURN (REG_BADRPT); - else if (syntax & RE_CONTEXT_INDEP_OPS) - laststart = b; - else - goto unfetch_interval; - } + goto unfetch_interval; if (upper_bound == 0) /* If the upper bound is zero, just drop the sub pattern @@ -3319,8 +2390,8 @@ regex_compile (const_re_char *pattern, size_t size, succeed_n <after jump addr> <succeed_n count> <body of loop> jump_n <succeed_n addr> <jump count> - (The upper bound and `jump_n' are omitted if - `upper_bound' is 1, though.) */ + (The upper bound and 'jump_n' are omitted if + 'upper_bound' is 1, though.) */ else { /* If the upper bound is > 1, we need to insert more at the end of the loop. */ @@ -3340,21 +2411,22 @@ regex_compile (const_re_char *pattern, size_t size, } else { - /* Initialize lower bound of the `succeed_n', even + /* Initialize lower bound of the 'succeed_n', even though it will be set during matching by its - attendant `set_number_at' (inserted next), - because `re_compile_fastmap' needs to know. - Jump to the `jump_n' we might insert below. */ + attendant 'set_number_at' (inserted next), + because 're_compile_fastmap' needs to know. + Jump to the 'jump_n' we might insert below. */ INSERT_JUMP2 (succeed_n, laststart, b + 5 + nbytes, lower_bound); b += 5; /* Code to initialize the lower bound. Insert - before the `succeed_n'. The `5' is the last two - bytes of this `set_number_at', plus 3 bytes of - the following `succeed_n'. */ - insert_op2 (set_number_at, laststart, 5, lower_bound, b); + before the 'succeed_n'. The '5' is the last two + bytes of this 'set_number_at', plus 3 bytes of + the following 'succeed_n'. */ + insert_op2 (set_number_at, laststart, 5, + lower_bound, b); b += 5; startoffset += 5; } @@ -3368,28 +2440,28 @@ regex_compile (const_re_char *pattern, size_t size, } else if (upper_bound > 1) { /* More than one repetition is allowed, so - append a backward jump to the `succeed_n' + append a backward jump to the 'succeed_n' that starts this interval. When we've reached this during matching, we'll have matched the interval once, so - jump back only `upper_bound - 1' times. */ + jump back only 'upper_bound - 1' times. */ STORE_JUMP2 (jump_n, b, laststart + startoffset, upper_bound - 1); b += 5; /* The location we want to set is the second - parameter of the `jump_n'; that is `b-2' as - an absolute address. `laststart' will be - the `set_number_at' we're about to insert; - `laststart+3' the number to set, the source + parameter of the 'jump_n'; that is 'b-2' as + an absolute address. 'laststart' will be + the 'set_number_at' we're about to insert; + 'laststart+3' the number to set, the source for the relative address. But we are inserting into the middle of the pattern -- so everything is getting moved up by 5. Conclusion: (b - 2) - (laststart + 3) + 5, i.e., b - laststart. - We insert this at the beginning of the loop + Insert this at the beginning of the loop so that if we fail during matching, we'll reinitialize the bounds. */ insert_op2 (set_number_at, laststart, b - laststart, @@ -3404,22 +2476,13 @@ regex_compile (const_re_char *pattern, size_t size, unfetch_interval: /* If an invalid interval, match the characters as literals. */ - assert (beg_interval); + eassert (beg_interval); p = beg_interval; beg_interval = NULL; - - /* normal_char and normal_backslash need `c'. */ + eassert (p > pattern && p[-1] == '\\'); c = '{'; + goto normal_char; - if (!(syntax & RE_NO_BK_BRACES)) - { - assert (p > pattern && p[-1] == '\\'); - goto normal_backslash; - } - else - goto normal_char; - -#ifdef emacs case '=': laststart = b; BUF_PUSH (at_dot); @@ -3448,42 +2511,30 @@ regex_compile (const_re_char *pattern, size_t size, PATFETCH (c); BUF_PUSH_2 (notcategoryspec, c); break; -#endif /* emacs */ - case 'w': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; laststart = b; BUF_PUSH_2 (syntaxspec, Sword); break; case 'W': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; laststart = b; BUF_PUSH_2 (notsyntaxspec, Sword); break; case '<': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; laststart = b; BUF_PUSH (wordbeg); break; case '>': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; laststart = b; BUF_PUSH (wordend); break; case '_': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; laststart = b; PATFETCH (c); if (c == '<') @@ -3495,38 +2546,25 @@ regex_compile (const_re_char *pattern, size_t size, break; case 'b': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; BUF_PUSH (wordbound); break; case 'B': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; BUF_PUSH (notwordbound); break; case '`': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; BUF_PUSH (begbuf); break; case '\'': - if (syntax & RE_NO_GNU_OPS) - goto normal_char; BUF_PUSH (endbuf); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - regnum_t reg; - - if (syntax & RE_NO_BK_REFS) - goto normal_backslash; - - reg = c - '0'; + regnum_t reg = c - '0'; if (reg > bufp->re_nsub || reg < 1 /* Can't back reference to a subexp before its end. */ @@ -3538,16 +2576,7 @@ regex_compile (const_re_char *pattern, size_t size, } break; - - case '+': - case '?': - if (syntax & RE_BK_PLUS_QM) - goto handle_plus; - else - goto normal_backslash; - default: - normal_backslash: /* You might think it would be useful for \ to mean not to translate; but if we don't translate it it will never match anything. */ @@ -3557,7 +2586,7 @@ regex_compile (const_re_char *pattern, size_t size, default: - /* Expects the character in `c'. */ + /* Expects the character in C. */ normal_char: /* If no exactn currently being built. */ if (!pending_exact @@ -3565,18 +2594,13 @@ regex_compile (const_re_char *pattern, size_t size, /* If last exactn not at current position. */ || pending_exact + *pending_exact + 1 != b - /* We have only one byte following the exactn for the count. */ + /* Only one byte follows the exactn for the count. */ || *pending_exact >= (1 << BYTEWIDTH) - MAX_MULTIBYTE_LENGTH /* If followed by a repetition operator. */ - || (p != pend && (*p == '*' || *p == '^')) - || ((syntax & RE_BK_PLUS_QM) - ? p + 1 < pend && *p == '\\' && (p[1] == '+' || p[1] == '?') - : p != pend && (*p == '+' || *p == '?')) - || ((syntax & RE_INTERVALS) - && ((syntax & RE_NO_BK_BRACES) - ? p != pend && *p == '{' - : p + 1 < pend && p[0] == '\\' && p[1] == '{'))) + || (p != pend + && (*p == '*' || *p == '+' || *p == '?' || *p == '^')) + || (p + 1 < pend && p[0] == '\\' && p[1] == '{')) { /* Start building a new exactn. */ @@ -3601,7 +2625,7 @@ regex_compile (const_re_char *pattern, size_t size, c1 = RE_CHAR_TO_MULTIBYTE (c); if (! CHAR_BYTE8_P (c1)) { - re_wchar_t c2 = TRANSLATE (c1); + int c2 = TRANSLATE (c1); if (c1 != c2 && (c1 = RE_CHAR_TO_UNIBYTE (c2)) >= 0) c = c1; @@ -3629,47 +2653,24 @@ regex_compile (const_re_char *pattern, size_t size, if (!posix_backtracking) BUF_PUSH (succeed); - /* We have succeeded; set the length of the buffer. */ + /* Success; set the length of the buffer. */ bufp->used = b - bufp->buffer; -#ifdef DEBUG - if (debug > 0) +#ifdef REGEX_EMACS_DEBUG + if (regex_emacs_debug > 0) { re_compile_fastmap (bufp); DEBUG_PRINT ("\nCompiled pattern: \n"); print_compiled_pattern (bufp); } - debug--; -#endif /* DEBUG */ - -#ifndef MATCH_MAY_ALLOCATE - /* Initialize the failure stack to the largest possible stack. This - isn't necessary unless we're trying to avoid calling alloca in - the search and match routines. */ - { - int num_regs = bufp->re_nsub + 1; - - if (fail_stack.size < emacs_re_max_failures * TYPICAL_FAILURE_SIZE) - { - fail_stack.size = emacs_re_max_failures * TYPICAL_FAILURE_SIZE; - falk_stack.stack = realloc (fail_stack.stack, - fail_stack.size * sizeof *falk_stack.stack); - } - - regex_grow_registers (num_regs); - } -#endif /* not MATCH_MAY_ALLOCATE */ + regex_emacs_debug--; +#endif FREE_STACK_RETURN (REG_NOERROR); -#ifdef emacs -# undef syntax -#else -# undef posix_backtracking -#endif } /* regex_compile */ -/* Subroutines for `regex_compile'. */ +/* Subroutines for 'regex_compile'. */ /* Store OP at LOC followed by two-byte integer parameter ARG. */ @@ -3681,7 +2682,7 @@ store_op1 (re_opcode_t op, unsigned char *loc, int arg) } -/* Like `store_op1', but for two two-byte parameters ARG1 and ARG2. */ +/* Like 'store_op1', but for two two-byte parameters ARG1 and ARG2. */ static void store_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2) @@ -3708,10 +2709,11 @@ insert_op1 (re_opcode_t op, unsigned char *loc, int arg, unsigned char *end) } -/* Like `insert_op1', but for two two-byte parameters ARG1 and ARG2. */ +/* Like 'insert_op1', but for two two-byte parameters ARG1 and ARG2. */ static void -insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, unsigned char *end) +insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, + unsigned char *end) { register unsigned char *pfrom = end; register unsigned char *pto = end + 5; @@ -3724,74 +2726,60 @@ insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, unsigned cha /* P points to just after a ^ in PATTERN. Return true if that ^ comes - after an alternative or a begin-subexpression. We assume there is at + after an alternative or a begin-subexpression. Assume there is at least one character before the ^. */ -static boolean -at_begline_loc_p (const_re_char *pattern, const_re_char *p, reg_syntax_t syntax) +static bool +at_begline_loc_p (re_char *pattern, re_char *p) { re_char *prev = p - 2; - boolean odd_backslashes; - - /* After a subexpression? */ - if (*prev == '(') - odd_backslashes = (syntax & RE_NO_BK_PARENS) == 0; - /* After an alternative? */ - else if (*prev == '|') - odd_backslashes = (syntax & RE_NO_BK_VBAR) == 0; - - /* After a shy subexpression? */ - else if (*prev == ':' && (syntax & RE_SHY_GROUPS)) + switch (*prev) { + case '(': /* After a subexpression. */ + case '|': /* After an alternative. */ + break; + + case ':': /* After a shy subexpression. */ /* Skip over optional regnum. */ - while (prev - 1 >= pattern && prev[-1] >= '0' && prev[-1] <= '9') + while (prev > pattern && '0' <= prev[-1] && prev[-1] <= '9') --prev; - if (!(prev - 2 >= pattern - && prev[-1] == '?' && prev[-2] == '(')) + if (! (prev > pattern + 1 && prev[-1] == '?' && prev[-2] == '(')) return false; prev -= 2; - odd_backslashes = (syntax & RE_NO_BK_PARENS) == 0; + break; + + default: + return false; } - else - return false; /* Count the number of preceding backslashes. */ p = prev; - while (prev - 1 >= pattern && prev[-1] == '\\') + while (prev > pattern && prev[-1] == '\\') --prev; - return (p - prev) & odd_backslashes; + return (p - prev) & 1; } -/* The dual of at_begline_loc_p. This one is for $. We assume there is - at least one character after the $, i.e., `P < PEND'. */ +/* The dual of at_begline_loc_p. This one is for $. Assume there is + at least one character after the $, i.e., 'P < PEND'. */ -static boolean -at_endline_loc_p (const_re_char *p, const_re_char *pend, reg_syntax_t syntax) +static bool +at_endline_loc_p (re_char *p, re_char *pend) { - re_char *next = p; - boolean next_backslash = *next == '\\'; - re_char *next_next = p + 1 < pend ? p + 1 : 0; - - return - /* Before a subexpression? */ - (syntax & RE_NO_BK_PARENS ? *next == ')' - : next_backslash && next_next && *next_next == ')') - /* Before an alternative? */ - || (syntax & RE_NO_BK_VBAR ? *next == '|' - : next_backslash && next_next && *next_next == '|'); + /* Before a subexpression or an alternative? */ + return *p == '\\' && p + 1 < pend && (p[1] == ')' || p[1] == '|'); } /* Returns true if REGNUM is in one of COMPILE_STACK's elements and false if it's not. */ -static boolean +static bool group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum) { - ssize_t this_element; + ptrdiff_t this_element; for (this_element = compile_stack.avail - 1; this_element >= 0; @@ -3813,39 +2801,39 @@ group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum) Return -1 if fastmap was not updated accurately. */ static int -analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, +analyze_first (re_char *p, re_char *pend, char *fastmap, const int multibyte) { int j, k; - boolean not; + bool not; /* If all elements for base leading-codes in fastmap is set, this flag is set true. */ - boolean match_any_multibyte_characters = false; + bool match_any_multibyte_characters = false; - assert (p); + eassert (p); /* The loop below works as follows: - It has a working-list kept in the PATTERN_STACK and which basically starts by only containing a pointer to the first operation. - If the opcode we're looking at is a match against some set of chars, then we add those chars to the fastmap and go on to the - next work element from the worklist (done via `break'). + next work element from the worklist (done via 'break'). - If the opcode is a control operator on the other hand, we either - ignore it (if it's meaningless at this point, such as `start_memory') + ignore it (if it's meaningless at this point, such as 'start_memory') or execute it (if it's a jump). If the jump has several destinations - (i.e. `on_failure_jump'), then we push the other destination onto the + (i.e. 'on_failure_jump'), then we push the other destination onto the worklist. We guarantee termination by ignoring backward jumps (more or less), - so that `p' is monotonically increasing. More to the point, we - never set `p' (or push) anything `<= p1'. */ + so that P is monotonically increasing. More to the point, we + never set P (or push) anything '<= p1'. */ while (p < pend) { - /* `p1' is used as a marker of how far back a `on_failure_jump' - can go without being ignored. It is normally equal to `p' - (which prevents any backward `on_failure_jump') except right - after a plain `jump', to allow patterns such as: + /* P1 is used as a marker of how far back a 'on_failure_jump' + can go without being ignored. It is normally equal to P + (which prevents any backward 'on_failure_jump') except right + after a plain 'jump', to allow patterns such as: 0: jump 10 3..9: <body> 10: on_failure_jump 3 @@ -3867,7 +2855,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, /* Following are the cases which match a character. These end - with `break'. */ + with 'break'. */ case exactn: if (fastmap) @@ -3914,7 +2902,6 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, if (!!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) ^ not) fastmap[j] = 1; -#ifdef emacs if (/* Any leading code can possibly start a character which doesn't match the specified set of characters. */ not @@ -3942,7 +2929,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, int c, count; unsigned char lc1, lc2; - /* Make P points the range table. `+ 2' is to skip flag + /* Make P points the range table. '+ 2' is to skip flag bits for a character class. */ p += CHARSET_BITMAP_SIZE (&p[-2]) + 2; @@ -3960,20 +2947,11 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, fastmap[j] = 1; } } -#endif break; case syntaxspec: case notsyntaxspec: if (!fastmap) break; -#ifndef emacs - not = (re_opcode_t)p[-1] == notsyntaxspec; - k = *p++; - for (j = 0; j < (1 << BYTEWIDTH); j++) - if ((SYNTAX (j) == (enum syntaxcode) k) ^ not) - fastmap[j] = 1; - break; -#else /* emacs */ /* This match depends on text properties. These end with aborting optimizations. */ return -1; @@ -3999,10 +2977,9 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, break; /* All cases after this match the empty string. These end with - `continue'. */ + 'continue'. */ case at_dot: -#endif /* !emacs */ case no_op: case begline: case endline: @@ -4021,7 +2998,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, EXTRACT_NUMBER_AND_INCR (j, p); if (j < 0) /* Backward jumps can only go back to code that we've already - visited. `re_compile' should make sure this is true. */ + visited. 're_compile' should make sure this is true. */ break; p += j; switch (*p) @@ -4036,7 +3013,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, default: continue; }; - /* Keep `p1' to allow the `on_failure_jump' we are jumping to + /* Keep P1 to allow the 'on_failure_jump' we are jumping to to jump back to "just after here". */ FALLTHROUGH; case on_failure_jump: @@ -4060,7 +3037,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, case jump_n: /* This code simply does not properly handle forward jump_n. */ - DEBUG_STATEMENT (EXTRACT_NUMBER (j, p); assert (j < 0)); + DEBUG_STATEMENT (EXTRACT_NUMBER (j, p); eassert (j < 0)); p += 4; /* jump_n can either jump or fall through. The (backward) jump case has already been handled, so we only need to look at the @@ -4069,7 +3046,7 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, case succeed_n: /* If N == 0, it should be an on_failure_jump_loop instead. */ - DEBUG_STATEMENT (EXTRACT_NUMBER (j, p + 2); assert (j > 0)); + DEBUG_STATEMENT (EXTRACT_NUMBER (j, p + 2); eassert (j > 0)); p += 4; /* We only care about one iteration of the loop, so we don't need to consider the case where this behaves like an @@ -4103,8 +3080,8 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, } /* analyze_first */ -/* re_compile_fastmap computes a ``fastmap'' for the compiled pattern in - BUFP. A fastmap records which of the (1 << BYTEWIDTH) possible +/* Compute a fastmap for the compiled pattern in BUFP. + A fastmap records which of the (1 << BYTEWIDTH) possible characters can start a string that matches the pattern. This fastmap is used by re_search to skip quickly over impossible starting points. @@ -4115,18 +3092,16 @@ analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, The caller must supply the address of a (1 << BYTEWIDTH)-byte data area as BUFP->fastmap. - We set the `fastmap', `fastmap_accurate', and `can_be_null' fields in - the pattern buffer. - - Returns 0 if we succeed, -2 if an internal error. */ + Set the 'fastmap', 'fastmap_accurate', and 'can_be_null' fields in + the pattern buffer. */ -int +static void re_compile_fastmap (struct re_pattern_buffer *bufp) { char *fastmap = bufp->fastmap; int analysis; - assert (fastmap && bufp->buffer); + eassert (fastmap && bufp->buffer); memset (fastmap, 0, 1 << BYTEWIDTH); /* Assume nothing's valid. */ bufp->fastmap_accurate = 1; /* It will be when we're done. */ @@ -4134,14 +3109,13 @@ re_compile_fastmap (struct re_pattern_buffer *bufp) analysis = analyze_first (bufp->buffer, bufp->buffer + bufp->used, fastmap, RE_MULTIBYTE_P (bufp)); bufp->can_be_null = (analysis != 0); - return 0; } /* re_compile_fastmap */ /* Set REGS to hold NUM_REGS registers, storing them in STARTS and ENDS. Subsequent matches using PATTERN_BUFFER and REGS will use this memory for recording register information. STARTS and ENDS must be allocated using the malloc library routine, and must each - be at least NUM_REGS * sizeof (regoff_t) bytes long. + be at least NUM_REGS * sizeof (ptrdiff_t) bytes long. If NUM_REGS == 0, then subsequent matches should allocate their own register data. @@ -4151,7 +3125,8 @@ re_compile_fastmap (struct re_pattern_buffer *bufp) freeing the old data. */ void -re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs, unsigned int num_regs, regoff_t *starts, regoff_t *ends) +re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs, + unsigned int num_regs, ptrdiff_t *starts, ptrdiff_t *ends) { if (num_regs) { @@ -4167,21 +3142,19 @@ re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs, uns regs->start = regs->end = 0; } } -WEAK_ALIAS (__re_set_registers, re_set_registers) /* Searching routines. */ /* Like re_search_2, below, but only one string is specified, and doesn't let you say where to stop matching. */ -regoff_t +ptrdiff_t re_search (struct re_pattern_buffer *bufp, const char *string, size_t size, - ssize_t startpos, ssize_t range, struct re_registers *regs) + ptrdiff_t startpos, ptrdiff_t range, struct re_registers *regs) { return re_search_2 (bufp, NULL, 0, string, size, startpos, range, regs, size); } -WEAK_ALIAS (__re_search, re_search) /* Head address of virtual concatenation of string. */ #define HEAD_ADDR_VSTRING(P) \ @@ -4208,25 +3181,26 @@ WEAK_ALIAS (__re_search, re_search) Do not consider matching one past the index STOP in the virtual concatenation of STRING1 and STRING2. - We return either the position in the strings at which the match was + Return either the position in the strings at which the match was found, -1 if no match, or -2 if error (such as failure stack overflow). */ -regoff_t +ptrdiff_t re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, - const char *str2, size_t size2, ssize_t startpos, ssize_t range, - struct re_registers *regs, ssize_t stop) + const char *str2, size_t size2, + ptrdiff_t startpos, ptrdiff_t range, + struct re_registers *regs, ptrdiff_t stop) { - regoff_t val; + ptrdiff_t val; re_char *string1 = (re_char *) str1; re_char *string2 = (re_char *) str2; - register char *fastmap = bufp->fastmap; - register RE_TRANSLATE_TYPE translate = bufp->translate; + char *fastmap = bufp->fastmap; + Lisp_Object translate = bufp->translate; size_t total_size = size1 + size2; - ssize_t endpos = startpos + range; - boolean anchored_start; + ptrdiff_t endpos = startpos + range; + bool anchored_start; /* Nonzero if we are searching multibyte string. */ - const boolean multibyte = RE_TARGET_MULTIBYTE_P (bufp); + bool multibyte = RE_TARGET_MULTIBYTE_P (bufp); /* Check for out-of-range STARTPOS. */ if (startpos < 0 || startpos > total_size) @@ -4250,7 +3224,6 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, range = 0; } -#ifdef emacs /* In a forward search for something that starts with \=. don't keep searching past point. */ if (bufp->used > 0 && (re_opcode_t) bufp->buffer[0] == at_dot && range > 0) @@ -4259,7 +3232,6 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, if (range < 0) return -1; } -#endif /* emacs */ /* Update the fastmap now if not correct already. */ if (fastmap && !bufp->fastmap_accurate) @@ -4268,21 +3240,19 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, /* See whether the pattern is anchored. */ anchored_start = (bufp->buffer[0] == begline); -#ifdef emacs gl_state.object = re_match_object; /* Used by SYNTAX_TABLE_BYTE_TO_CHAR. */ { - ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (startpos)); + ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (startpos)); SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, charpos, 1); } -#endif /* Loop through the string, looking for a place to start matching. */ for (;;) { /* If the pattern is anchored, skip quickly past places we cannot match. - We don't bother to treat startpos == 0 specially + Don't bother to treat startpos == 0 specially because that case doesn't repeat. */ if (anchored_start && startpos > 0) { @@ -4298,21 +3268,21 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, the first null string. */ if (fastmap && startpos < total_size && !bufp->can_be_null) { - register re_char *d; - register re_wchar_t buf_ch; + re_char *d; + int buf_ch; d = POS_ADDR_VSTRING (startpos); if (range > 0) /* Searching forwards. */ { - ssize_t irange = range, lim = 0; + ptrdiff_t irange = range, lim = 0; if (startpos < size1 && startpos + range >= size1) lim = range - (size1 - startpos); - /* Written out as an if-else to avoid testing `translate' + /* Written out as an if-else to avoid testing 'translate' inside the loop. */ - if (RE_TRANSLATE_P (translate)) + if (!NILP (translate)) { if (multibyte) while (range > lim) @@ -4330,11 +3300,9 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, else while (range > lim) { - register re_wchar_t ch, translated; - buf_ch = *d; - ch = RE_CHAR_TO_MULTIBYTE (buf_ch); - translated = RE_TRANSLATE (translate, ch); + int ch = RE_CHAR_TO_MULTIBYTE (buf_ch); + int translated = RE_TRANSLATE (translate, ch); if (translated != ch && (ch = RE_CHAR_TO_UNIBYTE (translated)) >= 0) buf_ch = ch; @@ -4377,11 +3345,9 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, } else { - register re_wchar_t ch, translated; - buf_ch = *d; - ch = RE_CHAR_TO_MULTIBYTE (buf_ch); - translated = TRANSLATE (ch); + int ch = RE_CHAR_TO_MULTIBYTE (buf_ch); + int translated = TRANSLATE (ch); if (translated != ch && (ch = RE_CHAR_TO_UNIBYTE (translated)) >= 0) buf_ch = ch; @@ -4451,17 +3417,16 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, size_t size1, } return -1; } /* re_search_2 */ -WEAK_ALIAS (__re_search_2, re_search_2) /* Declarations and macros for re_match_2. */ static int bcmp_translate (re_char *s1, re_char *s2, - register ssize_t len, - RE_TRANSLATE_TYPE translate, + ptrdiff_t len, + Lisp_Object translate, const int multibyte); -/* This converts PTR, a pointer into one of the search strings `string1' - and `string2' into an offset from the beginning of that string. */ +/* This converts PTR, a pointer into one of the search strings 'string1' + and 'string2' into an offset from the beginning of that string. */ #define POINTER_TO_OFFSET(ptr) \ (FIRST_STRING_P (ptr) \ ? (ptr) - string1 \ @@ -4485,7 +3450,7 @@ static int bcmp_translate (re_char *s1, re_char *s2, /* Call before fetching a char with *d if you already checked other limits. This is meant for use in lookahead operations like wordend, etc.. where we might need to look at parts of the string that might be - outside of the LIMITs (i.e past `stop'). */ + outside of the LIMITs (i.e past 'stop'). */ #define PREFETCH_NOLIMIT() \ if (d == end1) \ { \ @@ -4494,7 +3459,7 @@ static int bcmp_translate (re_char *s1, re_char *s2, } \ /* Test if at very beginning or at very end of the virtual concatenation - of `string1' and `string2'. If only one string, it's `string2'. */ + of STRING1 and STRING2. If only one string, it's STRING2. */ #define AT_STRINGS_BEG(d) ((d) == (size1 ? string1 : string2) || !size2) #define AT_STRINGS_END(d) ((d) == end2) @@ -4525,36 +3490,13 @@ static int bcmp_translate (re_char *s1, re_char *s2, || WORDCHAR_P (d - 1) != WORDCHAR_P (d)) #endif -/* Free everything we malloc. */ -#ifdef MATCH_MAY_ALLOCATE -# define FREE_VAR(var) \ - do { \ - if (var) \ - { \ - REGEX_FREE (var); \ - var = NULL; \ - } \ - } while (0) -# define FREE_VARIABLES() \ - do { \ - REGEX_FREE_STACK (fail_stack.stack); \ - FREE_VAR (regstart); \ - FREE_VAR (regend); \ - FREE_VAR (best_regstart); \ - FREE_VAR (best_regend); \ - REGEX_SAFE_FREE (); \ - } while (0) -#else -# define FREE_VARIABLES() ((void)0) /* Do nothing! But inhibit gcc warning. */ -#endif /* not MATCH_MAY_ALLOCATE */ - /* Optimization routines. */ /* If the operation is a match against one or more chars, return a pointer to the next operation, else return NULL. */ static re_char * -skip_one_char (const_re_char *p) +skip_one_char (re_char *p) { switch (*p++) { @@ -4580,10 +3522,8 @@ skip_one_char (const_re_char *p) case syntaxspec: case notsyntaxspec: -#ifdef emacs case categoryspec: case notcategoryspec: -#endif /* emacs */ p++; break; @@ -4596,7 +3536,7 @@ skip_one_char (const_re_char *p) /* Jump over non-matching operations. */ static re_char * -skip_noops (const_re_char *p, const_re_char *pend) +skip_noops (re_char *p, re_char *pend) { int mcnt; while (p < pend) @@ -4617,7 +3557,7 @@ skip_noops (const_re_char *p, const_re_char *pend) return p; } } - assert (p == pend); + eassert (p == pend); return p; } @@ -4627,7 +3567,7 @@ skip_noops (const_re_char *p, const_re_char *pend) 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) +execute_charset (re_char **pp, unsigned c, unsigned corig, bool unibyte) { re_char *p = *pp, *rtp = NULL; bool not = (re_opcode_t) *p == charset_not; @@ -4644,17 +3584,16 @@ execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte) if (unibyte && c < (1 << BYTEWIDTH)) { /* Lookup bitmap. */ - /* Cast to `unsigned' instead of `unsigned char' in + /* 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; + int 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 @@ -4685,21 +3624,21 @@ execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte) 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, - const_re_char *p2) +mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1, + re_char *p2) { re_opcode_t op2; - const boolean multibyte = RE_MULTIBYTE_P (bufp); + bool multibyte = RE_MULTIBYTE_P (bufp); unsigned char *pend = bufp->buffer + bufp->used; - assert (p1 >= bufp->buffer && p1 < pend - && p2 >= bufp->buffer && p2 <= pend); + eassert (p1 >= bufp->buffer && p1 < pend + && p2 >= bufp->buffer && p2 <= pend); /* Skip over open/close-group commands. If what follows this loop is a ...+ construct, @@ -4710,8 +3649,8 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, is only used in the case where p1 is a simple match operator. */ /* p1 = skip_noops (p1, pend); */ - assert (p1 >= bufp->buffer && p1 < pend - && p2 >= bufp->buffer && p2 <= pend); + eassert (p1 >= bufp->buffer && p1 < pend + && p2 >= bufp->buffer && p2 <= pend); op2 = p2 == pend ? succeed : *p2; @@ -4730,7 +3669,7 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, case endline: case exactn: { - register re_wchar_t c + int c = (re_opcode_t) *p2 == endline ? '\n' : RE_STRING_CHAR (p2 + 2, multibyte); @@ -4746,7 +3685,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) { - if (!execute_charset (&p1, c, c, !multibyte || IS_REAL_ASCII (c))) + if (!execute_charset (&p1, c, c, !multibyte || ASCII_CHAR_P (c))) { DEBUG_PRINT (" No match => fast loop.\n"); return 1; @@ -4773,10 +3712,10 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, else if (!multibyte || !CHARSET_RANGE_TABLE_EXISTS_P (p2)) { /* Now, we are sure that P2 has no range table. - So, for the size of bitmap in P2, `p2[1]' is + So, for the size of bitmap in P2, 'p2[1]' is enough. But P1 may have range table, so the size of bitmap table of P1 is extracted by - using macro `CHARSET_BITMAP_SIZE'. + using macro 'CHARSET_BITMAP_SIZE'. In a multibyte case, we know that all the character listed in P2 is ASCII. In a unibyte case, P1 has only a @@ -4860,12 +3799,10 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, || (re_opcode_t) *p1 == syntaxspec) && p1[1] == Sword); -#ifdef emacs case categoryspec: return ((re_opcode_t) *p1 == notcategoryspec && p1[1] == p2[1]); case notcategoryspec: return ((re_opcode_t) *p1 == categoryspec && p1[1] == p2[1]); -#endif /* emacs */ default: ; @@ -4878,61 +3815,43 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, /* Matching routines. */ -#ifndef emacs /* Emacs never uses this. */ -/* re_match is like re_match_2 except it takes only a single string. */ - -regoff_t -re_match (struct re_pattern_buffer *bufp, const char *string, - size_t size, ssize_t pos, struct re_registers *regs) -{ - regoff_t result = re_match_2_internal (bufp, NULL, 0, (re_char *) string, - size, pos, regs, size); - return result; -} -WEAK_ALIAS (__re_match, re_match) -#endif /* not emacs */ - /* 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 matching at STOP. - If REGS is non-null and the `no_sub' field of BUFP is nonzero, we - store offsets for the substring each group matched in REGS. See the - documentation for exactly how many groups we fill. + If REGS is non-null, store offsets for the substring each group + matched in REGS. We return -1 if no match, -2 if an internal error (such as the failure stack overflowing). Otherwise, we return the length of the matched substring. */ -regoff_t +ptrdiff_t re_match_2 (struct re_pattern_buffer *bufp, const char *string1, - size_t size1, const char *string2, size_t size2, ssize_t pos, - struct re_registers *regs, ssize_t stop) + size_t size1, const char *string2, size_t size2, ptrdiff_t pos, + struct re_registers *regs, ptrdiff_t stop) { - regoff_t result; + ptrdiff_t result; -#ifdef emacs - ssize_t charpos; + ptrdiff_t charpos; gl_state.object = re_match_object; /* Used by SYNTAX_TABLE_BYTE_TO_CHAR. */ charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (pos)); SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, charpos, 1); -#endif result = re_match_2_internal (bufp, (re_char *) string1, size1, (re_char *) string2, size2, pos, regs, stop); return result; } -WEAK_ALIAS (__re_match_2, re_match_2) /* This is a separate function so that we can force an alloca cleanup afterwards. */ -static regoff_t -re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, - size_t size1, const_re_char *string2, size_t size2, - ssize_t pos, struct re_registers *regs, ssize_t stop) +static ptrdiff_t +re_match_2_internal (struct re_pattern_buffer *bufp, re_char *string1, + size_t size1, re_char *string2, size_t size2, + ptrdiff_t pos, struct re_registers *regs, ptrdiff_t stop) { /* General temporaries. */ int mcnt; @@ -4959,13 +3878,13 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, re_char *pend = p + bufp->used; /* We use this to map every character in the string. */ - RE_TRANSLATE_TYPE translate = bufp->translate; + Lisp_Object translate = bufp->translate; - /* Nonzero if BUFP is setup from a multibyte regex. */ - const boolean multibyte = RE_MULTIBYTE_P (bufp); + /* True if BUFP is setup from a multibyte regex. */ + bool multibyte = RE_MULTIBYTE_P (bufp); - /* Nonzero if STRING1/STRING2 are multibyte. */ - const boolean target_multibyte = RE_TARGET_MULTIBYTE_P (bufp); + /* True if STRING1/STRING2 are multibyte. */ + bool target_multibyte = RE_TARGET_MULTIBYTE_P (bufp); /* Failure point stack. Each place that can handle a failure further down the line pushes a failure point on this stack. It consists of @@ -4974,19 +3893,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, registers, and, finally, two char *'s. The first char * is where to resume scanning the pattern; the second one is where to resume scanning the strings. */ -#ifdef MATCH_MAY_ALLOCATE /* otherwise, this is global. */ fail_stack_type fail_stack; -#endif #ifdef DEBUG_COMPILES_ARGUMENTS unsigned nfailure_points_pushed = 0, nfailure_points_popped = 0; #endif -#if defined REL_ALLOC && defined REGEX_MALLOC - /* This holds the pointer to the failure stack, when - it is allocated relocatably. */ - fail_stack_elt_t *failure_stack_ptr; -#endif - /* We fill all the registers internally, independent of what we return, for use in backreferences. The number here includes an element for register zero. */ @@ -4999,24 +3910,20 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, matching and the regnum-th regend points to right after where we stopped matching the regnum-th subexpression. (The zeroth register keeps track of what the whole pattern matches.) */ -#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */ - re_char **regstart, **regend; -#endif + re_char **regstart UNINIT, **regend UNINIT; /* The following record the register info as found in the above variables when we find a match better than any we've seen before. This happens as we backtrack through the failure points, which in turn happens only if we have not yet matched the entire string. */ unsigned best_regs_set = false; -#ifdef MATCH_MAY_ALLOCATE /* otherwise, these are global. */ - re_char **best_regstart, **best_regend; -#endif + re_char **best_regstart UNINIT, **best_regend UNINIT; - /* Logically, this is `best_regend[0]'. But we don't want to have to + /* Logically, this is 'best_regend[0]'. But we don't want to have to allocate space for that if we're not allocating space for anything else (see below). Also, we never need info about register 0 for any of the other register vectors, and it seems rather a kludge to - treat `best_regend' differently than the rest. So we keep track of + treat 'best_regend' differently than the rest. So we keep track of the end of the best match so far in a separate variable. We initialize this to NULL so that when we backtrack the first time and need to test it, it's not garbage. */ @@ -5033,7 +3940,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, INIT_FAIL_STACK (); -#ifdef MATCH_MAY_ALLOCATE /* Do not bother to initialize all the register variables if there are no groups in the pattern, as it takes a fair amount of time. If there are groups, we include space for register 0 (the whole @@ -5041,29 +3947,16 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, array indexing. We should fix this. */ if (bufp->re_nsub) { - regstart = REGEX_TALLOC (num_regs, re_char *); - regend = REGEX_TALLOC (num_regs, re_char *); - best_regstart = REGEX_TALLOC (num_regs, re_char *); - best_regend = REGEX_TALLOC (num_regs, re_char *); - - if (!(regstart && regend && best_regstart && best_regend)) - { - FREE_VARIABLES (); - return -2; - } + regstart = SAFE_ALLOCA (num_regs * 4 * sizeof *regstart); + regend = regstart + num_regs; + best_regstart = regend + num_regs; + best_regend = best_regstart + num_regs; } - else - { - /* We must initialize all our variables to NULL, so that - `FREE_VARIABLES' doesn't try to free them. */ - regstart = regend = best_regstart = best_regend = NULL; - } -#endif /* MATCH_MAY_ALLOCATE */ /* The starting position is bogus. */ if (pos < 0 || pos > size1 + size2) { - FREE_VARIABLES (); + SAFE_FREE (); return -1; } @@ -5073,8 +3966,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, for (reg = 1; reg < num_regs; reg++) regstart[reg] = regend[reg] = NULL; - /* We move `string1' into `string2' if the latter's empty -- but not if - `string1' is null. */ + /* We move 'string1' into 'string2' if the latter's empty -- but not if + 'string1' is null. */ if (size2 == 0 && string1 != NULL) { string2 = string1; @@ -5085,12 +3978,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, end1 = string1 + size1; end2 = string2 + size2; - /* `p' scans through the pattern as `d' scans through the data. - `dend' is the end of the input string that `d' points within. `d' - is advanced into the following input string whenever necessary, but + /* P scans through the pattern as D scans through the data. + DEND is the end of the input string that D points within. + Advance D into the following input string whenever necessary, but this happens before fetching; therefore, at the beginning of the - loop, `d' can be pointing at the end of a string, but it cannot - equal `string2'. */ + loop, D can be pointing at the end of a string, but it cannot + equal STRING2. */ if (pos >= size1) { /* Only match within string2. */ @@ -5107,7 +4000,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* BEWARE! When we reach end_match_1, PREFETCH normally switches to string2. But in the present case, this means that just doing a PREFETCH - makes us jump from `stop' to `gap' within the string. + makes us jump from 'stop' to 'gap' within the string. What we really want here is for the search to stop as soon as we hit end_match_1. That's why we set end_match_2 to end_match_1 (since PREFETCH fails as soon as we hit @@ -5115,8 +4008,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, end_match_2 = end_match_1; } else - { /* It's important to use this code when stop == size so that - moving `d' from end1 to string2 will not prevent the d == dend + { /* It's important to use this code when STOP == SIZE so that + moving D from end1 to string2 will not prevent the D == DEND check from catching the end of string. */ end_match_1 = end1; end_match_2 = string2 + stop - size1; @@ -5192,10 +4085,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, else if (best_regs_set && !best_match_p) { restore_best_regs: - /* Restore best match. It may happen that `dend == + /* Restore best match. It may happen that 'dend == end_match_1' while the restored d is in string2. - For example, the pattern `x.*y.*z' against the - strings `x-' and `y-z-', if the two strings are + For example, the pattern 'x.*y.*z' against the + strings 'x-' and 'y-z-', if the two strings are not consecutive in memory. */ DEBUG_PRINT ("Restoring best registers.\n"); @@ -5215,21 +4108,16 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, DEBUG_PRINT ("Accepting match.\n"); /* If caller wants register contents data back, do it. */ - if (regs && !bufp->no_sub) + if (regs) { /* Have the register data arrays been allocated? */ if (bufp->regs_allocated == REGS_UNALLOCATED) { /* No. So allocate them with malloc. We need one - extra element beyond `num_regs' for the `-1' marker + extra element beyond 'num_regs' for the '-1' marker GNU code uses. */ regs->num_regs = max (RE_NREGS, num_regs + 1); - regs->start = TALLOC (regs->num_regs, regoff_t); - regs->end = TALLOC (regs->num_regs, regoff_t); - if (regs->start == NULL || regs->end == NULL) - { - FREE_VARIABLES (); - return -2; - } + regs->start = TALLOC (regs->num_regs, ptrdiff_t); + regs->end = TALLOC (regs->num_regs, ptrdiff_t); bufp->regs_allocated = REGS_REALLOCATE; } else if (bufp->regs_allocated == REGS_REALLOCATE) @@ -5239,23 +4127,14 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, if (regs->num_regs < num_regs + 1) { regs->num_regs = num_regs + 1; - RETALLOC (regs->start, regs->num_regs, regoff_t); - RETALLOC (regs->end, regs->num_regs, regoff_t); - if (regs->start == NULL || regs->end == NULL) - { - FREE_VARIABLES (); - return -2; - } + RETALLOC (regs->start, regs->num_regs, ptrdiff_t); + RETALLOC (regs->end, regs->num_regs, ptrdiff_t); } } else - { - /* These braces fend off a "empty body in an else-statement" - warning under GCC when assert expands to nothing. */ - assert (bufp->regs_allocated == REGS_FIXED); - } + eassert (bufp->regs_allocated == REGS_FIXED); - /* Convert the pointer data in `regstart' and `regend' to + /* Convert the pointer data in 'regstart' and 'regend' to indices. Register zero has to be set differently, since we haven't kept track of any info for it. */ if (regs->num_regs > 0) @@ -5264,7 +4143,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, regs->end[0] = POINTER_TO_OFFSET (d); } - /* Go through the first `min (num_regs, regs->num_regs)' + /* Go through the first 'min (num_regs, regs->num_regs)' registers, since that is all we initialized. */ for (reg = 1; reg < min (num_regs, regs->num_regs); reg++) { @@ -5284,7 +4163,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, -1 at the end. */ for (reg = num_regs; reg < regs->num_regs; reg++) regs->start[reg] = regs->end[reg] = -1; - } /* regs && !bufp->no_sub */ + } DEBUG_PRINT ("%u failure points pushed, %u popped (%u remain).\n", nfailure_points_pushed, nfailure_points_popped, @@ -5295,7 +4174,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, DEBUG_PRINT ("Returning %td from re_match_2.\n", dcnt); - FREE_VARIABLES (); + SAFE_FREE (); return dcnt; } @@ -5322,34 +4201,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* Remember the start point to rollback upon failure. */ dfail = d; -#ifndef emacs - /* This is written out as an if-else so we don't waste time - testing `translate' inside the loop. */ - if (RE_TRANSLATE_P (translate)) - do - { - PREFETCH (); - if (RE_TRANSLATE (translate, *d) != *p++) - { - d = dfail; - goto fail; - } - d++; - } - while (--mcnt); - else - do - { - PREFETCH (); - if (*d++ != *p++) - { - d = dfail; - goto fail; - } - } - while (--mcnt); -#else /* emacs */ - /* The cost of testing `translate' is comparatively small. */ + /* The cost of testing 'translate' is comparatively small. */ if (target_multibyte) do { @@ -5413,16 +4265,15 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, d++; } while (--mcnt); -#endif + break; - /* Match any character except possibly a newline or a null. */ + /* Match any character except newline. */ case anychar: { int buf_charlen; - re_wchar_t buf_ch; - reg_syntax_t syntax; + int buf_ch; DEBUG_PRINT ("EXECUTING anychar.\n"); @@ -5430,15 +4281,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, buf_ch = RE_STRING_CHAR_AND_LENGTH (d, buf_charlen, target_multibyte); buf_ch = TRANSLATE (buf_ch); - -#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')) + if (buf_ch == '\n') goto fail; DEBUG_PRINT (" Matched \"%d\".\n", *d); @@ -5454,7 +4297,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, int len; /* Whether matching against a unibyte character. */ - boolean unibyte_char = false; + bool unibyte_char = false; DEBUG_PRINT ("EXECUTING charset%s.\n", (re_opcode_t) *(p - 1) == charset_not ? "_not" : ""); @@ -5524,10 +4367,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, case stop_memory: DEBUG_PRINT ("EXECUTING stop_memory %d:\n", *p); - assert (!REG_UNSET (regstart[*p])); + eassert (!REG_UNSET (regstart[*p])); /* Strictly speaking, there should be code such as: - assert (REG_UNSET (regend[*p])); + eassert (REG_UNSET (regend[*p])); PUSH_FAILURE_REGSTOP ((unsigned int)*p); But the only info to be pushed is regend[*p] and it is known to @@ -5547,11 +4390,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, break; - /* \<digit> has been turned into a `duplicate' command which is + /* \<digit> has been turned into a 'duplicate' command which is followed by the numeric value of <digit> as the register number. */ case duplicate: { - register re_char *d2, *dend2; + re_char *d2, *dend2; int regno = *p++; /* Get which register to match against. */ DEBUG_PRINT ("EXECUTING duplicate %d.\n", regno); @@ -5604,7 +4447,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* Compare that many; failure if mismatch, else move past them. */ - if (RE_TRANSLATE_P (translate) + if (!NILP (translate) ? bcmp_translate (d, d2, dcnt, translate, target_multibyte) : memcmp (d, d2, dcnt)) { @@ -5617,15 +4460,13 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, break; - /* begline matches the empty string at the beginning of the string - (unless `not_bol' is set in `bufp'), and after newlines. */ + /* begline matches the empty string at the beginning of the string, + and after newlines. */ case begline: DEBUG_PRINT ("EXECUTING begline.\n"); if (AT_STRINGS_BEG (d)) - { - if (!bufp->not_bol) break; - } + break; else { unsigned c; @@ -5633,7 +4474,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, if (c == '\n') break; } - /* In all other cases, we fail. */ goto fail; @@ -5642,15 +4482,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, DEBUG_PRINT ("EXECUTING endline.\n"); if (AT_STRINGS_END (d)) - { - if (!bufp->not_eol) break; - } - else - { - PREFETCH_NOLIMIT (); - if (*d == '\n') - break; - } + break; + PREFETCH_NOLIMIT (); + if (*d == '\n') + break; goto fail; @@ -5670,21 +4505,21 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, goto fail; - /* on_failure_keep_string_jump is used to optimize `.*\n'. It + /* on_failure_keep_string_jump is used to optimize '.*\n'. It pushes NULL as the value for the string on the stack. Then - `POP_FAILURE_POINT' will keep the current value for the + 'POP_FAILURE_POINT' will keep the current value for the string, instead of restoring it. To see why, consider - matching `foo\nbar' against `.*\n'. The .* matches the foo; + matching 'foo\nbar' against '.*\n'. The .* matches the foo; then the . fails against the \n. But the next thing we want to do is match the \n against the \n; if we restored the string value, we would be back at the foo. Because this is used only in specific cases, we don't need to - check all the things that `on_failure_jump' does, to make + check all the things that 'on_failure_jump' does, to make sure the right things get saved on the stack. Hence we don't share its code. The only reason to push anything on the stack at all is that otherwise we would have to change - `anychar's code to do something besides goto fail in this + 'anychar's code to do something besides goto fail in this case; that seems worse than this. */ case on_failure_keep_string_jump: EXTRACT_NUMBER_AND_INCR (mcnt, p); @@ -5713,7 +4548,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, DEBUG_PRINT ("EXECUTING on_failure_jump_nastyloop %d (to %p):\n", mcnt, p + mcnt); - assert ((re_opcode_t)p[-4] == no_op); + eassert ((re_opcode_t)p[-4] == no_op); { int cycle = 0; CHECK_INFINITE_LOOP (p - 4, d); @@ -5738,7 +4573,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, CHECK_INFINITE_LOOP (p - 3, d); if (cycle) /* If there's a cycle, get out of the loop, as if the matching - had failed. We used to just `goto fail' here, but that was + had failed. We used to just 'goto fail' here, but that was aborting the search a bit too early: we want to keep the empty-loop-match and keep matching after the loop. We want (x?)*y\1z to match both xxyz and xxyxz. */ @@ -5773,7 +4608,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, Compare the beginning of the repeat with what in the pattern follows its end. If we can establish that there is nothing that they would both match, i.e., that we - would have to backtrack because of (as in, e.g., `a*a') + would have to backtrack because of (as in, e.g., 'a*a') then we can use a non-backtracking loop based on on_failure_keep_string_jump instead of on_failure_jump. */ case on_failure_jump_smart: @@ -5782,7 +4617,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, mcnt, p + mcnt); { re_char *p1 = p; /* Next operation. */ - /* Here, we discard `const', making re_match non-reentrant. */ + /* Discard 'const', making re_search non-reentrant. */ unsigned char *p2 = (unsigned char *) p + mcnt; /* Jump dest. */ unsigned char *p3 = (unsigned char *) p - 3; /* opcode location. */ @@ -5793,23 +4628,23 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* Ensure this is indeed the trivial kind of loop we are expecting. */ - assert (skip_one_char (p1) == p2 - 3); - assert ((re_opcode_t) p2[-3] == jump && p2 + mcnt == p); - DEBUG_STATEMENT (debug += 2); + eassert (skip_one_char (p1) == p2 - 3); + eassert ((re_opcode_t) p2[-3] == jump && p2 + mcnt == p); + DEBUG_STATEMENT (regex_emacs_debug += 2); if (mutually_exclusive_p (bufp, p1, p2)) { - /* Use a fast `on_failure_keep_string_jump' loop. */ + /* Use a fast 'on_failure_keep_string_jump' loop. */ DEBUG_PRINT (" smart exclusive => fast loop.\n"); *p3 = (unsigned char) on_failure_keep_string_jump; STORE_NUMBER (p2 - 2, mcnt + 3); } else { - /* Default to a safe `on_failure_jump' loop. */ + /* Default to a safe 'on_failure_jump' loop. */ DEBUG_PRINT (" smart default => slow loop.\n"); *p3 = (unsigned char) on_failure_jump; } - DEBUG_STATEMENT (debug -= 2); + DEBUG_STATEMENT (regex_emacs_debug -= 2); } break; @@ -5825,7 +4660,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* Have to succeed matching what follows at least n times. - After that, handle like `on_failure_jump'. */ + After that, handle like 'on_failure_jump'. */ case succeed_n: /* Signedness doesn't matter since we only compare MCNT to 0. */ EXTRACT_NUMBER (mcnt, p + 2); @@ -5834,7 +4669,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* Originally, mcnt is how many times we HAVE to succeed. */ if (mcnt != 0) { - /* Here, we discard `const', making re_match non-reentrant. */ + /* Discard 'const', making re_search non-reentrant. */ unsigned char *p2 = (unsigned char *) p + 2; /* counter loc. */ mcnt--; p += 4; @@ -5853,7 +4688,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, /* Originally, this is how many times we CAN jump. */ if (mcnt != 0) { - /* Here, we discard `const', making re_match non-reentrant. */ + /* Discard 'const', making re_search non-reentrant. */ unsigned char *p2 = (unsigned char *) p + 2; /* counter loc. */ mcnt--; PUSH_NUMBER (p2, mcnt); @@ -5870,7 +4705,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, DEBUG_PRINT ("EXECUTING set_number_at.\n"); EXTRACT_NUMBER_AND_INCR (mcnt, p); - /* Here, we discard `const', making re_match non-reentrant. */ + /* Discard 'const', making re_search non-reentrant. */ p2 = (unsigned char *) p + mcnt; /* Signedness doesn't matter since we only copy MCNT's bits. */ EXTRACT_NUMBER_AND_INCR (mcnt, p); @@ -5882,7 +4717,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, case wordbound: case notwordbound: { - boolean not = (re_opcode_t) *(p - 1) == notwordbound; + bool not = (re_opcode_t) *(p - 1) == notwordbound; DEBUG_PRINT ("EXECUTING %swordbound.\n", not ? "not" : ""); /* We SUCCEED (or FAIL) in one of the following cases: */ @@ -5894,19 +4729,15 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { /* C1 is the character before D, S1 is the syntax of C1, C2 is the character at D, and S2 is the syntax of C2. */ - re_wchar_t c1, c2; + int c1, c2; int s1, s2; int dummy; -#ifdef emacs - ssize_t offset = PTR_TO_OFFSET (d - 1); - ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); - UPDATE_SYNTAX_TABLE_FAST (charpos); -#endif + ptrdiff_t offset = PTR_TO_OFFSET (d - 1); + ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); + UPDATE_SYNTAX_TABLE (charpos); GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2); s1 = SYNTAX (c1); -#ifdef emacs - UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos + 1); -#endif + UPDATE_SYNTAX_TABLE_FORWARD (charpos + 1); PREFETCH_NOLIMIT (); GET_CHAR_AFTER (c2, d, dummy); s2 = SYNTAX (c2); @@ -5936,14 +4767,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { /* C1 is the character before D, S1 is the syntax of C1, C2 is the character at D, and S2 is the syntax of C2. */ - re_wchar_t c1, c2; + int c1, c2; int s1, s2; int dummy; -#ifdef emacs - ssize_t offset = PTR_TO_OFFSET (d); - ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); - UPDATE_SYNTAX_TABLE_FAST (charpos); -#endif + ptrdiff_t offset = PTR_TO_OFFSET (d); + ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); + UPDATE_SYNTAX_TABLE (charpos); PREFETCH (); GET_CHAR_AFTER (c2, d, dummy); s2 = SYNTAX (c2); @@ -5956,9 +4785,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, if (!AT_STRINGS_BEG (d)) { GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2); -#ifdef emacs UPDATE_SYNTAX_TABLE_BACKWARD (charpos - 1); -#endif s1 = SYNTAX (c1); /* ... and S1 is Sword, and WORD_BOUNDARY_P (C1, C2) @@ -5981,14 +4808,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { /* C1 is the character before D, S1 is the syntax of C1, C2 is the character at D, and S2 is the syntax of C2. */ - re_wchar_t c1, c2; + int c1, c2; int s1, s2; int dummy; -#ifdef emacs - ssize_t offset = PTR_TO_OFFSET (d) - 1; - ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); - UPDATE_SYNTAX_TABLE_FAST (charpos); -#endif + ptrdiff_t offset = PTR_TO_OFFSET (d) - 1; + ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); + UPDATE_SYNTAX_TABLE (charpos); GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2); s1 = SYNTAX (c1); @@ -6001,9 +4826,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { PREFETCH_NOLIMIT (); GET_CHAR_AFTER (c2, d, dummy); -#ifdef emacs - UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos); -#endif + UPDATE_SYNTAX_TABLE_FORWARD (charpos); s2 = SYNTAX (c2); /* ... and S2 is Sword, and WORD_BOUNDARY_P (C1, C2) @@ -6026,13 +4849,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { /* C1 is the character before D, S1 is the syntax of C1, C2 is the character at D, and S2 is the syntax of C2. */ - re_wchar_t c1, c2; + int c1, c2; int s1, s2; -#ifdef emacs - ssize_t offset = PTR_TO_OFFSET (d); - ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); - UPDATE_SYNTAX_TABLE_FAST (charpos); -#endif + ptrdiff_t offset = PTR_TO_OFFSET (d); + ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); + UPDATE_SYNTAX_TABLE (charpos); PREFETCH (); c2 = RE_STRING_CHAR (d, target_multibyte); s2 = SYNTAX (c2); @@ -6045,9 +4866,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, if (!AT_STRINGS_BEG (d)) { GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2); -#ifdef emacs UPDATE_SYNTAX_TABLE_BACKWARD (charpos - 1); -#endif s1 = SYNTAX (c1); /* ... and S1 is Sword or Ssymbol. */ @@ -6069,13 +4888,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { /* C1 is the character before D, S1 is the syntax of C1, C2 is the character at D, and S2 is the syntax of C2. */ - re_wchar_t c1, c2; + int c1, c2; int s1, s2; -#ifdef emacs - ssize_t offset = PTR_TO_OFFSET (d) - 1; - ssize_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); - UPDATE_SYNTAX_TABLE_FAST (charpos); -#endif + ptrdiff_t offset = PTR_TO_OFFSET (d) - 1; + ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset); + UPDATE_SYNTAX_TABLE (charpos); GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2); s1 = SYNTAX (c1); @@ -6088,9 +4905,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { PREFETCH_NOLIMIT (); c2 = RE_STRING_CHAR (d, target_multibyte); -#ifdef emacs - UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos + 1); -#endif + UPDATE_SYNTAX_TABLE_FORWARD (charpos + 1); s2 = SYNTAX (c2); /* ... and S2 is Sword or Ssymbol. */ @@ -6103,21 +4918,19 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, case syntaxspec: case notsyntaxspec: { - boolean not = (re_opcode_t) *(p - 1) == notsyntaxspec; + bool not = (re_opcode_t) *(p - 1) == notsyntaxspec; mcnt = *p++; DEBUG_PRINT ("EXECUTING %ssyntaxspec %d.\n", not ? "not" : "", mcnt); PREFETCH (); -#ifdef emacs { - ssize_t offset = PTR_TO_OFFSET (d); - ssize_t pos1 = SYNTAX_TABLE_BYTE_TO_CHAR (offset); - UPDATE_SYNTAX_TABLE_FAST (pos1); + ptrdiff_t offset = PTR_TO_OFFSET (d); + ptrdiff_t pos1 = SYNTAX_TABLE_BYTE_TO_CHAR (offset); + UPDATE_SYNTAX_TABLE (pos1); } -#endif { int len; - re_wchar_t c; + int c; GET_CHAR_AFTER (c, d, len); if ((SYNTAX (c) != (enum syntaxcode) mcnt) ^ not) @@ -6127,7 +4940,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, } break; -#ifdef emacs case at_dot: DEBUG_PRINT ("EXECUTING at_dot.\n"); if (PTR_BYTE_POS (d) != PT_BYTE) @@ -6137,7 +4949,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, case categoryspec: case notcategoryspec: { - boolean not = (re_opcode_t) *(p - 1) == notcategoryspec; + bool not = (re_opcode_t) *(p - 1) == notcategoryspec; mcnt = *p++; DEBUG_PRINT ("EXECUTING %scategoryspec %d.\n", not ? "not" : "", mcnt); @@ -6145,7 +4957,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, { int len; - re_wchar_t c; + int c; GET_CHAR_AFTER (c, d, len); if ((!CHAR_HAS_CATEGORY (c, mcnt)) ^ not) goto fail; @@ -6154,8 +4966,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, } break; -#endif /* emacs */ - default: abort (); } @@ -6174,11 +4984,11 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, switch (*pat++) { case on_failure_keep_string_jump: - assert (str == NULL); + eassert (str == NULL); goto continue_failure_jump; case on_failure_jump_nastyloop: - assert ((re_opcode_t)pat[-2] == no_op); + eassert ((re_opcode_t)pat[-2] == no_op); PUSH_FAILURE_POINT (pat - 2, str); FALLTHROUGH; case on_failure_jump_loop: @@ -6198,7 +5008,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, abort (); } - assert (p >= bufp->buffer && p <= pend); + eassert (p >= bufp->buffer && p <= pend); if (d >= string1 && d <= end1) dend = end_match_1; @@ -6210,9 +5020,9 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, if (best_regs_set) goto restore_best_regs; - FREE_VARIABLES (); + SAFE_FREE (); - return -1; /* Failure to match. */ + return -1; /* Failure to match. */ } /* Subroutine definitions for re_match_2. */ @@ -6221,19 +5031,19 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, bytes; nonzero otherwise. */ static int -bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len, - RE_TRANSLATE_TYPE translate, const int target_multibyte) +bcmp_translate (re_char *s1, re_char *s2, ptrdiff_t len, + Lisp_Object translate, int target_multibyte) { - register re_char *p1 = s1, *p2 = s2; + re_char *p1 = s1, *p2 = s2; re_char *p1_end = s1 + len; re_char *p2_end = s2 + len; /* FIXME: Checking both p1 and p2 presumes that the two strings might have - different lengths, but relying on a single `len' would break this. -sm */ + different lengths, but relying on a single LEN would break this. -sm */ while (p1 < p1_end && p2 < p2_end) { int p1_charlen, p2_charlen; - re_wchar_t p1_ch, p2_ch; + int p1_ch, p2_ch; GET_CHAR_AFTER (p1_ch, p1, p1_charlen); GET_CHAR_AFTER (p2_ch, p2, p2_charlen); @@ -6257,16 +5067,14 @@ bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len, compiles PATTERN (of length SIZE) and puts the result in BUFP. Returns 0 if the pattern was valid, otherwise an error string. - Assumes the `allocated' (and perhaps `buffer') and `translate' fields + Assumes the 'allocated' (and perhaps 'buffer') and 'translate' fields are set in BUFP on entry. We call regex_compile to do the actual compilation. */ 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; @@ -6275,335 +5083,12 @@ re_compile_pattern (const char *pattern, size_t length, (and at least one extra will be -1). */ bufp->regs_allocated = REGS_UNALLOCATED; - /* And GNU code determines whether or not to get register information - by passing null for the REGS argument to re_match, etc., not by - setting no_sub. */ - bufp->no_sub = 0; - ret = regex_compile ((re_char *) pattern, length, -#ifdef emacs posix_backtracking, whitespace_regexp, -#else - re_syntax_options, -#endif bufp); if (!ret) return NULL; - return gettext (re_error_msgid[(int) ret]); -} -WEAK_ALIAS (__re_compile_pattern, re_compile_pattern) - -/* Entry points compatible with 4.2 BSD regex library. We don't define - them unless specifically requested. */ - -#if defined _REGEX_RE_COMP || defined _LIBC - -/* BSD has one and only one pattern buffer. */ -static struct re_pattern_buffer re_comp_buf; - -char * -# ifdef _LIBC -/* Make these definitions weak in libc, so POSIX programs can redefine - these names if they don't use our functions, and still use - regcomp/regexec below without link errors. */ -weak_function -# endif -re_comp (const char *s) -{ - reg_errcode_t ret; - - if (!s) - { - if (!re_comp_buf.buffer) - /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */ - return (char *) gettext ("No previous regular expression"); - return 0; - } - - if (!re_comp_buf.buffer) - { - re_comp_buf.buffer = malloc (200); - if (re_comp_buf.buffer == NULL) - /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */ - return (char *) gettext (re_error_msgid[(int) REG_ESPACE]); - re_comp_buf.allocated = 200; - - re_comp_buf.fastmap = malloc (1 << BYTEWIDTH); - if (re_comp_buf.fastmap == NULL) - /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */ - return (char *) gettext (re_error_msgid[(int) REG_ESPACE]); - } - - /* Since `re_exec' always passes NULL for the `regs' argument, we - don't need to initialize the pattern buffer fields which affect it. */ - - ret = regex_compile (s, strlen (s), re_syntax_options, &re_comp_buf); - - if (!ret) - return NULL; - - /* Yes, we're discarding `const' here if !HAVE_LIBINTL. */ - return (char *) gettext (re_error_msgid[(int) ret]); -} - - -int -# ifdef _LIBC -weak_function -# endif -re_exec (const char *s) -{ - const size_t len = strlen (s); - return re_search (&re_comp_buf, s, len, 0, len, 0) >= 0; -} -#endif /* _REGEX_RE_COMP */ - -/* POSIX.2 functions. Don't define these for Emacs. */ - -#ifndef emacs - -/* regcomp takes a regular expression as a string and compiles it. - - PREG is a regex_t *. We do not expect any fields to be initialized, - since POSIX says we shouldn't. Thus, we set - - `buffer' to the compiled pattern; - `used' to the length of the compiled pattern; - `syntax' to RE_SYNTAX_POSIX_EXTENDED if the - REG_EXTENDED bit in CFLAGS is set; otherwise, to - RE_SYNTAX_POSIX_BASIC; - `fastmap' to an allocated space for the fastmap; - `fastmap_accurate' to zero; - `re_nsub' to the number of subexpressions in PATTERN. - - PATTERN is the address of the pattern string. - - CFLAGS is a series of bits which affect compilation. - - If REG_EXTENDED is set, we use POSIX extended syntax; otherwise, we - use POSIX basic syntax. - - If REG_NEWLINE is set, then . and [^...] don't match newline. - Also, regexec will try a match beginning after every newline. - - If REG_ICASE is set, then we considers upper- and lowercase - versions of letters to be equivalent when matching. - - If REG_NOSUB is set, then when PREG is passed to regexec, that - routine will report only success or failure, and nothing about the - registers. - - It returns 0 if it succeeds, nonzero if it doesn't. (See regex.h for - the return codes and their meanings.) */ - -reg_errcode_t -regcomp (regex_t *_Restrict_ preg, const char *_Restrict_ pattern, - int cflags) -{ - reg_errcode_t ret; - reg_syntax_t syntax - = (cflags & REG_EXTENDED) ? - RE_SYNTAX_POSIX_EXTENDED : RE_SYNTAX_POSIX_BASIC; - - /* regex_compile will allocate the space for the compiled pattern. */ - preg->buffer = 0; - preg->allocated = 0; - preg->used = 0; - - /* Try to allocate space for the fastmap. */ - preg->fastmap = malloc (1 << BYTEWIDTH); - - if (cflags & REG_ICASE) - { - unsigned i; - - preg->translate = malloc (CHAR_SET_SIZE * sizeof *preg->translate); - if (preg->translate == NULL) - return (int) REG_ESPACE; - - /* Map uppercase characters to corresponding lowercase ones. */ - for (i = 0; i < CHAR_SET_SIZE; i++) - preg->translate[i] = ISUPPER (i) ? TOLOWER (i) : i; - } - else - preg->translate = NULL; - - /* If REG_NEWLINE is set, newlines are treated differently. */ - if (cflags & REG_NEWLINE) - { /* REG_NEWLINE implies neither . nor [^...] match newline. */ - syntax &= ~RE_DOT_NEWLINE; - syntax |= RE_HAT_LISTS_NOT_NEWLINE; - } - else - syntax |= RE_NO_NEWLINE_ANCHOR; - - preg->no_sub = !!(cflags & REG_NOSUB); - - /* POSIX says a null character in the pattern terminates it, so we - can use strlen here in compiling the pattern. */ - ret = regex_compile ((re_char *) pattern, strlen (pattern), syntax, preg); - - /* POSIX doesn't distinguish between an unmatched open-group and an - unmatched close-group: both are REG_EPAREN. */ - if (ret == REG_ERPAREN) - ret = REG_EPAREN; - - if (ret == REG_NOERROR && preg->fastmap) - { /* Compute the fastmap now, since regexec cannot modify the pattern - buffer. */ - re_compile_fastmap (preg); - if (preg->can_be_null) - { /* The fastmap can't be used anyway. */ - free (preg->fastmap); - preg->fastmap = NULL; - } - } - return ret; -} -WEAK_ALIAS (__regcomp, regcomp) - - -/* regexec searches for a given pattern, specified by PREG, in the - string STRING. - - If NMATCH is zero or REG_NOSUB was set in the cflags argument to - `regcomp', we ignore PMATCH. Otherwise, we assume PMATCH has at - least NMATCH elements, and we set them to the offsets of the - corresponding matched substrings. - - EFLAGS specifies `execution flags' which affect matching: if - REG_NOTBOL is set, then ^ does not match at the beginning of the - string; if REG_NOTEOL is set, then $ does not match at the end. - - We return 0 if we find a match and REG_NOMATCH if not. */ - -reg_errcode_t -regexec (const regex_t *_Restrict_ preg, const char *_Restrict_ string, - size_t nmatch, regmatch_t pmatch[_Restrict_arr_], int eflags) -{ - regoff_t ret; - struct re_registers regs; - regex_t private_preg; - size_t len = strlen (string); - boolean want_reg_info = !preg->no_sub && nmatch > 0 && pmatch; - - private_preg = *preg; - - private_preg.not_bol = !!(eflags & REG_NOTBOL); - private_preg.not_eol = !!(eflags & REG_NOTEOL); - - /* The user has told us exactly how many registers to return - information about, via `nmatch'. We have to pass that on to the - matching routines. */ - private_preg.regs_allocated = REGS_FIXED; - - if (want_reg_info) - { - regs.num_regs = nmatch; - regs.start = TALLOC (nmatch * 2, regoff_t); - if (regs.start == NULL) - return REG_NOMATCH; - regs.end = regs.start + nmatch; - } - - /* Instead of using not_eol to implement REG_NOTEOL, we could simply - pass (&private_preg, string, len + 1, 0, len, ...) pretending the string - was a little bit longer but still only matching the real part. - This works because the `endline' will check for a '\n' and will find a - '\0', correctly deciding that this is not the end of a line. - But it doesn't work out so nicely for REG_NOTBOL, since we don't have - a convenient '\0' there. For all we know, the string could be preceded - by '\n' which would throw things off. */ - - /* Perform the searching operation. */ - ret = re_search (&private_preg, string, len, - /* start: */ 0, /* range: */ len, - want_reg_info ? ®s : 0); - - /* Copy the register information to the POSIX structure. */ - if (want_reg_info) - { - if (ret >= 0) - { - unsigned r; - - for (r = 0; r < nmatch; r++) - { - pmatch[r].rm_so = regs.start[r]; - pmatch[r].rm_eo = regs.end[r]; - } - } - - /* If we needed the temporary register info, free the space now. */ - free (regs.start); - } - - /* We want zero return to mean success, unlike `re_search'. */ - return ret >= 0 ? REG_NOERROR : REG_NOMATCH; -} -WEAK_ALIAS (__regexec, regexec) - - -/* Returns a message corresponding to an error code, ERR_CODE, returned - from either regcomp or regexec. We don't use PREG here. - - ERR_CODE was previously called ERRCODE, but that name causes an - error with msvc8 compiler. */ - -size_t -regerror (int err_code, const regex_t *preg, char *errbuf, size_t errbuf_size) -{ - const char *msg; - size_t msg_size; - - if (err_code < 0 - || err_code >= (sizeof (re_error_msgid) / sizeof (re_error_msgid[0]))) - /* Only error codes returned by the rest of the code should be passed - to this routine. If we are given anything else, or if other regex - code generates an invalid error code, then the program has a bug. - Dump core so we can fix it. */ - abort (); - - msg = gettext (re_error_msgid[err_code]); - - msg_size = strlen (msg) + 1; /* Includes the null. */ - - if (errbuf_size != 0) - { - if (msg_size > errbuf_size) - { - memcpy (errbuf, msg, errbuf_size - 1); - errbuf[errbuf_size - 1] = 0; - } - else - strcpy (errbuf, msg); - } - - return msg_size; + return re_error_msgid[ret]; } -WEAK_ALIAS (__regerror, regerror) - - -/* Free dynamically allocated space used by PREG. */ - -void -regfree (regex_t *preg) -{ - free (preg->buffer); - preg->buffer = NULL; - - preg->allocated = 0; - preg->used = 0; - - free (preg->fastmap); - preg->fastmap = NULL; - preg->fastmap_accurate = 0; - - free (preg->translate); - preg->translate = NULL; -} -WEAK_ALIAS (__regfree, regfree) - -#endif /* not emacs */ diff --git a/src/regex-emacs.h b/src/regex-emacs.h new file mode 100644 index 00000000000..a849cbea054 --- /dev/null +++ b/src/regex-emacs.h @@ -0,0 +1,197 @@ +/* Emacs regular expression API + + Copyright (C) 1985, 1989-1993, 1995, 2000-2018 Free Software + Foundation, Inc. + + This program 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, or (at your option) + any later version. + + This program 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 this program. If not, see <https://www.gnu.org/licenses/>. */ + +#ifndef EMACS_REGEX_H +#define EMACS_REGEX_H 1 + +#include <stddef.h> + +/* This is the structure we store register match data in. + Declare this before including lisp.h, since lisp.h (via thread.h) + uses struct re_registers. */ +struct re_registers +{ + unsigned num_regs; + ptrdiff_t *start; + ptrdiff_t *end; +}; + +#include "lisp.h" + +/* The string or buffer being matched. + It is used for looking up syntax properties. + + If the value is a Lisp string object, match text in that string; if + it's nil, match text in the current buffer; if it's t, match text + in a C string. + + This value is effectively another parameter to re_search_2 and + re_match_2. No calls into Lisp or thread switches are allowed + before setting re_match_object and calling into the regex search + and match functions. These functions capture the current value of + re_match_object into gl_state on entry. + + TODO: turn into an actual function parameter. */ +extern Lisp_Object re_match_object; + +/* Roughly the maximum number of failure points on the stack. */ +extern size_t emacs_re_max_failures; + +/* Amount of memory that we can safely stack allocate. */ +extern ptrdiff_t emacs_re_safe_alloca; + +/* This data structure represents a compiled pattern. Before calling + the pattern compiler, the fields 'buffer', 'allocated', 'fastmap', + and 'translate' can be set. After the pattern has been + compiled, the 're_nsub' field is available. All other fields are + private to the regex routines. */ + +struct re_pattern_buffer +{ + /* Space that holds the compiled pattern. It is declared as + 'unsigned char *' because its elements are + sometimes used as array indexes. */ + unsigned char *buffer; + + /* Number of bytes to which 'buffer' points. */ + size_t allocated; + + /* Number of bytes actually used in 'buffer'. */ + size_t used; + + /* Charset of unibyte characters at compiling time. */ + int charset_unibyte; + + /* 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. */ + char *fastmap; + + /* Either a translate table to apply to all characters before + comparing them, or zero for no translation. The translation + applies to a pattern when it is compiled and to a string + when it is matched. */ + Lisp_Object translate; + + /* Number of subexpressions found by the compiler. */ + size_t re_nsub; + + /* True if and only if this pattern can match the empty string. + Well, in truth it's used only in 're_search_2', to see + whether or not we should use the fastmap, so we don't set + this absolutely perfectly; see 're_compile_fastmap'. */ + unsigned can_be_null : 1; + + /* If REGS_UNALLOCATED, allocate space in the 'regs' structure + for 'max (RE_NREGS, re_nsub + 1)' groups. + If REGS_REALLOCATE, reallocate space if necessary. + If REGS_FIXED, use what's there. */ + unsigned regs_allocated : 2; + + /* Set to false when 'regex_compile' compiles a pattern; set to true + by 're_compile_fastmap' if it updates the fastmap. */ + unsigned fastmap_accurate : 1; + + /* If true, the compilation of the pattern had to look up the syntax table, + so the compiled pattern is valid for the current syntax table only. */ + unsigned used_syntax : 1; + + /* If true, multi-byte form in the regexp pattern should be + recognized as a multibyte character. */ + unsigned multibyte : 1; + + /* If true, multi-byte form in the target of match should be + recognized as a multibyte character. */ + unsigned target_multibyte : 1; +}; + +/* Declarations for routines. */ + +/* 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, + bool posix_backtracking, + const char *whitespace_regexp, + struct re_pattern_buffer *buffer); + + +/* Search in the string STRING (with length LENGTH) for the pattern + compiled into BUFFER. Start searching at position START, for RANGE + characters. Return the starting position of the match, -1 for no + match, or -2 for an internal error. Also return register + information in REGS (if REGS is non-null). */ +extern ptrdiff_t re_search (struct re_pattern_buffer *buffer, + const char *string, size_t length, + ptrdiff_t start, ptrdiff_t range, + struct re_registers *regs); + + +/* Like 're_search', but search in the concatenation of STRING1 and + STRING2. Also, stop searching at index START + STOP. */ +extern ptrdiff_t re_search_2 (struct re_pattern_buffer *buffer, + const char *string1, size_t length1, + const char *string2, size_t length2, + ptrdiff_t start, ptrdiff_t range, + struct re_registers *regs, + ptrdiff_t stop); + + +/* Like 're_search_2', but return how many characters in STRING the regexp + in BUFFER matched, starting at position START. */ +extern ptrdiff_t re_match_2 (struct re_pattern_buffer *buffer, + const char *string1, size_t length1, + const char *string2, size_t length2, + ptrdiff_t start, struct re_registers *regs, + ptrdiff_t stop); + + +/* Set REGS to hold NUM_REGS registers, storing them in STARTS and + ENDS. Subsequent matches using BUFFER and REGS will use this memory + for recording register information. STARTS and ENDS must be + allocated with malloc, and must each be at least 'NUM_REGS * sizeof + (ptrdiff_t)' bytes long. + + If NUM_REGS == 0, then subsequent matches should allocate their own + register data. + + Unless this function is called, the first search or match using + PATTERN_BUFFER will allocate its own register data, without + freeing the old data. */ +extern void re_set_registers (struct re_pattern_buffer *buffer, + struct re_registers *regs, + unsigned num_regs, + ptrdiff_t *starts, ptrdiff_t *ends); + +/* Character classes. */ +typedef enum { RECC_ERROR = 0, + RECC_ALNUM, RECC_ALPHA, RECC_WORD, + RECC_GRAPH, RECC_PRINT, + RECC_LOWER, RECC_UPPER, + RECC_PUNCT, RECC_CNTRL, + RECC_DIGIT, RECC_XDIGIT, + RECC_BLANK, RECC_SPACE, + RECC_MULTIBYTE, RECC_NONASCII, + RECC_ASCII, RECC_UNIBYTE +} re_wctype_t; + +extern bool re_iswctype (int ch, re_wctype_t cc); +extern re_wctype_t re_wctype_parse (const unsigned char **strp, + unsigned limit); + +#endif /* EMACS_REGEX_H */ diff --git a/src/regex.h b/src/regex.h deleted file mode 100644 index 5ef3d541d91..00000000000 --- a/src/regex.h +++ /dev/null @@ -1,644 +0,0 @@ -/* Definitions for data structures and routines for the regular - expression library, version 0.12. - - Copyright (C) 1985, 1989-1993, 1995, 2000-2019 Free Software - Foundation, Inc. - - This program 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, or (at your option) - any later version. - - This program 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 this program. If not, see <https://www.gnu.org/licenses/>. */ - -#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 - -#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. */ -# include <stddef.h> -#endif - -/* The following bits are used to determine the regexp syntax we - recognize. The set/not-set meanings where historically chosen so - that Emacs syntax had the value 0. - The bits are given in alphabetical order, and - the definitions shifted by one from the previous bit; thus, when we - add or remove a bit, only one other definition need change. */ -typedef unsigned long reg_syntax_t; - -/* If this bit is not set, then \ inside a bracket expression is literal. - If set, then such a \ quotes the following character. */ -#define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1) - -/* If this bit is not set, then + and ? are operators, and \+ and \? are - literals. - If set, then \+ and \? are operators and + and ? are literals. */ -#define RE_BK_PLUS_QM (RE_BACKSLASH_ESCAPE_IN_LISTS << 1) - -/* If this bit is set, then character classes are supported. They are: - [:alpha:], [:upper:], [:lower:], [:digit:], [:alnum:], [:xdigit:], - [:space:], [:print:], [:punct:], [:graph:], and [:cntrl:]. - If not set, then character classes are not supported. */ -#define RE_CHAR_CLASSES (RE_BK_PLUS_QM << 1) - -/* If this bit is set, then ^ and $ are always anchors (outside bracket - expressions, of course). - If this bit is not set, then it depends: - ^ is an anchor if it is at the beginning of a regular - expression or after an open-group or an alternation operator; - $ is an anchor if it is at the end of a regular expression, or - before a close-group or an alternation operator. - - This bit could be (re)combined with RE_CONTEXT_INDEP_OPS, because - POSIX draft 11.2 says that * etc. in leading positions is undefined. - We already implemented a previous draft which made those constructs - invalid, though, so we haven't changed the code back. */ -#define RE_CONTEXT_INDEP_ANCHORS (RE_CHAR_CLASSES << 1) - -/* If this bit is set, then special characters are always special - regardless of where they are in the pattern. - If this bit is not set, then special characters are special only in - some contexts; otherwise they are ordinary. Specifically, - * + ? and intervals are only special when not after the beginning, - open-group, or alternation operator. */ -#define RE_CONTEXT_INDEP_OPS (RE_CONTEXT_INDEP_ANCHORS << 1) - -/* If this bit is set, then *, +, ?, and { cannot be first in an re or - immediately after an alternation or begin-group operator. */ -#define RE_CONTEXT_INVALID_OPS (RE_CONTEXT_INDEP_OPS << 1) - -/* If this bit is set, then . matches newline. - If not set, then it doesn't. */ -#define RE_DOT_NEWLINE (RE_CONTEXT_INVALID_OPS << 1) - -/* If this bit is set, then . doesn't match NUL. - If not set, then it does. */ -#define RE_DOT_NOT_NULL (RE_DOT_NEWLINE << 1) - -/* If this bit is set, nonmatching lists [^...] do not match newline. - If not set, they do. */ -#define RE_HAT_LISTS_NOT_NEWLINE (RE_DOT_NOT_NULL << 1) - -/* If this bit is set, either \{...\} or {...} defines an - interval, depending on RE_NO_BK_BRACES. - If not set, \{, \}, {, and } are literals. */ -#define RE_INTERVALS (RE_HAT_LISTS_NOT_NEWLINE << 1) - -/* If this bit is set, +, ? and | aren't recognized as operators. - If not set, they are. */ -#define RE_LIMITED_OPS (RE_INTERVALS << 1) - -/* If this bit is set, newline is an alternation operator. - If not set, newline is literal. */ -#define RE_NEWLINE_ALT (RE_LIMITED_OPS << 1) - -/* If this bit is set, then `{...}' defines an interval, and \{ and \} - are literals. - If not set, then `\{...\}' defines an interval. */ -#define RE_NO_BK_BRACES (RE_NEWLINE_ALT << 1) - -/* If this bit is set, (...) defines a group, and \( and \) are literals. - If not set, \(...\) defines a group, and ( and ) are literals. */ -#define RE_NO_BK_PARENS (RE_NO_BK_BRACES << 1) - -/* If this bit is set, then \<digit> matches <digit>. - If not set, then \<digit> is a back-reference. */ -#define RE_NO_BK_REFS (RE_NO_BK_PARENS << 1) - -/* If this bit is set, then | is an alternation operator, and \| is literal. - If not set, then \| is an alternation operator, and | is literal. */ -#define RE_NO_BK_VBAR (RE_NO_BK_REFS << 1) - -/* If this bit is set, then an ending range point collating higher - than the starting range point, as in [z-a], is invalid. - If not set, then when ending range point collates higher than the - starting range point, the range is ignored. */ -#define RE_NO_EMPTY_RANGES (RE_NO_BK_VBAR << 1) - -/* If this bit is set, then an unmatched ) is ordinary. - If not set, then an unmatched ) is invalid. */ -#define RE_UNMATCHED_RIGHT_PAREN_ORD (RE_NO_EMPTY_RANGES << 1) - -/* If this bit is set, succeed as soon as we match the whole pattern, - without further backtracking. */ -#define RE_NO_POSIX_BACKTRACKING (RE_UNMATCHED_RIGHT_PAREN_ORD << 1) - -/* If this bit is set, do not process the GNU regex operators. - If not set, then the GNU regex operators are recognized. */ -#define RE_NO_GNU_OPS (RE_NO_POSIX_BACKTRACKING << 1) - -/* If this bit is set, then *?, +? and ?? match non greedily. */ -#define RE_FRUGAL (RE_NO_GNU_OPS << 1) - -/* If this bit is set, then (?:...) is treated as a shy group. */ -#define RE_SHY_GROUPS (RE_FRUGAL << 1) - -/* If this bit is set, ^ and $ only match at beg/end of buffer. */ -#define RE_NO_NEWLINE_ANCHOR (RE_SHY_GROUPS << 1) - -/* If this bit is set, turn on internal regex debugging. - If not set, and debugging was on, turn it off. - This only works if regex.c is compiled -DDEBUG. - We define this bit always, so that all that's needed to turn on - debugging is to recompile regex.c; the calling code can always have - this bit set, and it won't affect anything in the normal case. */ -#define RE_DEBUG (RE_NO_NEWLINE_ANCHOR << 1) - -/* This global variable defines the particular regexp syntax to use (for - 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; */ - -#ifdef emacs -# include "lisp.h" -/* In Emacs, 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. - - 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. */ -extern size_t emacs_re_max_failures; - -#ifdef emacs -/* Amount of memory that we can safely stack allocate. */ -extern ptrdiff_t emacs_re_safe_alloca; -#endif - - -/* Define combinations of the above bits for the standard possibilities. - (The [[[ comments delimit what gets put into the Texinfo file, so - don't delete them!) */ -/* [[[begin syntaxes]]] */ -#define RE_SYNTAX_EMACS \ - (RE_CHAR_CLASSES | RE_INTERVALS | RE_SHY_GROUPS | RE_FRUGAL) - -#define RE_SYNTAX_AWK \ - (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DOT_NOT_NULL \ - | RE_NO_BK_PARENS | RE_NO_BK_REFS \ - | RE_NO_BK_VBAR | RE_NO_EMPTY_RANGES \ - | RE_DOT_NEWLINE | RE_CONTEXT_INDEP_ANCHORS \ - | RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS) - -#define RE_SYNTAX_GNU_AWK \ - ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DEBUG) \ - & ~(RE_DOT_NOT_NULL | RE_INTERVALS | RE_CONTEXT_INDEP_OPS)) - -#define RE_SYNTAX_POSIX_AWK \ - (RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \ - | RE_INTERVALS | RE_NO_GNU_OPS) - -#define RE_SYNTAX_GREP \ - (RE_BK_PLUS_QM | RE_CHAR_CLASSES \ - | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \ - | RE_NEWLINE_ALT) - -#define RE_SYNTAX_EGREP \ - (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \ - | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \ - | RE_NEWLINE_ALT | RE_NO_BK_PARENS \ - | RE_NO_BK_VBAR) - -#define RE_SYNTAX_POSIX_EGREP \ - (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES) - -/* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */ -#define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC - -#define RE_SYNTAX_SED RE_SYNTAX_POSIX_BASIC - -/* Syntax bits common to both basic and extended POSIX regex syntax. */ -#define _RE_SYNTAX_POSIX_COMMON \ - (RE_CHAR_CLASSES | RE_DOT_NEWLINE | RE_DOT_NOT_NULL \ - | RE_INTERVALS | RE_NO_EMPTY_RANGES) - -#define RE_SYNTAX_POSIX_BASIC \ - (_RE_SYNTAX_POSIX_COMMON | RE_BK_PLUS_QM) - -/* Differs from ..._POSIX_BASIC only in that RE_BK_PLUS_QM becomes - RE_LIMITED_OPS, i.e., \? \+ \| are not recognized. Actually, this - isn't minimal, since other operators, such as \`, aren't disabled. */ -#define RE_SYNTAX_POSIX_MINIMAL_BASIC \ - (_RE_SYNTAX_POSIX_COMMON | RE_LIMITED_OPS) - -#define RE_SYNTAX_POSIX_EXTENDED \ - (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \ - | RE_CONTEXT_INDEP_OPS | RE_NO_BK_BRACES \ - | RE_NO_BK_PARENS | RE_NO_BK_VBAR \ - | RE_CONTEXT_INVALID_OPS | RE_UNMATCHED_RIGHT_PAREN_ORD) - -/* Differs from ..._POSIX_EXTENDED in that RE_CONTEXT_INDEP_OPS is - removed and RE_NO_BK_REFS is added. */ -#define RE_SYNTAX_POSIX_MINIMAL_EXTENDED \ - (_RE_SYNTAX_POSIX_COMMON | RE_CONTEXT_INDEP_ANCHORS \ - | RE_CONTEXT_INVALID_OPS | RE_NO_BK_BRACES \ - | RE_NO_BK_PARENS | RE_NO_BK_REFS \ - | RE_NO_BK_VBAR | RE_UNMATCHED_RIGHT_PAREN_ORD) -/* [[[end syntaxes]]] */ - -/* Maximum number of duplicates an interval can allow. Some systems - (erroneously) define this in other header files, but we want our - value, so remove any previous define. */ -#ifdef RE_DUP_MAX -# undef RE_DUP_MAX -#endif -/* If sizeof(int) == 2, then ((1 << 15) - 1) overflows. */ -#define RE_DUP_MAX (0x7fff) - - -/* POSIX `cflags' bits (i.e., information for `regcomp'). */ - -/* If this bit is set, then use extended regular expression syntax. - If not set, then use basic regular expression syntax. */ -#define REG_EXTENDED 1 - -/* If this bit is set, then ignore case when matching. - If not set, then case is significant. */ -#define REG_ICASE (REG_EXTENDED << 1) - -/* If this bit is set, then anchors do not match at newline - characters in the string. - If not set, then anchors do match at newlines. */ -#define REG_NEWLINE (REG_ICASE << 1) - -/* If this bit is set, then report only success or fail in regexec. - If not set, then returns differ between not matching and errors. */ -#define REG_NOSUB (REG_NEWLINE << 1) - - -/* POSIX `eflags' bits (i.e., information for regexec). */ - -/* If this bit is set, then the beginning-of-line operator doesn't match - the beginning of the string (presumably because it's not the - beginning of a line). - If not set, then the beginning-of-line operator does match the - beginning of the string. */ -#define REG_NOTBOL 1 - -/* Like REG_NOTBOL, except for the end-of-line. */ -#define REG_NOTEOL (1 << 1) - - -/* If any error codes are removed, changed, or added, update the - `re_error_msg' table in regex.c. */ -typedef enum -{ -#ifdef _XOPEN_SOURCE - REG_ENOSYS = -1, /* This will never happen for this implementation. */ -#endif - - REG_NOERROR = 0, /* Success. */ - REG_NOMATCH, /* Didn't find a match (for regexec). */ - - /* POSIX regcomp return error codes. (In the order listed in the - standard.) */ - REG_BADPAT, /* Invalid pattern. */ - REG_ECOLLATE, /* Not implemented. */ - REG_ECTYPE, /* Invalid character class name. */ - REG_EESCAPE, /* Trailing backslash. */ - REG_ESUBREG, /* Invalid back reference. */ - REG_EBRACK, /* Unmatched left bracket. */ - REG_EPAREN, /* Parenthesis imbalance. */ - REG_EBRACE, /* Unmatched \{. */ - REG_BADBR, /* Invalid contents of \{\}. */ - REG_ERANGE, /* Invalid range end. */ - REG_ESPACE, /* Ran out of memory. */ - REG_BADRPT, /* No preceding re for repetition op. */ - - /* Error codes we've added. */ - REG_EEND, /* Premature end. */ - REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */ - REG_ERPAREN, /* Unmatched ) or \); not returned from regcomp. */ - REG_ERANGEX /* Range striding over charsets. */ -} reg_errcode_t; - -/* This data structure represents a compiled pattern. Before calling - the pattern compiler, the fields `buffer', `allocated', `fastmap', - `translate', and `no_sub' can be set. After the pattern has been - compiled, the `re_nsub' field is available. All other fields are - private to the regex routines. */ - -#ifndef RE_TRANSLATE_TYPE -# define RE_TRANSLATE_TYPE char * -#endif - -struct re_pattern_buffer -{ -/* [[[begin pattern_buffer]]] */ - /* Space that holds the compiled pattern. It is declared as - `unsigned char *' because its elements are - sometimes used as array indexes. */ - unsigned char *buffer; - - /* Number of bytes to which `buffer' points. */ - size_t allocated; - - /* 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. */ - char *fastmap; - - /* Either a translate table to apply to all characters before - comparing them, or zero for no translation. The translation - is applied to a pattern when it is compiled and to a string - when it is matched. */ - RE_TRANSLATE_TYPE translate; - - /* Number of subexpressions found by the compiler. */ - size_t re_nsub; - - /* Zero if this pattern cannot match the empty string, one else. - Well, in truth it's used only in `re_search_2', to see - whether or not we should use the fastmap, so we don't set - this absolutely perfectly; see `re_compile_fastmap'. */ - unsigned can_be_null : 1; - - /* If REGS_UNALLOCATED, allocate space in the `regs' structure - for `max (RE_NREGS, re_nsub + 1)' groups. - If REGS_REALLOCATE, reallocate space if necessary. - If REGS_FIXED, use what's there. */ -#define REGS_UNALLOCATED 0 -#define REGS_REALLOCATE 1 -#define REGS_FIXED 2 - unsigned regs_allocated : 2; - - /* Set to zero when `regex_compile' compiles a pattern; set to one - by `re_compile_fastmap' if it updates the fastmap. */ - unsigned fastmap_accurate : 1; - - /* If set, `re_match_2' does not return information about - subexpressions. */ - unsigned no_sub : 1; - - /* If set, a beginning-of-line anchor doesn't match at the - beginning of the string. */ - unsigned not_bol : 1; - - /* Similarly for an end-of-line anchor. */ - unsigned not_eol : 1; - - /* If true, the compilation of the pattern had to look up the syntax table, - so the compiled pattern is only valid for the current syntax table. */ - unsigned used_syntax : 1; - -#ifdef emacs - /* If true, multi-byte form in the regexp pattern should be - recognized as a multibyte character. */ - unsigned multibyte : 1; - - /* If true, multi-byte form in the target of match should be - recognized as a multibyte character. */ - unsigned target_multibyte : 1; - - /* Charset of unibyte characters at compiling time. */ - int charset_unibyte; -#endif - -/* [[[end pattern_buffer]]] */ -}; - -typedef struct re_pattern_buffer regex_t; - -/* 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; - - -/* This is the structure we store register match data in. See - regex.texinfo for a full description of what registers match. */ -struct re_registers -{ - unsigned num_regs; - regoff_t *start; - regoff_t *end; -}; - - -/* If `regs_allocated' is REGS_UNALLOCATED in the pattern buffer, - `re_match_2' returns information about at least this many registers - the first time a `regs' structure is passed. */ -#ifndef RE_NREGS -# define RE_NREGS 30 -#endif - - -/* POSIX specification for registers. Aside from the different names than - `re_registers', POSIX uses an array of structures, instead of a - structure of arrays. */ -typedef struct -{ - regoff_t rm_so; /* Byte offset from string's start to substring's start. */ - regoff_t rm_eo; /* Byte offset from string's start to substring's end. */ -} regmatch_t; - -/* 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); - - -/* Compile a fastmap for the compiled pattern in BUFFER; used to - accelerate searches. Return 0 if successful and -2 if was an - internal error. */ -extern int re_compile_fastmap (struct re_pattern_buffer *__buffer); - - -/* Search in the string STRING (with length LENGTH) for the pattern - compiled into BUFFER. Start searching at position START, for RANGE - characters. Return the starting position of the match, -1 for no - match, or -2 for an internal error. Also return register - information in REGS (if REGS and BUFFER->no_sub are nonzero). */ -extern regoff_t re_search (struct re_pattern_buffer *__buffer, - const char *__string, size_t __length, - ssize_t __start, ssize_t __range, - struct re_registers *__regs); - - -/* Like `re_search', but search in the concatenation of STRING1 and - STRING2. Also, stop searching at index START + STOP. */ -extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer, - const char *__string1, size_t __length1, - const char *__string2, size_t __length2, - ssize_t __start, ssize_t __range, - struct re_registers *__regs, - ssize_t __stop); - - -/* Like `re_search', but return how many characters in STRING the regexp - in BUFFER matched, starting at position START. */ -extern regoff_t re_match (struct re_pattern_buffer *__buffer, - const char *__string, size_t __length, - ssize_t __start, struct re_registers *__regs); - - -/* Relates to `re_match' as `re_search_2' relates to `re_search'. */ -extern regoff_t re_match_2 (struct re_pattern_buffer *__buffer, - const char *__string1, size_t __length1, - const char *__string2, size_t __length2, - ssize_t __start, struct re_registers *__regs, - ssize_t __stop); - - -/* Set REGS to hold NUM_REGS registers, storing them in STARTS and - ENDS. Subsequent matches using BUFFER and REGS will use this memory - for recording register information. STARTS and ENDS must be - allocated with malloc, and must each be at least `NUM_REGS * sizeof - (regoff_t)' bytes long. - - If NUM_REGS == 0, then subsequent matches should allocate their own - register data. - - Unless this function is called, the first search or match using - PATTERN_BUFFER will allocate its own register data, without - freeing the old data. */ -extern void re_set_registers (struct re_pattern_buffer *__buffer, - struct re_registers *__regs, - unsigned __num_regs, - regoff_t *__starts, regoff_t *__ends); - -#if defined _REGEX_RE_COMP || defined _LIBC -# ifndef _CRAY -/* 4.2 bsd compatibility. */ -extern char *re_comp (const char *); -extern int re_exec (const char *); -# endif -#endif - -/* GCC 2.95 and later have "__restrict"; C99 compilers have - "restrict", and "configure" may have defined "restrict". - Other compilers use __restrict, __restrict__, and _Restrict, and - 'configure' might #define 'restrict' to those words, so pick a - different name. */ -#ifndef _Restrict_ -# if 199901L <= __STDC_VERSION__ -# define _Restrict_ restrict -# elif 2 < __GNUC__ || (2 == __GNUC__ && 95 <= __GNUC_MINOR__) -# define _Restrict_ __restrict -# else -# define _Restrict_ -# endif -#endif -/* gcc 3.1 and up support the [restrict] syntax. Don't trust - sys/cdefs.h's definition of __restrict_arr, though, as it - mishandles gcc -ansi -pedantic. */ -#ifndef _Restrict_arr_ -# if ((199901L <= __STDC_VERSION__ \ - || ((3 < __GNUC__ || (3 == __GNUC__ && 1 <= __GNUC_MINOR__)) \ - && !defined __STRICT_ANSI__)) \ - && !defined __GNUG__) -# define _Restrict_arr_ _Restrict_ -# else -# define _Restrict_arr_ -# endif -#endif - -/* POSIX compatibility. */ -extern reg_errcode_t regcomp (regex_t *_Restrict_ __preg, - const char *_Restrict_ __pattern, - int __cflags); - -extern reg_errcode_t regexec (const regex_t *_Restrict_ __preg, - const char *_Restrict_ __string, size_t __nmatch, - regmatch_t __pmatch[_Restrict_arr_], - int __eflags); - -extern size_t regerror (int __errcode, const regex_t * __preg, - char *__errbuf, size_t __errbuf_size); - -extern void regfree (regex_t *__preg); - - -#ifdef __cplusplus -} -#endif /* C++ */ - -/* For platform which support the ISO C amendment 1 functionality we - support user defined character classes. */ -#if WIDE_CHAR_SUPPORT -/* Solaris 2.5 has a bug: <wchar.h> must be included before <wctype.h>. */ -# include <wchar.h> -# include <wctype.h> - -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 -# ifndef emacs -# define btowc(c) c -# endif - -/* Character classes. */ -typedef enum { RECC_ERROR = 0, - RECC_ALNUM, RECC_ALPHA, RECC_WORD, - RECC_GRAPH, RECC_PRINT, - RECC_LOWER, RECC_UPPER, - RECC_PUNCT, RECC_CNTRL, - RECC_DIGIT, RECC_XDIGIT, - RECC_BLANK, RECC_SPACE, - RECC_MULTIBYTE, RECC_NONASCII, - RECC_ASCII, RECC_UNIBYTE -} re_wctype_t; - -extern char re_iswctype (int ch, re_wctype_t cc); -extern re_wctype_t re_wctype_parse (const unsigned char **strp, unsigned limit); - -typedef int re_wchar_t; - -#endif /* not WIDE_CHAR_SUPPORT */ - -#endif /* regex.h */ - diff --git a/src/scroll.c b/src/scroll.c index 6cbf212f09e..e523a19ab89 100644 --- a/src/scroll.c +++ b/src/scroll.c @@ -28,12 +28,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "frame.h" #include "termhooks.h" -/* All costs measured in characters. - So no cost can exceed the area of a frame, measured in characters. - Let's hope this is never more than 1000000 characters. */ - -#define INFINITY 1000000 - struct matrix_elt { /* Cost of outputting through this line @@ -120,8 +114,8 @@ calculate_scrolling (struct frame *frame, /* initialize the top left corner of the matrix */ matrix->writecost = 0; - matrix->insertcost = INFINITY; - matrix->deletecost = INFINITY; + matrix->insertcost = SCROLL_INFINITY; + matrix->deletecost = SCROLL_INFINITY; matrix->insertcount = 0; matrix->deletecount = 0; @@ -132,8 +126,8 @@ calculate_scrolling (struct frame *frame, p = matrix + i * (window_size + 1); cost += draw_cost[i] + next_insert_cost[i] + extra_cost; p->insertcost = cost; - p->writecost = INFINITY; - p->deletecost = INFINITY; + p->writecost = SCROLL_INFINITY; + p->deletecost = SCROLL_INFINITY; p->insertcount = i; p->deletecount = 0; } @@ -144,8 +138,8 @@ calculate_scrolling (struct frame *frame, { cost += next_delete_cost[j]; matrix[j].deletecost = cost; - matrix[j].writecost = INFINITY; - matrix[j].insertcost = INFINITY; + matrix[j].writecost = SCROLL_INFINITY; + matrix[j].insertcost = SCROLL_INFINITY; matrix[j].deletecount = j; matrix[j].insertcount = 0; } @@ -192,13 +186,13 @@ calculate_scrolling (struct frame *frame, else { cost = p1->writecost + first_insert_cost[i]; - if ((int) p1->insertcount > i) + if (p1->insertcount > i) emacs_abort (); cost1 = p1->insertcost + next_insert_cost[i - p1->insertcount]; } p->insertcost = min (cost, cost1) + draw_cost[i] + extra_cost; p->insertcount = (cost < cost1) ? 1 : p1->insertcount + 1; - if ((int) p->insertcount > i) + if (p->insertcount > i) emacs_abort (); /* Calculate the cost if we do a delete line after @@ -465,8 +459,8 @@ calculate_direct_scrolling (struct frame *frame, /* initialize the top left corner of the matrix */ matrix->writecost = 0; - matrix->insertcost = INFINITY; - matrix->deletecost = INFINITY; + matrix->insertcost = SCROLL_INFINITY; + matrix->deletecost = SCROLL_INFINITY; matrix->writecount = 0; matrix->insertcount = 0; matrix->deletecount = 0; @@ -478,8 +472,8 @@ calculate_direct_scrolling (struct frame *frame, p = matrix + i * (window_size + 1); cost += draw_cost[i]; p->insertcost = cost; - p->writecost = INFINITY; - p->deletecost = INFINITY; + p->writecost = SCROLL_INFINITY; + p->deletecost = SCROLL_INFINITY; p->insertcount = i; p->writecount = 0; p->deletecount = 0; @@ -489,8 +483,8 @@ calculate_direct_scrolling (struct frame *frame, for (j = 1; j <= window_size; j++) { matrix[j].deletecost = 0; - matrix[j].writecost = INFINITY; - matrix[j].insertcost = INFINITY; + matrix[j].writecost = SCROLL_INFINITY; + matrix[j].insertcost = SCROLL_INFINITY; matrix[j].deletecount = j; matrix[j].writecount = 0; matrix[j].insertcount = 0; diff --git a/src/search.c b/src/search.c index 9bde884bc53..702e6e3d8e7 100644 --- a/src/search.c +++ b/src/search.c @@ -30,7 +30,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "blockinput.h" #include "intervals.h" -#include "regex.h" +#include "regex-emacs.h" #define REGEXP_CACHE_SIZE 20 @@ -48,6 +48,8 @@ struct regexp_cache char fastmap[0400]; /* True means regexp was compiled to do full POSIX backtracking. */ bool posix; + /* True means we're inside a buffer match. */ + bool busy; }; /* The instances of that struct. */ @@ -57,8 +59,8 @@ static struct regexp_cache searchbufs[REGEXP_CACHE_SIZE]; static struct regexp_cache *searchbuf_head; -/* 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 +/* Every call to re_search, etc., must pass &search_regs as the regs + argument unless you can show it is unnecessary (i.e., if re_search is certainly going to be called again before region-around-match can be called). @@ -93,6 +95,8 @@ static EMACS_INT search_buffer (Lisp_Object, ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, EMACS_INT, int, Lisp_Object, Lisp_Object, bool); +Lisp_Object re_match_object; + static _Noreturn void matcher_overflow (void) { @@ -110,14 +114,6 @@ freeze_buffer_relocation (void) #endif } -static void -thaw_buffer_relocation (void) -{ -#ifdef REL_ALLOC - unbind_to (SPECPDL_INDEX () - 1, Qnil); -#endif -} - /* Compile a regexp and signal a Lisp error if anything goes wrong. PATTERN is the pattern to compile. CP is the place to put the result. @@ -134,8 +130,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, const char *whitespace_regexp; char *val; + eassert (!cp->busy); cp->regexp = Qnil; - cp->buf.translate = (! NILP (translate) ? translate : make_number (0)); + cp->buf.translate = translate; cp->posix = posix; cp->buf.multibyte = STRING_MULTIBYTE (pattern); cp->buf.charset_unibyte = charset_unibyte; @@ -144,12 +141,6 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, else 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; */ - whitespace_regexp = STRINGP (Vsearch_spaces_regexp) ? SSDATA (Vsearch_spaces_regexp) : NULL; @@ -160,7 +151,6 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, syntax-table, it can only be reused with *this* syntax table. */ cp->syntax_table = cp->buf.used_syntax ? BVAR (current_buffer, syntax_table) : Qt; - /* unblock_input (); */ if (val) xsignal1 (Qinvalid_regexp, build_string (val)); @@ -177,10 +167,11 @@ shrink_regexp_cache (void) struct regexp_cache *cp; for (cp = searchbuf_head; cp != 0; cp = cp->next) - { - cp->buf.allocated = cp->buf.used; - cp->buf.buffer = xrealloc (cp->buf.buffer, cp->buf.used); - } + if (!cp->busy) + { + cp->buf.allocated = cp->buf.used; + cp->buf.buffer = xrealloc (cp->buf.buffer, cp->buf.used); + } } /* Clear the regexp cache w.r.t. a particular syntax table, @@ -197,10 +188,25 @@ clear_regexp_cache (void) /* It's tempting to compare with the syntax-table we've actually changed, but it's not sufficient because char-table inheritance means that modifying one syntax-table can change others at the same time. */ - if (!EQ (searchbufs[i].syntax_table, Qt)) + if (!searchbufs[i].busy && !EQ (searchbufs[i].syntax_table, Qt)) searchbufs[i].regexp = Qnil; } +static void +unfreeze_pattern (void *arg) +{ + struct regexp_cache *searchbuf = arg; + searchbuf->busy = false; +} + +static void +freeze_pattern (struct regexp_cache *searchbuf) +{ + eassert (!searchbuf->busy); + record_unwind_protect_ptr (unfreeze_pattern, searchbuf); + searchbuf->busy = true; +} + /* Compile a regexp if necessary, but first check to see if there's one in the cache. PATTERN is the pattern to compile. @@ -212,7 +218,7 @@ clear_regexp_cache (void) POSIX is true if we want full backtracking (POSIX style) for this pattern. False means backtrack only enough to get a valid match. */ -struct re_pattern_buffer * +static struct regexp_cache * compile_pattern (Lisp_Object pattern, struct re_registers *regp, Lisp_Object translate, bool posix, bool multibyte) { @@ -229,9 +235,10 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, if (NILP (cp->regexp)) goto compile_it; if (SCHARS (cp->regexp) == SCHARS (pattern) + && !cp->busy && STRING_MULTIBYTE (cp->regexp) == STRING_MULTIBYTE (pattern) && !NILP (Fstring_equal (cp->regexp, pattern)) - && EQ (cp->buf.translate, (! NILP (translate) ? translate : make_number (0))) + && EQ (cp->buf.translate, translate) && cp->posix == posix && (EQ (cp->syntax_table, Qt) || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table))) @@ -244,7 +251,10 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, string value. */ if (cp->next == 0) { + if (cp->busy) + error ("Too much matching reentrancy"); compile_it: + eassert (!cp->busy); compile_pattern_1 (cp, pattern, translate, posix); break; } @@ -265,8 +275,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, /* The compiled pattern can be used both for multibyte and unibyte target. But, we have to tell which the pattern is used for. */ cp->buf.target_multibyte = multibyte; - - return &cp->buf; + return cp; } @@ -277,23 +286,27 @@ looking_at_1 (Lisp_Object string, bool posix) unsigned char *p1, *p2; ptrdiff_t s1, s2; register ptrdiff_t i; - struct re_pattern_buffer *bufp; if (running_asynch_code) save_search_regs (); - /* This is so set_image_of_range_1 in regex.c can find the EQV table. */ + /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV + table. */ set_char_table_extras (BVAR (current_buffer, case_canon_table), 2, BVAR (current_buffer, case_eqv_table)); CHECK_STRING (string); - bufp = compile_pattern (string, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : NULL), - (!NILP (BVAR (current_buffer, case_fold_search)) - ? BVAR (current_buffer, case_canon_table) : Qnil), - posix, - !NILP (BVAR (current_buffer, enable_multibyte_characters))); + + /* Snapshot in case Lisp changes the value. */ + bool preserve_match_data = NILP (Vinhibit_changing_match_data); + + struct regexp_cache *cache_entry = compile_pattern ( + string, + preserve_match_data ? &search_regs : NULL, + (!NILP (BVAR (current_buffer, case_fold_search)) + ? BVAR (current_buffer, case_canon_table) : Qnil), + posix, + !NILP (BVAR (current_buffer, enable_multibyte_characters))); /* Do a pending quit right away, to avoid paradoxical behavior */ maybe_quit (); @@ -317,21 +330,20 @@ looking_at_1 (Lisp_Object string, bool posix) s2 = 0; } - re_match_object = Qnil; - + ptrdiff_t count = SPECPDL_INDEX (); freeze_buffer_relocation (); - i = re_match_2 (bufp, (char *) p1, s1, (char *) p2, s2, + freeze_pattern (cache_entry); + re_match_object = Qnil; + i = re_match_2 (&cache_entry->buf, (char *) p1, s1, (char *) p2, s2, PT_BYTE - BEGV_BYTE, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : NULL), + preserve_match_data ? &search_regs : NULL, ZV_BYTE - BEGV_BYTE); - thaw_buffer_relocation (); if (i == -2) matcher_overflow (); val = (i >= 0 ? Qt : Qnil); - if (NILP (Vinhibit_changing_match_data) && i >= 0) + if (preserve_match_data && i >= 0) { for (i = 0; i < search_regs.num_regs; i++) if (search_regs.start[i] >= 0) @@ -345,7 +357,7 @@ looking_at_1 (Lisp_Object string, bool posix) XSETBUFFER (last_thing_searched, current_buffer); } - return val; + return unbind_to (count, val); } DEFUN ("looking-at", Flooking_at, Slooking_at, 1, 1, 0, @@ -390,8 +402,8 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, { ptrdiff_t len = SCHARS (string); - CHECK_NUMBER (start); - pos = XINT (start); + CHECK_FIXNUM (start); + pos = XFIXNUM (start); if (pos < 0 && -pos <= len) pos = len + pos; else if (0 > pos || pos > len) @@ -399,19 +411,19 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, pos_byte = string_char_to_byte (string, pos); } - /* This is so set_image_of_range_1 in regex.c can find the EQV table. */ + /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV + table. */ set_char_table_extras (BVAR (current_buffer, case_canon_table), 2, BVAR (current_buffer, case_eqv_table)); - bufp = compile_pattern (regexp, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : NULL), - (!NILP (BVAR (current_buffer, case_fold_search)) - ? BVAR (current_buffer, case_canon_table) : Qnil), - posix, - STRING_MULTIBYTE (string)); + bufp = &compile_pattern (regexp, + (NILP (Vinhibit_changing_match_data) + ? &search_regs : NULL), + (!NILP (BVAR (current_buffer, case_fold_search)) + ? BVAR (current_buffer, case_canon_table) : Qnil), + posix, + STRING_MULTIBYTE (string))->buf; re_match_object = string; - val = re_search (bufp, SSDATA (string), SBYTES (string), pos_byte, SBYTES (string) - pos_byte, @@ -436,7 +448,7 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, = string_byte_to_char (string, search_regs.end[i]); } - return make_number (string_byte_to_char (string, val)); + return make_fixnum (string_byte_to_char (string, val)); } DEFUN ("string-match", Fstring_match, Sstring_match, 2, 3, 0, @@ -478,10 +490,9 @@ fast_string_match_internal (Lisp_Object regexp, Lisp_Object string, ptrdiff_t val; struct re_pattern_buffer *bufp; - bufp = compile_pattern (regexp, 0, table, - 0, STRING_MULTIBYTE (string)); + bufp = &compile_pattern (regexp, 0, table, + 0, STRING_MULTIBYTE (string))->buf; re_match_object = string; - val = re_search (bufp, SSDATA (string), SBYTES (string), 0, SBYTES (string), 0); @@ -501,10 +512,10 @@ fast_c_string_match_ignore_case (Lisp_Object regexp, struct re_pattern_buffer *bufp; regexp = string_make_unibyte (regexp); + bufp = &compile_pattern (regexp, 0, + Vascii_canon_table, 0, + 0)->buf; re_match_object = Qt; - bufp = compile_pattern (regexp, 0, - Vascii_canon_table, 0, - 0); val = re_search (bufp, string, len, 0, len, 0); return val; } @@ -520,7 +531,6 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t limit, ptrdiff_t limit_byte, Lisp_Object string) { bool multibyte; - struct re_pattern_buffer *buf; unsigned char *p1, *p2; ptrdiff_t s1, s2; ptrdiff_t len; @@ -535,7 +545,6 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte, s1 = 0; p2 = SDATA (string); s2 = SBYTES (string); - re_match_object = string; multibyte = STRING_MULTIBYTE (string); } else @@ -561,16 +570,19 @@ fast_looking_at (Lisp_Object regexp, ptrdiff_t pos, ptrdiff_t pos_byte, s1 = ZV_BYTE - BEGV_BYTE; s2 = 0; } - re_match_object = Qnil; multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters)); } - buf = compile_pattern (regexp, 0, Qnil, 0, multibyte); + struct regexp_cache *cache_entry = + compile_pattern (regexp, 0, Qnil, 0, multibyte); + ptrdiff_t count = SPECPDL_INDEX (); freeze_buffer_relocation (); - len = re_match_2 (buf, (char *) p1, s1, (char *) p2, s2, + freeze_pattern (cache_entry); + re_match_object = STRINGP (string) ? string : Qnil; + len = re_match_2 (&cache_entry->buf, (char *) p1, s1, (char *) p2, s2, pos_byte, NULL, limit_byte); - thaw_buffer_relocation (); + unbind_to (count, Qnil); return len; } @@ -1026,8 +1038,8 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, if (!NILP (count)) { - CHECK_NUMBER (count); - n *= XINT (count); + CHECK_FIXNUM (count); + n *= XFIXNUM (count); } CHECK_STRING (string); @@ -1040,8 +1052,8 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, } else { - CHECK_NUMBER_COERCE_MARKER (bound); - lim = XINT (bound); + CHECK_FIXNUM_COERCE_MARKER (bound); + lim = XFIXNUM (bound); if (n > 0 ? lim < PT : lim > PT) error ("Invalid search bound (wrong side of point)"); if (lim > ZV) @@ -1052,7 +1064,8 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, lim_byte = CHAR_TO_BYTE (lim); } - /* This is so set_image_of_range_1 in regex.c can find the EQV table. */ + /* This is so set_image_of_range_1 in regex-emacs.c can find the EQV + table. */ set_char_table_extras (BVAR (current_buffer, case_canon_table), 2, BVAR (current_buffer, case_eqv_table)); @@ -1086,7 +1099,7 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, eassert (BEGV <= np && np <= ZV); SET_PT (np); - return make_number (np); + return make_fixnum (np); } /* Return true if REGEXP it matches just one constant string. */ @@ -1141,9 +1154,9 @@ do \ if (! NILP (trt)) \ { \ Lisp_Object temp; \ - temp = Faref (trt, make_number (d)); \ - if (INTEGERP (temp)) \ - out = XINT (temp); \ + temp = Faref (trt, make_fixnum (d)); \ + if (FIXNUMP (temp)) \ + out = XFIXNUM (temp); \ else \ out = d; \ } \ @@ -1158,355 +1171,372 @@ while (0) static struct re_registers search_regs_1; static EMACS_INT -search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte, - ptrdiff_t lim, ptrdiff_t lim_byte, EMACS_INT n, - int RE, Lisp_Object trt, Lisp_Object inverse_trt, bool posix) +search_buffer_re (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte, + ptrdiff_t lim, ptrdiff_t lim_byte, EMACS_INT n, + Lisp_Object trt, Lisp_Object inverse_trt, bool posix) { - ptrdiff_t len = SCHARS (string); - ptrdiff_t len_byte = SBYTES (string); - register ptrdiff_t i; + unsigned char *p1, *p2; + ptrdiff_t s1, s2; - if (running_asynch_code) - save_search_regs (); + /* Snapshot in case Lisp changes the value. */ + bool preserve_match_data = NILP (Vinhibit_changing_match_data); - /* Searching 0 times means don't move. */ - /* Null string is found at starting position. */ - if (len == 0 || n == 0) + struct regexp_cache *cache_entry = + compile_pattern (string, + preserve_match_data ? &search_regs : &search_regs_1, + trt, posix, + !NILP (BVAR (current_buffer, enable_multibyte_characters))); + struct re_pattern_buffer *bufp = &cache_entry->buf; + + maybe_quit (); /* Do a pending quit right away, + to avoid paradoxical behavior */ + /* Get pointers and sizes of the two strings + that make up the visible portion of the buffer. */ + + p1 = BEGV_ADDR; + s1 = GPT_BYTE - BEGV_BYTE; + p2 = GAP_END_ADDR; + s2 = ZV_BYTE - GPT_BYTE; + if (s1 < 0) { - set_search_regs (pos_byte, 0); - return pos; + p2 = p1; + s2 = ZV_BYTE - BEGV_BYTE; + s1 = 0; } - - if (RE && !(trivial_regexp_p (string) && NILP (Vsearch_spaces_regexp))) + if (s2 < 0) { - unsigned char *p1, *p2; - ptrdiff_t s1, s2; - struct re_pattern_buffer *bufp; + s1 = ZV_BYTE - BEGV_BYTE; + s2 = 0; + } - bufp = compile_pattern (string, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : &search_regs_1), - trt, posix, - !NILP (BVAR (current_buffer, enable_multibyte_characters))); + ptrdiff_t count = SPECPDL_INDEX (); + freeze_buffer_relocation (); + freeze_pattern (cache_entry); - maybe_quit (); /* Do a pending quit right away, - to avoid paradoxical behavior */ - /* Get pointers and sizes of the two strings - that make up the visible portion of the buffer. */ + while (n < 0) + { + ptrdiff_t val; - p1 = BEGV_ADDR; - s1 = GPT_BYTE - BEGV_BYTE; - p2 = GAP_END_ADDR; - s2 = ZV_BYTE - GPT_BYTE; - if (s1 < 0) - { - p2 = p1; - s2 = ZV_BYTE - BEGV_BYTE; - s1 = 0; - } - if (s2 < 0) - { - s1 = ZV_BYTE - BEGV_BYTE; - s2 = 0; - } re_match_object = Qnil; + val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2, + pos_byte - BEGV_BYTE, lim_byte - pos_byte, + preserve_match_data ? &search_regs : &search_regs_1, + /* Don't allow match past current point */ + pos_byte - BEGV_BYTE); + if (val == -2) + { + matcher_overflow (); + } + if (val >= 0) + { + if (preserve_match_data) + { + pos_byte = search_regs.start[0] + BEGV_BYTE; + for (ptrdiff_t i = 0; i < search_regs.num_regs; i++) + if (search_regs.start[i] >= 0) + { + search_regs.start[i] + = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE); + search_regs.end[i] + = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE); + } + XSETBUFFER (last_thing_searched, current_buffer); + /* Set pos to the new position. */ + pos = search_regs.start[0]; + } + else + { + pos_byte = search_regs_1.start[0] + BEGV_BYTE; + /* Set pos to the new position. */ + pos = BYTE_TO_CHAR (search_regs_1.start[0] + BEGV_BYTE); + } + } + else + { + unbind_to (count, Qnil); + return (n); + } + n++; + maybe_quit (); + } + while (n > 0) + { + ptrdiff_t val; - freeze_buffer_relocation (); + re_match_object = Qnil; + val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2, + pos_byte - BEGV_BYTE, lim_byte - pos_byte, + preserve_match_data ? &search_regs : &search_regs_1, + lim_byte - BEGV_BYTE); + if (val == -2) + { + matcher_overflow (); + } + if (val >= 0) + { + if (preserve_match_data) + { + pos_byte = search_regs.end[0] + BEGV_BYTE; + for (ptrdiff_t i = 0; i < search_regs.num_regs; i++) + if (search_regs.start[i] >= 0) + { + search_regs.start[i] + = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE); + search_regs.end[i] + = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE); + } + XSETBUFFER (last_thing_searched, current_buffer); + pos = search_regs.end[0]; + } + else + { + pos_byte = search_regs_1.end[0] + BEGV_BYTE; + pos = BYTE_TO_CHAR (search_regs_1.end[0] + BEGV_BYTE); + } + } + else + { + unbind_to (count, Qnil); + return (0 - n); + } + n--; + maybe_quit (); + } + unbind_to (count, Qnil); + return (pos); +} - while (n < 0) - { - ptrdiff_t val; - - val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2, - pos_byte - BEGV_BYTE, lim_byte - pos_byte, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : &search_regs_1), - /* Don't allow match past current point */ - pos_byte - BEGV_BYTE); - if (val == -2) - { - matcher_overflow (); - } - if (val >= 0) - { - if (NILP (Vinhibit_changing_match_data)) - { - pos_byte = search_regs.start[0] + BEGV_BYTE; - for (i = 0; i < search_regs.num_regs; i++) - if (search_regs.start[i] >= 0) - { - search_regs.start[i] - = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE); - search_regs.end[i] - = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE); - } - XSETBUFFER (last_thing_searched, current_buffer); - /* Set pos to the new position. */ - pos = search_regs.start[0]; - } - else - { - pos_byte = search_regs_1.start[0] + BEGV_BYTE; - /* Set pos to the new position. */ - pos = BYTE_TO_CHAR (search_regs_1.start[0] + BEGV_BYTE); - } - } - else - { - thaw_buffer_relocation (); - return (n); - } - n++; - maybe_quit (); - } - while (n > 0) - { - ptrdiff_t val; - - val = re_search_2 (bufp, (char *) p1, s1, (char *) p2, s2, - pos_byte - BEGV_BYTE, lim_byte - pos_byte, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : &search_regs_1), - lim_byte - BEGV_BYTE); - if (val == -2) - { - matcher_overflow (); - } - if (val >= 0) - { - if (NILP (Vinhibit_changing_match_data)) - { - pos_byte = search_regs.end[0] + BEGV_BYTE; - for (i = 0; i < search_regs.num_regs; i++) - if (search_regs.start[i] >= 0) - { - search_regs.start[i] - = BYTE_TO_CHAR (search_regs.start[i] + BEGV_BYTE); - search_regs.end[i] - = BYTE_TO_CHAR (search_regs.end[i] + BEGV_BYTE); - } - XSETBUFFER (last_thing_searched, current_buffer); - pos = search_regs.end[0]; - } - else - { - pos_byte = search_regs_1.end[0] + BEGV_BYTE; - pos = BYTE_TO_CHAR (search_regs_1.end[0] + BEGV_BYTE); - } - } - else - { - thaw_buffer_relocation (); - return (0 - n); - } - n--; - maybe_quit (); - } - thaw_buffer_relocation (); - return (pos); +static EMACS_INT +search_buffer_non_re (Lisp_Object string, ptrdiff_t pos, + ptrdiff_t pos_byte, ptrdiff_t lim, ptrdiff_t lim_byte, + EMACS_INT n, int RE, Lisp_Object trt, Lisp_Object inverse_trt, + bool posix) +{ + unsigned char *raw_pattern, *pat; + ptrdiff_t raw_pattern_size; + ptrdiff_t raw_pattern_size_byte; + unsigned char *patbuf; + bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); + unsigned char *base_pat; + /* Set to positive if we find a non-ASCII char that need + translation. Otherwise set to zero later. */ + int char_base = -1; + bool boyer_moore_ok = 1; + USE_SAFE_ALLOCA; + + /* MULTIBYTE says whether the text to be searched is multibyte. + We must convert PATTERN to match that, or we will not really + find things right. */ + + if (multibyte == STRING_MULTIBYTE (string)) + { + raw_pattern = SDATA (string); + raw_pattern_size = SCHARS (string); + raw_pattern_size_byte = SBYTES (string); } - else /* non-RE case */ + else if (multibyte) { - unsigned char *raw_pattern, *pat; - ptrdiff_t raw_pattern_size; - ptrdiff_t raw_pattern_size_byte; - unsigned char *patbuf; - bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); - unsigned char *base_pat; - /* Set to positive if we find a non-ASCII char that need - translation. Otherwise set to zero later. */ - int char_base = -1; - bool boyer_moore_ok = 1; - USE_SAFE_ALLOCA; - - /* MULTIBYTE says whether the text to be searched is multibyte. - We must convert PATTERN to match that, or we will not really - find things right. */ - - if (multibyte == STRING_MULTIBYTE (string)) - { - raw_pattern = SDATA (string); - raw_pattern_size = SCHARS (string); - raw_pattern_size_byte = SBYTES (string); - } - else if (multibyte) - { - raw_pattern_size = SCHARS (string); - raw_pattern_size_byte - = count_size_as_multibyte (SDATA (string), - raw_pattern_size); - raw_pattern = SAFE_ALLOCA (raw_pattern_size_byte + 1); - copy_text (SDATA (string), raw_pattern, - SCHARS (string), 0, 1); - } - else - { - /* Converting multibyte to single-byte. - - ??? Perhaps this conversion should be done in a special way - by subtracting nonascii-insert-offset from each non-ASCII char, - so that only the multibyte chars which really correspond to - the chosen single-byte character set can possibly match. */ - raw_pattern_size = SCHARS (string); - raw_pattern_size_byte = SCHARS (string); - raw_pattern = SAFE_ALLOCA (raw_pattern_size + 1); - copy_text (SDATA (string), raw_pattern, - SBYTES (string), 1, 0); - } + raw_pattern_size = SCHARS (string); + raw_pattern_size_byte + = count_size_as_multibyte (SDATA (string), + raw_pattern_size); + raw_pattern = SAFE_ALLOCA (raw_pattern_size_byte + 1); + copy_text (SDATA (string), raw_pattern, + SCHARS (string), 0, 1); + } + else + { + /* Converting multibyte to single-byte. + + ??? Perhaps this conversion should be done in a special way + by subtracting nonascii-insert-offset from each non-ASCII char, + so that only the multibyte chars which really correspond to + the chosen single-byte character set can possibly match. */ + raw_pattern_size = SCHARS (string); + raw_pattern_size_byte = SCHARS (string); + raw_pattern = SAFE_ALLOCA (raw_pattern_size + 1); + copy_text (SDATA (string), raw_pattern, + SBYTES (string), 1, 0); + } - /* Copy and optionally translate the pattern. */ - len = raw_pattern_size; - len_byte = raw_pattern_size_byte; - SAFE_NALLOCA (patbuf, MAX_MULTIBYTE_LENGTH, len); - pat = patbuf; - base_pat = raw_pattern; - if (multibyte) - { - /* Fill patbuf by translated characters in STRING while - checking if we can use boyer-moore search. If TRT is - non-nil, we can use boyer-moore search only if TRT can be - represented by the byte array of 256 elements. For that, - all non-ASCII case-equivalents of all case-sensitive - characters in STRING must belong to the same character - group (two characters belong to the same group iff their - multibyte forms are the same except for the last byte; - i.e. every 64 characters form a group; U+0000..U+003F, - U+0040..U+007F, U+0080..U+00BF, ...). */ - - while (--len >= 0) - { - unsigned char str_base[MAX_MULTIBYTE_LENGTH], *str; - int c, translated, inverse; - int in_charlen, charlen; - - /* If we got here and the RE flag is set, it's because we're - dealing with a regexp known to be trivial, so the backslash - just quotes the next character. */ - if (RE && *base_pat == '\\') - { - len--; - raw_pattern_size--; - len_byte--; - base_pat++; - } + /* Copy and optionally translate the pattern. */ + ptrdiff_t len = raw_pattern_size; + ptrdiff_t len_byte = raw_pattern_size_byte; + SAFE_NALLOCA (patbuf, MAX_MULTIBYTE_LENGTH, len); + pat = patbuf; + base_pat = raw_pattern; + if (multibyte) + { + /* Fill patbuf by translated characters in STRING while + checking if we can use boyer-moore search. If TRT is + non-nil, we can use boyer-moore search only if TRT can be + represented by the byte array of 256 elements. For that, + all non-ASCII case-equivalents of all case-sensitive + characters in STRING must belong to the same character + group (two characters belong to the same group iff their + multibyte forms are the same except for the last byte; + i.e. every 64 characters form a group; U+0000..U+003F, + U+0040..U+007F, U+0080..U+00BF, ...). */ + + while (--len >= 0) + { + unsigned char str_base[MAX_MULTIBYTE_LENGTH], *str; + int c, translated, inverse; + int in_charlen, charlen; + + /* If we got here and the RE flag is set, it's because we're + dealing with a regexp known to be trivial, so the backslash + just quotes the next character. */ + if (RE && *base_pat == '\\') + { + len--; + raw_pattern_size--; + len_byte--; + base_pat++; + } - c = STRING_CHAR_AND_LENGTH (base_pat, in_charlen); + c = STRING_CHAR_AND_LENGTH (base_pat, in_charlen); - if (NILP (trt)) - { - str = base_pat; - charlen = in_charlen; - } - else - { - /* Translate the character. */ - TRANSLATE (translated, trt, c); - charlen = CHAR_STRING (translated, str_base); - str = str_base; - - /* Check if C has any other case-equivalents. */ - TRANSLATE (inverse, inverse_trt, c); - /* If so, check if we can use boyer-moore. */ - if (c != inverse && boyer_moore_ok) - { - /* Check if all equivalents belong to the same - group of characters. Note that the check of C - itself is done by the last iteration. */ - int this_char_base = -1; + if (NILP (trt)) + { + str = base_pat; + charlen = in_charlen; + } + else + { + /* Translate the character. */ + TRANSLATE (translated, trt, c); + charlen = CHAR_STRING (translated, str_base); + str = str_base; + + /* Check if C has any other case-equivalents. */ + TRANSLATE (inverse, inverse_trt, c); + /* If so, check if we can use boyer-moore. */ + if (c != inverse && boyer_moore_ok) + { + /* Check if all equivalents belong to the same + group of characters. Note that the check of C + itself is done by the last iteration. */ + int this_char_base = -1; + + while (boyer_moore_ok) + { + if (ASCII_CHAR_P (inverse)) + { + if (this_char_base > 0) + boyer_moore_ok = 0; + else + this_char_base = 0; + } + else if (CHAR_BYTE8_P (inverse)) + /* Boyer-moore search can't handle a + translation of an eight-bit + character. */ + boyer_moore_ok = 0; + else if (this_char_base < 0) + { + this_char_base = inverse & ~0x3F; + if (char_base < 0) + char_base = this_char_base; + else if (this_char_base != char_base) + boyer_moore_ok = 0; + } + else if ((inverse & ~0x3F) != this_char_base) + boyer_moore_ok = 0; + if (c == inverse) + break; + TRANSLATE (inverse, inverse_trt, inverse); + } + } + } - while (boyer_moore_ok) - { - if (ASCII_CHAR_P (inverse)) - { - if (this_char_base > 0) - boyer_moore_ok = 0; - else - this_char_base = 0; - } - else if (CHAR_BYTE8_P (inverse)) - /* Boyer-moore search can't handle a - translation of an eight-bit - character. */ - boyer_moore_ok = 0; - else if (this_char_base < 0) - { - this_char_base = inverse & ~0x3F; - if (char_base < 0) - char_base = this_char_base; - else if (this_char_base != char_base) - boyer_moore_ok = 0; - } - else if ((inverse & ~0x3F) != this_char_base) - boyer_moore_ok = 0; - if (c == inverse) - break; - TRANSLATE (inverse, inverse_trt, inverse); - } - } - } + /* Store this character into the translated pattern. */ + memcpy (pat, str, charlen); + pat += charlen; + base_pat += in_charlen; + len_byte -= in_charlen; + } - /* Store this character into the translated pattern. */ - memcpy (pat, str, charlen); - pat += charlen; - base_pat += in_charlen; - len_byte -= in_charlen; - } + /* If char_base is still negative we didn't find any translated + non-ASCII characters. */ + if (char_base < 0) + char_base = 0; + } + else + { + /* Unibyte buffer. */ + char_base = 0; + while (--len >= 0) + { + int c, translated, inverse; - /* If char_base is still negative we didn't find any translated - non-ASCII characters. */ - if (char_base < 0) - char_base = 0; - } - else - { - /* Unibyte buffer. */ - char_base = 0; - while (--len >= 0) - { - int c, translated, inverse; + /* If we got here and the RE flag is set, it's because we're + dealing with a regexp known to be trivial, so the backslash + just quotes the next character. */ + if (RE && *base_pat == '\\') + { + len--; + raw_pattern_size--; + base_pat++; + } + c = *base_pat++; + TRANSLATE (translated, trt, c); + *pat++ = translated; + /* Check that none of C's equivalents violates the + assumptions of boyer_moore. */ + TRANSLATE (inverse, inverse_trt, c); + while (1) + { + if (inverse >= 0200) + { + boyer_moore_ok = 0; + break; + } + if (c == inverse) + break; + TRANSLATE (inverse, inverse_trt, inverse); + } + } + } - /* If we got here and the RE flag is set, it's because we're - dealing with a regexp known to be trivial, so the backslash - just quotes the next character. */ - if (RE && *base_pat == '\\') - { - len--; - raw_pattern_size--; - base_pat++; - } - c = *base_pat++; - TRANSLATE (translated, trt, c); - *pat++ = translated; - /* Check that none of C's equivalents violates the - assumptions of boyer_moore. */ - TRANSLATE (inverse, inverse_trt, c); - while (1) - { - if (inverse >= 0200) - { - boyer_moore_ok = 0; - break; - } - if (c == inverse) - break; - TRANSLATE (inverse, inverse_trt, inverse); - } - } - } + len_byte = pat - patbuf; + pat = base_pat = patbuf; + + EMACS_INT result + = (boyer_moore_ok + ? boyer_moore (n, pat, len_byte, trt, inverse_trt, + pos_byte, lim_byte, + char_base) + : simple_search (n, pat, raw_pattern_size, len_byte, trt, + pos, pos_byte, lim, lim_byte)); + SAFE_FREE (); + return result; +} + +static EMACS_INT +search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte, + ptrdiff_t lim, ptrdiff_t lim_byte, EMACS_INT n, + int RE, Lisp_Object trt, Lisp_Object inverse_trt, bool posix) +{ + if (running_asynch_code) + save_search_regs (); - len_byte = pat - patbuf; - pat = base_pat = patbuf; - - EMACS_INT result - = (boyer_moore_ok - ? boyer_moore (n, pat, len_byte, trt, inverse_trt, - pos_byte, lim_byte, - char_base) - : simple_search (n, pat, raw_pattern_size, len_byte, trt, - pos, pos_byte, lim, lim_byte)); - SAFE_FREE (); - return result; + /* Searching 0 times means don't move. */ + /* Null string is found at starting position. */ + if (n == 0 || SCHARS (string) == 0) + { + set_search_regs (pos_byte, 0); + return pos; } + + if (RE && !(trivial_regexp_p (string) && NILP (Vsearch_spaces_regexp))) + pos = search_buffer_re (string, pos, pos_byte, lim, lim_byte, + n, trt, inverse_trt, posix); + else + pos = search_buffer_non_re (string, pos, pos_byte, lim, lim_byte, + n, RE, trt, inverse_trt, posix); + + return pos; } /* Do a simple string search N times for the string PAT, @@ -2159,8 +2189,8 @@ set_search_regs (ptrdiff_t beg_byte, ptrdiff_t nbytes) the match position. */ if (search_regs.num_regs == 0) { - search_regs.start = xmalloc (2 * sizeof (regoff_t)); - search_regs.end = xmalloc (2 * sizeof (regoff_t)); + search_regs.start = xmalloc (2 * sizeof *search_regs.start); + search_regs.end = xmalloc (2 * sizeof *search_regs.end); search_regs.num_regs = 2; } @@ -2393,10 +2423,10 @@ since only regular expressions have distinguished subexpressions. */) sub = 0; else { - CHECK_NUMBER (subexp); - if (! (0 <= XINT (subexp) && XINT (subexp) < search_regs.num_regs)) - args_out_of_range (subexp, make_number (search_regs.num_regs)); - sub = XINT (subexp); + CHECK_FIXNUM (subexp); + if (! (0 <= XFIXNUM (subexp) && XFIXNUM (subexp) < search_regs.num_regs)) + args_out_of_range (subexp, make_fixnum (search_regs.num_regs)); + sub = XFIXNUM (subexp); } if (NILP (string)) @@ -2404,16 +2434,16 @@ since only regular expressions have distinguished subexpressions. */) if (search_regs.start[sub] < BEGV || search_regs.start[sub] > search_regs.end[sub] || search_regs.end[sub] > ZV) - args_out_of_range (make_number (search_regs.start[sub]), - make_number (search_regs.end[sub])); + args_out_of_range (make_fixnum (search_regs.start[sub]), + make_fixnum (search_regs.end[sub])); } else { if (search_regs.start[sub] < 0 || search_regs.start[sub] > search_regs.end[sub] || search_regs.end[sub] > SCHARS (string)) - args_out_of_range (make_number (search_regs.start[sub]), - make_number (search_regs.end[sub])); + args_out_of_range (make_fixnum (search_regs.start[sub]), + make_fixnum (search_regs.end[sub])); } if (NILP (fixedcase)) @@ -2498,9 +2528,9 @@ since only regular expressions have distinguished subexpressions. */) { Lisp_Object before, after; - before = Fsubstring (string, make_number (0), - make_number (search_regs.start[sub])); - after = Fsubstring (string, make_number (search_regs.end[sub]), Qnil); + before = Fsubstring (string, make_fixnum (0), + make_fixnum (search_regs.start[sub])); + after = Fsubstring (string, make_fixnum (search_regs.end[sub]), Qnil); /* Substitute parts of the match into NEWTEXT if desired. */ @@ -2563,8 +2593,8 @@ since only regular expressions have distinguished subexpressions. */) middle = Qnil; accum = concat3 (accum, middle, Fsubstring (string, - make_number (substart), - make_number (subend))); + make_fixnum (substart), + make_fixnum (subend))); lastpos = pos; lastpos_byte = pos_byte; } @@ -2753,12 +2783,12 @@ since only regular expressions have distinguished subexpressions. */) } if (case_action == all_caps) - Fupcase_region (make_number (search_regs.start[sub]), - make_number (newpoint), + Fupcase_region (make_fixnum (search_regs.start[sub]), + make_fixnum (newpoint), Qnil); else if (case_action == cap_initial) - Fupcase_initials_region (make_number (search_regs.start[sub]), - make_number (newpoint)); + Fupcase_initials_region (make_fixnum (search_regs.start[sub]), + make_fixnum (newpoint)); if (search_regs.start[sub] != sub_start || search_regs.end[sub] != sub_end @@ -2782,16 +2812,16 @@ match_limit (Lisp_Object num, bool beginningp) { EMACS_INT n; - CHECK_NUMBER (num); - n = XINT (num); + CHECK_FIXNUM (num); + n = XFIXNUM (num); if (n < 0) - args_out_of_range (num, make_number (0)); + args_out_of_range (num, make_fixnum (0)); if (search_regs.num_regs <= 0) error ("No match data, because no search succeeded"); if (n >= search_regs.num_regs || search_regs.start[n] < 0) return Qnil; - return (make_number ((beginningp) ? search_regs.start[n] + return (make_fixnum ((beginningp) ? search_regs.start[n] : search_regs.end[n])); } @@ -2881,11 +2911,11 @@ Return value is undefined if the last search failed. */) { data[2 * i] = Fmake_marker (); Fset_marker (data[2 * i], - make_number (start), + make_fixnum (start), last_thing_searched); data[2 * i + 1] = Fmake_marker (); Fset_marker (data[2 * i + 1], - make_number (search_regs.end[i]), + make_fixnum (search_regs.end[i]), last_thing_searched); } else @@ -2962,7 +2992,7 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) /* Allocate registers if they don't already exist. */ { - EMACS_INT length = XFASTINT (Flength (list)) / 2; + EMACS_INT length = XFIXNAT (Flength (list)) / 2; if (length > search_regs.num_regs) { @@ -2971,9 +3001,9 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) memory_full (SIZE_MAX); search_regs.start = xpalloc (search_regs.start, &num_regs, length - num_regs, - min (PTRDIFF_MAX, UINT_MAX), sizeof (regoff_t)); + min (PTRDIFF_MAX, UINT_MAX), sizeof *search_regs.start); search_regs.end = - xrealloc (search_regs.end, num_regs * sizeof (regoff_t)); + xrealloc (search_regs.end, num_regs * sizeof *search_regs.end); for (i = search_regs.num_regs; i < num_regs; i++) search_regs.start[i] = -1; @@ -3010,7 +3040,7 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) XSETBUFFER (last_thing_searched, XMARKER (marker)->buffer); } - CHECK_NUMBER_COERCE_MARKER (marker); + CHECK_FIXNUM_COERCE_MARKER (marker); from = marker; if (!NILP (reseat) && MARKERP (m)) @@ -3027,16 +3057,13 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) if (MARKERP (marker) && XMARKER (marker)->buffer == 0) XSETFASTINT (marker, 0); - CHECK_NUMBER_COERCE_MARKER (marker); - if ((XINT (from) < 0 - ? TYPE_MINIMUM (regoff_t) <= XINT (from) - : XINT (from) <= TYPE_MAXIMUM (regoff_t)) - && (XINT (marker) < 0 - ? TYPE_MINIMUM (regoff_t) <= XINT (marker) - : XINT (marker) <= TYPE_MAXIMUM (regoff_t))) + CHECK_FIXNUM_COERCE_MARKER (marker); + if (PTRDIFF_MIN <= XFIXNUM (from) && XFIXNUM (from) <= PTRDIFF_MAX + && PTRDIFF_MIN <= XFIXNUM (marker) + && XFIXNUM (marker) <= PTRDIFF_MAX) { - search_regs.start[i] = XINT (from); - search_regs.end[i] = XINT (marker); + search_regs.start[i] = XFIXNUM (from); + search_regs.end[i] = XFIXNUM (marker); } else { @@ -3322,11 +3349,11 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */) NULL, true); if (shortage != 0 || i >= nl_count_cache) break; - ASET (cache_newlines, i, make_number (found - 1)); + ASET (cache_newlines, i, make_fixnum (found - 1)); } /* Fill the rest of slots with an invalid position. */ for ( ; i < nl_count_cache; i++) - ASET (cache_newlines, i, make_number (-1)); + ASET (cache_newlines, i, make_fixnum (-1)); } /* Now do the same, but without using the cache. */ @@ -3344,10 +3371,10 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */) NULL, true); if (shortage != 0 || i >= nl_count_buf) break; - ASET (buf_newlines, i, make_number (found - 1)); + ASET (buf_newlines, i, make_fixnum (found - 1)); } for ( ; i < nl_count_buf; i++) - ASET (buf_newlines, i, make_number (-1)); + ASET (buf_newlines, i, make_fixnum (-1)); } /* Construct the value and return it. */ @@ -3360,6 +3387,7 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */) return val; } + void syms_of_search (void) { @@ -3372,6 +3400,7 @@ syms_of_search (void) searchbufs[i].buf.fastmap = searchbufs[i].fastmap; searchbufs[i].regexp = Qnil; searchbufs[i].f_whitespace_regexp = Qnil; + searchbufs[i].busy = false; searchbufs[i].syntax_table = Qnil; staticpro (&searchbufs[i].regexp); staticpro (&searchbufs[i].f_whitespace_regexp); @@ -3412,6 +3441,9 @@ syms_of_search (void) saved_last_thing_searched = Qnil; staticpro (&saved_last_thing_searched); + re_match_object = Qnil; + staticpro (&re_match_object); + DEFVAR_LISP ("search-spaces-regexp", Vsearch_spaces_regexp, doc: /* Regexp to substitute for bunches of spaces in regexp search. Some commands use this for user-specified regexps. diff --git a/src/sound.c b/src/sound.c index c1f869045f5..2b8715010e7 100644 --- a/src/sound.c +++ b/src/sound.c @@ -2,6 +2,8 @@ Copyright (C) 1998-1999, 2001-2019 Free Software Foundation, Inc. +Author: Gerd Moellmann <gerd@gnu.org> + This file is part of GNU Emacs. GNU Emacs is free software: you can redistribute it and/or modify @@ -17,8 +19,7 @@ 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 <https://www.gnu.org/licenses/>. */ -/* Written by Gerd Moellmann <gerd@gnu.org>. Tested with Luigi's - driver on FreeBSD 2.2.7 with a SoundBlaster 16. */ +/* Tested with Luigi's driver on FreeBSD 2.2.7 with a SoundBlaster 16. */ /* Modified by Ben Key <Bkey1@tampabay.rr.com> to add a partial @@ -384,9 +385,9 @@ parse_sound (Lisp_Object sound, Lisp_Object *attrs) /* Volume must be in the range 0..100 or unspecified. */ if (!NILP (attrs[SOUND_VOLUME])) { - if (INTEGERP (attrs[SOUND_VOLUME])) + if (FIXNUMP (attrs[SOUND_VOLUME])) { - EMACS_INT volume = XINT (attrs[SOUND_VOLUME]); + EMACS_INT volume = XFIXNUM (attrs[SOUND_VOLUME]); if (! (0 <= volume && volume <= 100)) return 0; } @@ -1399,8 +1400,8 @@ Internal use only, use `play-sound' instead. */) /* Set up a device. */ current_sound_device->file = attrs[SOUND_DEVICE]; - if (INTEGERP (attrs[SOUND_VOLUME])) - current_sound_device->volume = XFASTINT (attrs[SOUND_VOLUME]); + if (FIXNUMP (attrs[SOUND_VOLUME])) + current_sound_device->volume = XFIXNAT (attrs[SOUND_VOLUME]); else if (FLOATP (attrs[SOUND_VOLUME])) current_sound_device->volume = XFLOAT_DATA (attrs[SOUND_VOLUME]) * 100; @@ -1422,9 +1423,9 @@ Internal use only, use `play-sound' instead. */) file = Fexpand_file_name (attrs[SOUND_FILE], Vdata_directory); file = ENCODE_FILE (file); - if (INTEGERP (attrs[SOUND_VOLUME])) + if (FIXNUMP (attrs[SOUND_VOLUME])) { - ui_volume_tmp = XFASTINT (attrs[SOUND_VOLUME]); + ui_volume_tmp = XFIXNAT (attrs[SOUND_VOLUME]); } else if (FLOATP (attrs[SOUND_VOLUME])) { diff --git a/src/syntax.c b/src/syntax.c index 3cc32094a8c..ba8f5fcfa9e 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -23,7 +23,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "character.h" #include "buffer.h" -#include "regex.h" +#include "regex-emacs.h" #include "syntax.h" #include "intervals.h" #include "category.h" @@ -267,9 +267,10 @@ SETUP_SYNTAX_TABLE (ptrdiff_t from, ptrdiff_t count) If it is t (which is only used in fast_c_string_match_ignore_case), ignore properties altogether. - This is meant for regex.c to use. For buffers, regex.c passes arguments - to the UPDATE_SYNTAX_TABLE functions which are relative to BEGV. - So if it is a buffer, we set the offset field to BEGV. */ + This is meant for regex-emacs.c to use. For buffers, regex-emacs.c + passes arguments to the UPDATE_SYNTAX_TABLE functions which are + relative to BEGV. So if it is a buffer, we set the offset field to + BEGV. */ void SETUP_SYNTAX_TABLE_FOR_OBJECT (Lisp_Object object, @@ -490,7 +491,7 @@ parse_sexp_propertize (ptrdiff_t charpos) { EMACS_INT modiffs = CHARS_MODIFF; safe_call1 (Qinternal__syntax_propertize, - make_number (min (zv, 1 + charpos))); + make_fixnum (min (zv, 1 + charpos))); if (modiffs != CHARS_MODIFF) error ("parse-sexp-propertize-function modified the buffer!"); if (syntax_propertize__done <= charpos @@ -605,6 +606,26 @@ find_defun_start (ptrdiff_t pos, ptrdiff_t pos_byte) && MODIFF == find_start_modiff) return find_start_value; + if (!NILP (Vcomment_use_syntax_ppss)) + { + EMACS_INT modiffs = CHARS_MODIFF; + Lisp_Object ppss = call1 (Qsyntax_ppss, make_fixnum (pos)); + if (modiffs != CHARS_MODIFF) + error ("syntax-ppss modified the buffer!"); + TEMP_SET_PT_BOTH (opoint, opoint_byte); + Lisp_Object boc = Fnth (make_fixnum (8), ppss); + if (FIXNUMP (boc)) + { + find_start_value = XFIXNUM (boc); + find_start_value_byte = CHAR_TO_BYTE (find_start_value); + } + else + { + find_start_value = pos; + find_start_value_byte = pos_byte; + } + goto found; + } if (!open_paren_in_column_0_is_defun_start) { find_start_value = BEGV; @@ -874,6 +895,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, case Sopen: /* Assume a defun-start point is outside of strings. */ if (open_paren_in_column_0_is_defun_start + && NILP (Vcomment_use_syntax_ppss) && (from == stop || (temp_byte = dec_bytepos (from_byte), FETCH_CHAR (temp_byte) == '\n'))) @@ -931,7 +953,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, { adjusted = true; find_start_value - = CONSP (state.levelstarts) ? XINT (XCAR (state.levelstarts)) + = CONSP (state.levelstarts) ? XFIXNUM (XCAR (state.levelstarts)) : state.thislevelstart >= 0 ? state.thislevelstart : find_start_value; find_start_value_byte = CHAR_TO_BYTE (find_start_value); @@ -1097,9 +1119,9 @@ this is probably the wrong function to use, because it can't take { int char_int; CHECK_CHARACTER (character); - char_int = XINT (character); + char_int = XFIXNUM (character); SETUP_BUFFER_SYNTAX_TABLE (); - return make_number (syntax_code_spec[SYNTAX (char_int)]); + return make_fixnum (syntax_code_spec[SYNTAX (char_int)]); } DEFUN ("matching-paren", Fmatching_paren, Smatching_paren, 1, 1, 0, @@ -1109,7 +1131,7 @@ DEFUN ("matching-paren", Fmatching_paren, Smatching_paren, 1, 1, 0, int char_int; enum syntaxcode code; CHECK_CHARACTER (character); - char_int = XINT (character); + char_int = XFIXNUM (character); SETUP_BUFFER_SYNTAX_TABLE (); code = SYNTAX (char_int); if (code == Sopen || code == Sclose) @@ -1144,7 +1166,7 @@ the value of a `syntax-table' text property. */) int len; int character = STRING_CHAR_AND_LENGTH (p, len); XSETINT (match, character); - if (XFASTINT (match) == ' ') + if (XFIXNAT (match) == ' ') match = Qnil; p += len; } @@ -1191,7 +1213,7 @@ the value of a `syntax-table' text property. */) return AREF (Vsyntax_code_object, val); else /* Since we can't use a shared object, let's make a new one. */ - return Fcons (make_number (val), match); + return Fcons (make_fixnum (val), match); } /* I really don't know why this is interactive @@ -1256,7 +1278,7 @@ usage: (modify-syntax-entry CHAR NEWENTRY &optional SYNTAX-TABLE) */) if (CONSP (c)) SET_RAW_SYNTAX_ENTRY_RANGE (syntax_table, c, newentry); else - SET_RAW_SYNTAX_ENTRY (syntax_table, XINT (c), newentry); + SET_RAW_SYNTAX_ENTRY (syntax_table, XFIXNUM (c), newentry); /* We clear the regexp cache, since character classes can now have different values from those in the compiled regexps.*/ @@ -1298,13 +1320,13 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value, first = XCAR (value); match_lisp = XCDR (value); - if (!INTEGERP (first) || !(NILP (match_lisp) || CHARACTERP (match_lisp))) + if (!FIXNUMP (first) || !(NILP (match_lisp) || CHARACTERP (match_lisp))) { insert_string ("invalid"); return syntax; } - syntax_code = XINT (first) & INT_MAX; + syntax_code = XFIXNUM (first) & INT_MAX; code = syntax_code & 0377; start1 = SYNTAX_FLAGS_COMSTART_FIRST (syntax_code); start2 = SYNTAX_FLAGS_COMSTART_SECOND (syntax_code); @@ -1327,7 +1349,7 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value, if (NILP (match_lisp)) insert (" ", 1); else - insert_char (XINT (match_lisp)); + insert_char (XFIXNUM (match_lisp)); if (start1) insert ("1", 1); @@ -1392,7 +1414,7 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value, if (!NILP (match_lisp)) { insert_string (", matches "); - insert_char (XINT (match_lisp)); + insert_char (XFIXNUM (match_lisp)); } if (start1) @@ -1459,10 +1481,10 @@ scan_words (ptrdiff_t from, EMACS_INT count) func = CHAR_TABLE_REF (Vfind_word_boundary_function_table, ch0); if (! NILP (Ffboundp (func))) { - pos = call2 (func, make_number (from - 1), make_number (end)); - if (INTEGERP (pos) && from < XINT (pos) && XINT (pos) <= ZV) + pos = call2 (func, make_fixnum (from - 1), make_fixnum (end)); + if (FIXNUMP (pos) && from < XFIXNUM (pos) && XFIXNUM (pos) <= ZV) { - from = XINT (pos); + from = XFIXNUM (pos); from_byte = CHAR_TO_BYTE (from); } } @@ -1508,10 +1530,10 @@ scan_words (ptrdiff_t from, EMACS_INT count) func = CHAR_TABLE_REF (Vfind_word_boundary_function_table, ch1); if (! NILP (Ffboundp (func))) { - pos = call2 (func, make_number (from), make_number (beg)); - if (INTEGERP (pos) && BEGV <= XINT (pos) && XINT (pos) < from) + pos = call2 (func, make_fixnum (from), make_fixnum (beg)); + if (FIXNUMP (pos) && BEGV <= XFIXNUM (pos) && XFIXNUM (pos) < from) { - from = XINT (pos); + from = XFIXNUM (pos); from_byte = CHAR_TO_BYTE (from); } } @@ -1565,16 +1587,16 @@ instead. See Info node `(elisp) Word Motion' for details. */) if (NILP (arg)) XSETFASTINT (arg, 1); else - CHECK_NUMBER (arg); + CHECK_FIXNUM (arg); - val = orig_val = scan_words (PT, XINT (arg)); + val = orig_val = scan_words (PT, XFIXNUM (arg)); if (! orig_val) - val = XINT (arg) > 0 ? ZV : BEGV; + val = XFIXNUM (arg) > 0 ? ZV : BEGV; /* Avoid jumping out of an input field. */ - tmp = Fconstrain_to_field (make_number (val), make_number (PT), + tmp = Fconstrain_to_field (make_fixnum (val), make_fixnum (PT), Qnil, Qnil, Qnil); - val = XFASTINT (tmp); + val = XFIXNAT (tmp); SET_PT (val); return val == orig_val ? Qt : Qnil; @@ -1655,16 +1677,16 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, if (NILP (lim)) XSETINT (lim, forwardp ? ZV : BEGV); else - CHECK_NUMBER_COERCE_MARKER (lim); + CHECK_FIXNUM_COERCE_MARKER (lim); /* In any case, don't allow scan outside bounds of buffer. */ - if (XINT (lim) > ZV) + if (XFIXNUM (lim) > ZV) XSETFASTINT (lim, ZV); - if (XINT (lim) < BEGV) + if (XFIXNUM (lim) < BEGV) XSETFASTINT (lim, BEGV); multibyte = (!NILP (BVAR (current_buffer, enable_multibyte_characters)) - && (XINT (lim) - PT != CHAR_TO_BYTE (XINT (lim)) - PT_BYTE)); + && (XFIXNUM (lim) - PT != CHAR_TO_BYTE (XFIXNUM (lim)) - PT_BYTE)); string_multibyte = SBYTES (string) > SCHARS (string); memset (fastmap, 0, sizeof fastmap); @@ -1700,7 +1722,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, error ("Invalid ISO C character class"); if (cc != -1) { - iso_classes = Fcons (make_number (cc), iso_classes); + iso_classes = Fcons (make_fixnum (cc), iso_classes); i_byte = ch - str; continue; } @@ -1796,7 +1818,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, error ("Invalid ISO C character class"); if (cc != -1) { - iso_classes = Fcons (make_number (cc), iso_classes); + iso_classes = Fcons (make_fixnum (cc), iso_classes); i_byte = ch - str; continue; } @@ -1915,13 +1937,13 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, if (forwardp) { - endp = (XINT (lim) == GPT) ? GPT_ADDR : CHAR_POS_ADDR (XINT (lim)); - stop = (pos < GPT && GPT < XINT (lim)) ? GPT_ADDR : endp; + endp = (XFIXNUM (lim) == GPT) ? GPT_ADDR : CHAR_POS_ADDR (XFIXNUM (lim)); + stop = (pos < GPT && GPT < XFIXNUM (lim)) ? GPT_ADDR : endp; } else { - endp = CHAR_POS_ADDR (XINT (lim)); - stop = (pos >= GPT && GPT > XINT (lim)) ? GAP_END_ADDR : endp; + endp = CHAR_POS_ADDR (XFIXNUM (lim)); + stop = (pos >= GPT && GPT > XFIXNUM (lim)) ? GAP_END_ADDR : endp; } /* This code may look up syntax tables using functions that rely on the @@ -2073,7 +2095,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, SET_PT_BOTH (pos, pos_byte); SAFE_FREE (); - return make_number (PT - start_point); + return make_fixnum (PT - start_point); } } @@ -2094,19 +2116,19 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) if (NILP (lim)) XSETINT (lim, forwardp ? ZV : BEGV); else - CHECK_NUMBER_COERCE_MARKER (lim); + CHECK_FIXNUM_COERCE_MARKER (lim); /* In any case, don't allow scan outside bounds of buffer. */ - if (XINT (lim) > ZV) + if (XFIXNUM (lim) > ZV) XSETFASTINT (lim, ZV); - if (XINT (lim) < BEGV) + if (XFIXNUM (lim) < BEGV) XSETFASTINT (lim, BEGV); - if (forwardp ? (PT >= XFASTINT (lim)) : (PT <= XFASTINT (lim))) - return make_number (0); + if (forwardp ? (PT >= XFIXNAT (lim)) : (PT <= XFIXNAT (lim))) + return make_fixnum (0); multibyte = (!NILP (BVAR (current_buffer, enable_multibyte_characters)) - && (XINT (lim) - PT != CHAR_TO_BYTE (XINT (lim)) - PT_BYTE)); + && (XFIXNUM (lim) - PT != CHAR_TO_BYTE (XFIXNUM (lim)) - PT_BYTE)); memset (fastmap, 0, sizeof fastmap); @@ -2151,8 +2173,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) while (true) { p = BYTE_POS_ADDR (pos_byte); - endp = XINT (lim) == GPT ? GPT_ADDR : CHAR_POS_ADDR (XINT (lim)); - stop = pos < GPT && GPT < XINT (lim) ? GPT_ADDR : endp; + endp = XFIXNUM (lim) == GPT ? GPT_ADDR : CHAR_POS_ADDR (XFIXNUM (lim)); + stop = pos < GPT && GPT < XFIXNUM (lim) ? GPT_ADDR : endp; do { @@ -2184,8 +2206,8 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) else { p = BYTE_POS_ADDR (pos_byte); - endp = CHAR_POS_ADDR (XINT (lim)); - stop = pos >= GPT && GPT > XINT (lim) ? GAP_END_ADDR : endp; + endp = CHAR_POS_ADDR (XFIXNUM (lim)); + stop = pos >= GPT && GPT > XFIXNUM (lim) ? GAP_END_ADDR : endp; if (multibyte) { @@ -2235,7 +2257,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) done: SET_PT_BOTH (pos, pos_byte); - return make_number (PT - start_point); + return make_fixnum (PT - start_point); } } @@ -2254,7 +2276,7 @@ in_classes (int c, Lisp_Object iso_classes) elt = XCAR (iso_classes); iso_classes = XCDR (iso_classes); - if (re_iswctype (c, XFASTINT (elt))) + if (re_iswctype (c, XFIXNAT (elt))) fits_class = 1; } @@ -2421,8 +2443,8 @@ between them, return t; otherwise return nil. */) int dummy2; unsigned short int quit_count = 0; - CHECK_NUMBER (count); - count1 = XINT (count); + CHECK_FIXNUM (count); + count1 = XFIXNUM (count); stop = count1 > 0 ? ZV : BEGV; from = PT; @@ -2772,7 +2794,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (depth < min_depth) xsignal3 (Qscan_error, build_string ("Containing expression ends prematurely"), - make_number (last_good), make_number (from)); + make_fixnum (last_good), make_fixnum (from)); break; case Sstring: @@ -2928,7 +2950,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (depth < min_depth) xsignal3 (Qscan_error, build_string ("Containing expression ends prematurely"), - make_number (last_good), make_number (from)); + make_fixnum (last_good), make_fixnum (from)); break; case Sendcomment: @@ -3008,7 +3030,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) lose: xsignal3 (Qscan_error, build_string ("Unbalanced parentheses"), - make_number (last_good), make_number (from)); + make_fixnum (last_good), make_fixnum (from)); } DEFUN ("scan-lists", Fscan_lists, Sscan_lists, 3, 3, 0, @@ -3032,11 +3054,11 @@ before we have scanned over COUNT lists, return nil if the depth at that point is zero, and signal an error if the depth is nonzero. */) (Lisp_Object from, Lisp_Object count, Lisp_Object depth) { - CHECK_NUMBER (from); - CHECK_NUMBER (count); - CHECK_NUMBER (depth); + CHECK_FIXNUM (from); + CHECK_FIXNUM (count); + CHECK_FIXNUM (depth); - return scan_lists (XINT (from), XINT (count), XINT (depth), 0); + return scan_lists (XFIXNUM (from), XFIXNUM (count), XFIXNUM (depth), 0); } DEFUN ("scan-sexps", Fscan_sexps, Sscan_sexps, 2, 2, 0, @@ -3052,10 +3074,10 @@ If the beginning or end is reached between groupings but before count is used up, nil is returned. */) (Lisp_Object from, Lisp_Object count) { - CHECK_NUMBER (from); - CHECK_NUMBER (count); + CHECK_FIXNUM (from); + CHECK_FIXNUM (count); - return scan_lists (XINT (from), XINT (count), 0, 1); + return scan_lists (XFIXNUM (from), XFIXNUM (count), 0, 1); } DEFUN ("backward-prefix-chars", Fbackward_prefix_chars, Sbackward_prefix_chars, @@ -3195,8 +3217,8 @@ do { prev_from = from; \ while (!NILP (tem)) /* >= second enclosing sexps. */ { Lisp_Object temhd = Fcar (tem); - if (RANGED_INTEGERP (PTRDIFF_MIN, temhd, PTRDIFF_MAX)) - curlevel->last = XINT (temhd); + if (RANGED_FIXNUMP (PTRDIFF_MIN, temhd, PTRDIFF_MAX)) + curlevel->last = XFIXNUM (temhd); if (++curlevel == endlevel) curlevel--; /* error ("Nesting too deep for parser"); */ curlevel->prev = -1; @@ -3441,7 +3463,7 @@ do { prev_from = from; \ state->location_byte = from_byte; state->levelstarts = Qnil; while (curlevel > levelstart) - state->levelstarts = Fcons (make_number ((--curlevel)->last), + state->levelstarts = Fcons (make_fixnum ((--curlevel)->last), state->levelstarts); state->prev_syntax = (SYNTAX_FLAGS_COMSTARTEND_FIRST (prev_from_syntax) || state->quoted) ? prev_from_syntax : Smax; @@ -3469,7 +3491,7 @@ internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state) { tem = Fcar (external); if (!NILP (tem)) - state->depth = XINT (tem); + state->depth = XFIXNUM (tem); else state->depth = 0; @@ -3479,13 +3501,13 @@ internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state) tem = Fcar (external); /* Check whether we are inside string_fence-style string: */ state->instring = (!NILP (tem) - ? (CHARACTERP (tem) ? XFASTINT (tem) : ST_STRING_STYLE) + ? (CHARACTERP (tem) ? XFIXNAT (tem) : ST_STRING_STYLE) : -1); external = Fcdr (external); tem = Fcar (external); state->incomment = (!NILP (tem) - ? (INTEGERP (tem) ? XINT (tem) : -1) + ? (FIXNUMP (tem) ? XFIXNUM (tem) : -1) : 0); external = Fcdr (external); @@ -3499,21 +3521,21 @@ internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state) tem = Fcar (external); state->comstyle = (NILP (tem) ? 0 - : (RANGED_INTEGERP (0, tem, ST_COMMENT_STYLE) - ? XINT (tem) + : (RANGED_FIXNUMP (0, tem, ST_COMMENT_STYLE) + ? XFIXNUM (tem) : ST_COMMENT_STYLE)); external = Fcdr (external); tem = Fcar (external); state->comstr_start = - RANGED_INTEGERP (PTRDIFF_MIN, tem, PTRDIFF_MAX) ? XINT (tem) : -1; + RANGED_FIXNUMP (PTRDIFF_MIN, tem, PTRDIFF_MAX) ? XFIXNUM (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); + state->prev_syntax = NILP (tem) ? Smax : XFIXNUM (tem); } } @@ -3562,16 +3584,16 @@ Sixth arg COMMENTSTOP non-nil means stop after the start of a comment. if (!NILP (targetdepth)) { - CHECK_NUMBER (targetdepth); - target = XINT (targetdepth); + CHECK_FIXNUM (targetdepth); + target = XFIXNUM (targetdepth); } else 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), + scan_sexps_forward (&state, XFIXNUM (from), CHAR_TO_BYTE (XFIXNUM (from)), + XFIXNUM (to), target, !NILP (stopbefore), (NILP (commentstop) ? 0 : (EQ (commentstop, Qsyntax_table) ? -1 : 1))); @@ -3579,32 +3601,32 @@ Sixth arg COMMENTSTOP non-nil means stop after the start of a comment. SET_PT_BOTH (state.location, state.location_byte); return - Fcons (make_number (state.depth), + Fcons (make_fixnum (state.depth), Fcons (state.prevlevelstart < 0 - ? Qnil : make_number (state.prevlevelstart), + ? Qnil : make_fixnum (state.prevlevelstart), Fcons (state.thislevelstart < 0 - ? Qnil : make_number (state.thislevelstart), + ? Qnil : make_fixnum (state.thislevelstart), Fcons (state.instring >= 0 ? (state.instring == ST_STRING_STYLE - ? Qt : make_number (state.instring)) : Qnil, + ? Qt : make_fixnum (state.instring)) : Qnil, Fcons (state.incomment < 0 ? Qt : (state.incomment == 0 ? Qnil : - make_number (state.incomment)), + make_fixnum (state.incomment)), Fcons (state.quoted ? Qt : Qnil, - Fcons (make_number (state.mindepth), + Fcons (make_fixnum (state.mindepth), Fcons ((state.comstyle ? (state.comstyle == ST_COMMENT_STYLE ? Qsyntax_table - : make_number (state.comstyle)) + : make_fixnum (state.comstyle)) : Qnil), Fcons (((state.incomment || (state.instring >= 0)) - ? make_number (state.comstr_start) + ? make_fixnum (state.comstr_start) : Qnil), Fcons (state.levelstarts, Fcons (state.prev_syntax == Smax ? Qnil - : make_number (state.prev_syntax), + : make_fixnum (state.prev_syntax), Qnil))))))))))); } @@ -3620,11 +3642,11 @@ init_syntax_once (void) /* Create objects which can be shared among syntax tables. */ Vsyntax_code_object = make_uninit_vector (Smax); for (i = 0; i < Smax; i++) - ASET (Vsyntax_code_object, i, Fcons (make_number (i), Qnil)); + ASET (Vsyntax_code_object, i, Fcons (make_fixnum (i), Qnil)); /* Now we are ready to set up this property, so we can create syntax tables. */ - Fput (Qsyntax_table, Qchar_table_extra_slots, make_number (0)); + Fput (Qsyntax_table, Qchar_table_extra_slots, make_fixnum (0)); temp = AREF (Vsyntax_code_object, Swhitespace); @@ -3656,21 +3678,21 @@ init_syntax_once (void) SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '%', temp); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '(', - Fcons (make_number (Sopen), make_number (')'))); + Fcons (make_fixnum (Sopen), make_fixnum (')'))); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, ')', - Fcons (make_number (Sclose), make_number ('('))); + Fcons (make_fixnum (Sclose), make_fixnum ('('))); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '[', - Fcons (make_number (Sopen), make_number (']'))); + Fcons (make_fixnum (Sopen), make_fixnum (']'))); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, ']', - Fcons (make_number (Sclose), make_number ('['))); + Fcons (make_fixnum (Sclose), make_fixnum ('['))); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '{', - Fcons (make_number (Sopen), make_number ('}'))); + Fcons (make_fixnum (Sopen), make_fixnum ('}'))); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '}', - Fcons (make_number (Sclose), make_number ('{'))); + Fcons (make_fixnum (Sclose), make_fixnum ('{'))); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '"', - Fcons (make_number (Sstring), Qnil)); + Fcons (make_fixnum (Sstring), Qnil)); SET_RAW_SYNTAX_ENTRY (Vstandard_syntax_table, '\\', - Fcons (make_number (Sescape), Qnil)); + Fcons (make_fixnum (Sescape), Qnil)); temp = AREF (Vsyntax_code_object, Ssymbol); for (i = 0; i < 10; i++) @@ -3695,6 +3717,11 @@ void syms_of_syntax (void) { DEFSYM (Qsyntax_table_p, "syntax-table-p"); + DEFSYM (Qsyntax_ppss, "syntax-ppss"); + DEFVAR_LISP ("comment-use-syntax-ppss", + Vcomment_use_syntax_ppss, + doc: /* Non-nil means `forward-comment' can use `syntax-ppss' internally. */); + Vcomment_use_syntax_ppss = Qt; staticpro (&Vsyntax_code_object); @@ -3703,7 +3730,7 @@ syms_of_syntax (void) staticpro (&gl_state.current_syntax_table); staticpro (&gl_state.old_prop); - /* Defined in regex.c. */ + /* Defined in regex-emacs.c. */ staticpro (&re_match_object); DEFSYM (Qscan_error, "scan-error"); diff --git a/src/syntax.h b/src/syntax.h index 0251fded4c6..6d3851ff72f 100644 --- a/src/syntax.h +++ b/src/syntax.h @@ -118,7 +118,7 @@ INLINE int syntax_property_with_flags (int c, bool via_property) { Lisp_Object ent = syntax_property_entry (c, via_property); - return CONSP (ent) ? XINT (XCAR (ent)) : Swhitespace; + return CONSP (ent) ? XFIXNUM (XCAR (ent)) : Swhitespace; } INLINE int SYNTAX_WITH_FLAGS (int c) @@ -186,13 +186,6 @@ UPDATE_SYNTAX_TABLE_FORWARD (ptrdiff_t charpos) false, gl_state.object); } -INLINE void -UPDATE_SYNTAX_TABLE_FORWARD_FAST (ptrdiff_t charpos) -{ - if (parse_sexp_lookup_properties && charpos >= gl_state.e_property) - update_syntax_table (charpos + gl_state.offset, 1, false, gl_state.object); -} - /* Make syntax table state (gl_state) good for CHARPOS, assuming it is currently good for a position after CHARPOS. */ @@ -212,13 +205,6 @@ UPDATE_SYNTAX_TABLE (ptrdiff_t charpos) UPDATE_SYNTAX_TABLE_FORWARD (charpos); } -INLINE void -UPDATE_SYNTAX_TABLE_FAST (ptrdiff_t charpos) -{ - UPDATE_SYNTAX_TABLE_BACKWARD (charpos); - UPDATE_SYNTAX_TABLE_FORWARD_FAST (charpos); -} - /* Set up the buffer-global syntax table. */ INLINE void diff --git a/src/sysdep.c b/src/sysdep.c index 1e35e06b633..a477ec892ec 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -91,13 +91,19 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <sys/file.h> #include <fcntl.h> +#include "syssignal.h" +#include "systime.h" #include "systty.h" #include "syswait.h" +#ifdef HAVE_SYS_RESOURCE_H +# include <sys/resource.h> +#endif + #ifdef HAVE_SYS_UTSNAME_H -#include <sys/utsname.h> -#include <memory.h> -#endif /* HAVE_SYS_UTSNAME_H */ +# include <sys/utsname.h> +# include <memory.h> +#endif #include "keyboard.h" #include "frame.h" @@ -118,18 +124,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #endif #ifdef WINDOWSNT -#include <direct.h> +# include <direct.h> /* In process.h which conflicts with the local copy. */ -#define _P_WAIT 0 +# define _P_WAIT 0 int _cdecl _spawnlp (int, const char *, const char *, ...); /* The following is needed for O_CLOEXEC, F_SETFD, FD_CLOEXEC, and several prototypes of functions called below. */ -#include <sys/socket.h> +# include <sys/socket.h> #endif -#include "syssignal.h" -#include "systime.h" - /* ULLONG_MAX is missing on Red Hat Linux 7.3; see Bug#11781. */ #ifndef ULLONG_MAX #define ULLONG_MAX TYPE_MAXIMUM (unsigned long long int) @@ -147,22 +150,52 @@ static const int baud_convert[] = #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) +/* If not -1, the personality that should be restored before exec. */ +static int exec_personality; + +/* Try to disable randomization if the current process needs it and + does not appear to have it already. */ +int +maybe_disable_address_randomization (bool dumping, int argc, char **argv) { - int pers = personality (0xffffffff); - if (pers < 0) - return false; - int desired_pers = pers | ADDR_NO_RANDOMIZE; + /* Undocumented Emacs option used only by this function. */ + static char const aslr_disabled_option[] = "--__aslr-disabled"; + + if (argc < 2 || strcmp (argv[1], aslr_disabled_option) != 0) + { + bool disable_aslr = dumping; +# ifdef __PPC64__ + disable_aslr = true; +# endif + exec_personality = disable_aslr ? personality (0xffffffff) : -1; + if (exec_personality & ADDR_NO_RANDOMIZE) + exec_personality = -1; + if (exec_personality != -1 + && personality (exec_personality | ADDR_NO_RANDOMIZE) != -1) + { + char **newargv = malloc ((argc + 2) * sizeof *newargv); + if (newargv) + { + /* Invoke self with undocumented option. */ + newargv[0] = argv[0]; + newargv[1] = (char *) aslr_disabled_option; + memcpy (&newargv[2], &argv[1], argc * sizeof *newargv); + execvp (newargv[0], newargv); + } + + /* If malloc or execvp fails, warn and then try anyway. */ + perror (argv[0]); + free (newargv); + } + } + else + { + /* Our earlier incarnation already disabled ASLR. */ + argc--; + memmove (&argv[1], &argv[2], argc * sizeof *argv); + } - /* 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); + return argc; } #endif @@ -174,21 +207,12 @@ 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); + if (exec_personality != -1) + personality (exec_personality); #endif execve (file, argv, envp); - int err = errno; - -#ifdef HAVE_PERSONALITY_ADDR_NO_RANDOMIZE - if (change_personality) - personality (pers); -#endif - - return err; + return errno; } /* If FD is not already open, arrange for it to be open with FLAGS. */ @@ -1496,18 +1520,18 @@ reset_sys_modes (struct tty_display_info *tty_out) tty_out->terminal->reset_terminal_modes_hook (tty_out->terminal); /* Avoid possible loss of output when changing terminal modes. */ - while (fdatasync (fileno (tty_out->output)) != 0 && errno == EINTR) + while (tcdrain (fileno (tty_out->output)) != 0 && errno == EINTR) continue; #ifndef DOS_NT -#ifdef F_SETOWN +# ifdef F_SETOWN if (interrupt_input) { reset_sigio (fileno (tty_out->input)); fcntl (fileno (tty_out->input), F_SETOWN, old_fcntl_owner[fileno (tty_out->input)]); } -#endif /* F_SETOWN */ +# endif /* F_SETOWN */ fcntl (fileno (tty_out->input), F_SETFL, fcntl (fileno (tty_out->input), F_GETFL, 0) & ~O_NONBLOCK); #endif @@ -1671,7 +1695,7 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler) } #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD -pthread_t main_thread_id; +static pthread_t main_thread_id; #endif /* SIG has arrived at the current process. Deliver it to the main @@ -2554,6 +2578,22 @@ emacs_close (int fd) #define MAX_RW_COUNT (INT_MAX >> 18 << 18) #endif +/* Verify that MAX_RW_COUNT fits in the relevant standard types. */ +#ifndef SSIZE_MAX +# define SSIZE_MAX TYPE_MAXIMUM (ssize_t) +#endif +verify (MAX_RW_COUNT <= PTRDIFF_MAX); +verify (MAX_RW_COUNT <= SIZE_MAX); +verify (MAX_RW_COUNT <= SSIZE_MAX); + +#ifdef WINDOWSNT +/* Verify that Emacs read requests cannot cause trouble, even in + 64-bit builds. The last argument of 'read' is 'unsigned int', and + the return value's type (see 'sys_read') is 'int'. */ +verify (MAX_RW_COUNT <= INT_MAX); +verify (MAX_RW_COUNT <= UINT_MAX); +#endif + /* Read from FD to a buffer BUF with size NBYTE. If interrupted, process any quits and pending signals immediately if INTERRUPTIBLE, and then retry the read unless quitting. @@ -2562,10 +2602,11 @@ emacs_close (int fd) static ptrdiff_t emacs_intr_read (int fd, void *buf, ptrdiff_t nbyte, bool interruptible) { + /* No caller should ever pass a too-large size to emacs_read. */ + eassert (nbyte <= MAX_RW_COUNT); + ssize_t result; - /* There is no need to check against MAX_RW_COUNT, since no caller ever - passes a size that large to emacs_read. */ do { if (interruptible) @@ -2687,30 +2728,6 @@ emacs_perror (char const *message) errno = err; } -/* Return a struct timeval that is roughly equivalent to T. - Use the least timeval not less than T. - Return an extremal value if the result would overflow. */ -struct timeval -make_timeval (struct timespec t) -{ - struct timeval tv; - tv.tv_sec = t.tv_sec; - tv.tv_usec = t.tv_nsec / 1000; - - if (t.tv_nsec % 1000 != 0) - { - if (tv.tv_usec < 999999) - tv.tv_usec++; - else if (tv.tv_sec < TYPE_MAXIMUM (time_t)) - { - tv.tv_sec++; - tv.tv_usec = 0; - } - } - - return tv; -} - /* Set the access and modification time stamps of FD (a.k.a. FILE) to be ATIME and MTIME, respectively. FD must be either negative -- in which case it is ignored -- @@ -2833,8 +2850,8 @@ serial_configure (struct Lisp_Process *p, tem = Fplist_get (contact, QCspeed); else tem = Fplist_get (p->childp, QCspeed); - CHECK_NUMBER (tem); - err = cfsetspeed (&attr, XINT (tem)); + CHECK_FIXNUM (tem); + err = cfsetspeed (&attr, XFIXNUM (tem)); if (err != 0) report_file_error ("Failed cfsetspeed", tem); childp2 = Fplist_put (childp2, QCspeed, tem); @@ -2845,17 +2862,17 @@ serial_configure (struct Lisp_Process *p, else tem = Fplist_get (p->childp, QCbytesize); if (NILP (tem)) - tem = make_number (8); - CHECK_NUMBER (tem); - if (XINT (tem) != 7 && XINT (tem) != 8) + tem = make_fixnum (8); + CHECK_FIXNUM (tem); + if (XFIXNUM (tem) != 7 && XFIXNUM (tem) != 8) error (":bytesize must be nil (8), 7, or 8"); - summary[0] = XINT (tem) + '0'; + summary[0] = XFIXNUM (tem) + '0'; #if defined (CSIZE) && defined (CS7) && defined (CS8) attr.c_cflag &= ~CSIZE; - attr.c_cflag |= ((XINT (tem) == 7) ? CS7 : CS8); + attr.c_cflag |= ((XFIXNUM (tem) == 7) ? CS7 : CS8); #else /* Don't error on bytesize 8, which should be set by cfmakeraw. */ - if (XINT (tem) != 8) + if (XFIXNUM (tem) != 8) error ("Bytesize cannot be changed"); #endif childp2 = Fplist_put (childp2, QCbytesize, tem); @@ -2899,18 +2916,18 @@ serial_configure (struct Lisp_Process *p, else tem = Fplist_get (p->childp, QCstopbits); if (NILP (tem)) - tem = make_number (1); - CHECK_NUMBER (tem); - if (XINT (tem) != 1 && XINT (tem) != 2) + tem = make_fixnum (1); + CHECK_FIXNUM (tem); + if (XFIXNUM (tem) != 1 && XFIXNUM (tem) != 2) error (":stopbits must be nil (1 stopbit), 1, or 2"); - summary[2] = XINT (tem) + '0'; + summary[2] = XFIXNUM (tem) + '0'; #if defined (CSTOPB) attr.c_cflag &= ~CSTOPB; - if (XINT (tem) == 2) + if (XFIXNUM (tem) == 2) attr.c_cflag |= CSTOPB; #else /* Don't error on 1 stopbit, which should be set by cfmakeraw. */ - if (XINT (tem) != 1) + if (XFIXNUM (tem) != 1) error ("Stopbits cannot be configured"); #endif childp2 = Fplist_put (childp2, QCstopbits, tem); @@ -3028,9 +3045,9 @@ list_system_processes (void) for (i = 0; i < len; i++) { #ifdef DARWIN_OS - proclist = Fcons (make_fixnum_or_float (procs[i].kp_proc.p_pid), proclist); + proclist = Fcons (INT_TO_INTEGER (procs[i].kp_proc.p_pid), proclist); #else - proclist = Fcons (make_fixnum_or_float (procs[i].ki_pid), proclist); + proclist = Fcons (INT_TO_INTEGER (procs[i].ki_pid), proclist); #endif } @@ -3051,6 +3068,22 @@ list_system_processes (void) #endif /* !defined (WINDOWSNT) */ + +#if defined __FreeBSD__ || 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)); +} + +#endif + #if defined GNU_LINUX && defined HAVE_LONG_LONG_INT static struct timespec time_from_jiffies (unsigned long long tval, long hz) @@ -3061,16 +3094,15 @@ time_from_jiffies (unsigned long long tval, long hz) if (TYPE_MAXIMUM (time_t) < s) time_overflow (); - if (LONG_MAX - 1 <= ULLONG_MAX / TIMESPEC_RESOLUTION - || frac <= ULLONG_MAX / TIMESPEC_RESOLUTION) - ns = frac * TIMESPEC_RESOLUTION / hz; + if (LONG_MAX - 1 <= ULLONG_MAX / TIMESPEC_HZ + || frac <= ULLONG_MAX / TIMESPEC_HZ) + ns = frac * TIMESPEC_HZ / hz; else { /* This is reachable only in the unlikely case that HZ * HZ exceeds ULLONG_MAX. It calculates an approximation that is guaranteed to be in range. */ - long hz_per_ns = (hz / TIMESPEC_RESOLUTION - + (hz % TIMESPEC_RESOLUTION != 0)); + long hz_per_ns = hz / TIMESPEC_HZ + (hz % TIMESPEC_HZ != 0); ns = frac / hz_per_ns; } @@ -3095,27 +3127,26 @@ get_up_time (void) if (fup) { - unsigned long long upsec, upfrac, idlesec, idlefrac; - int upfrac_start, upfrac_end, idlefrac_start, idlefrac_end; + unsigned long long upsec, upfrac; + int upfrac_start, upfrac_end; - if (fscanf (fup, "%llu.%n%llu%n %llu.%n%llu%n", - &upsec, &upfrac_start, &upfrac, &upfrac_end, - &idlesec, &idlefrac_start, &idlefrac, &idlefrac_end) - == 4) + if (fscanf (fup, "%llu.%n%llu%n", + &upsec, &upfrac_start, &upfrac, &upfrac_end) + == 2) { if (TYPE_MAXIMUM (time_t) < upsec) { upsec = TYPE_MAXIMUM (time_t); - upfrac = TIMESPEC_RESOLUTION - 1; + upfrac = TIMESPEC_HZ - 1; } else { int upfraclen = upfrac_end - upfrac_start; - for (; upfraclen < LOG10_TIMESPEC_RESOLUTION; upfraclen++) + for (; upfraclen < LOG10_TIMESPEC_HZ; upfraclen++) upfrac *= 10; - for (; LOG10_TIMESPEC_RESOLUTION < upfraclen; upfraclen--) + for (; LOG10_TIMESPEC_HZ < upfraclen; upfraclen--) upfrac /= 10; - upfrac = min (upfrac, TIMESPEC_RESOLUTION - 1); + upfrac = min (upfrac, TIMESPEC_HZ - 1); } up = make_timespec (upsec, upfrac); } @@ -3222,7 +3253,7 @@ system_process_attributes (Lisp_Object pid) struct group *gr; long clocks_per_sec; char *procfn_end; - char procbuf[1025], *p, *q; + char procbuf[1025], *p, *q UNINIT; int fd; ssize_t nread; static char const default_cmd[] = "???"; @@ -3244,7 +3275,7 @@ system_process_attributes (Lisp_Object pid) Lisp_Object decoded_cmd; ptrdiff_t count; - CHECK_NUMBER_OR_FLOAT (pid); + CHECK_NUMBER (pid); CONS_TO_INTEGER (pid, pid_t, proc_id); sprintf (procfn, "/proc/%"pMd, proc_id); if (stat (procfn, &st) < 0) @@ -3252,7 +3283,7 @@ system_process_attributes (Lisp_Object pid) /* euid egid */ uid = st.st_uid; - attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs); + attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs); block_input (); pw = getpwuid (uid); unblock_input (); @@ -3260,7 +3291,7 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs); gid = st.st_gid; - attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs); + attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs); block_input (); gr = getgrgid (gid); unblock_input (); @@ -3318,17 +3349,15 @@ system_process_attributes (Lisp_Object pid) state_str[0] = c; state_str[1] = '\0'; attrs = Fcons (Fcons (Qstate, build_string (state_str)), attrs); - attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (ppid)), attrs); - attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (pgrp)), attrs); - attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (sess)), attrs); + attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (ppid)), attrs); + attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (pgrp)), attrs); + attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (sess)), attrs); attrs = Fcons (Fcons (Qttname, procfs_ttyname (tty)), attrs); - attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (tpgid)), attrs); - attrs = Fcons (Fcons (Qminflt, make_fixnum_or_float (minflt)), attrs); - attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (majflt)), attrs); - attrs = Fcons (Fcons (Qcminflt, make_fixnum_or_float (cminflt)), - attrs); - attrs = Fcons (Fcons (Qcmajflt, make_fixnum_or_float (cmajflt)), - attrs); + attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (tpgid)), attrs); + attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (minflt)), attrs); + attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (majflt)), attrs); + attrs = Fcons (Fcons (Qcminflt, INT_TO_INTEGER (cminflt)), attrs); + attrs = Fcons (Fcons (Qcmajflt, INT_TO_INTEGER (cmajflt)), attrs); clocks_per_sec = sysconf (_SC_CLK_TCK); if (clocks_per_sec < 0) clocks_per_sec = 100; @@ -3352,19 +3381,17 @@ system_process_attributes (Lisp_Object pid) ltime_from_jiffies (cstime + cutime, clocks_per_sec)), attrs); - attrs = Fcons (Fcons (Qpri, make_number (priority)), attrs); - attrs = Fcons (Fcons (Qnice, make_number (niceness)), attrs); - attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (thcount)), - attrs); + attrs = Fcons (Fcons (Qpri, make_fixnum (priority)), attrs); + attrs = Fcons (Fcons (Qnice, make_fixnum (niceness)), attrs); + attrs = Fcons (Fcons (Qthcount, INT_TO_INTEGER (thcount)), attrs); tnow = current_timespec (); telapsed = get_up_time (); tboot = timespec_sub (tnow, telapsed); tstart = time_from_jiffies (start, clocks_per_sec); tstart = timespec_add (tboot, tstart); attrs = Fcons (Fcons (Qstart, make_lisp_time (tstart)), attrs); - attrs = Fcons (Fcons (Qvsize, make_fixnum_or_float (vsize / 1024)), - attrs); - attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (4 * rss)), attrs); + attrs = Fcons (Fcons (Qvsize, INT_TO_INTEGER (vsize / 1024)), attrs); + attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (4 * rss)), attrs); telapsed = timespec_sub (tnow, tstart); attrs = Fcons (Fcons (Qetime, make_lisp_time (telapsed)), attrs); us_time = time_from_jiffies (u_time + s_time, clocks_per_sec); @@ -3478,7 +3505,7 @@ system_process_attributes (Lisp_Object pid) Lisp_Object decoded_cmd; ptrdiff_t count; - CHECK_NUMBER_OR_FLOAT (pid); + CHECK_NUMBER (pid); CONS_TO_INTEGER (pid, pid_t, proc_id); sprintf (procfn, "/proc/%"pMd, proc_id); if (stat (procfn, &st) < 0) @@ -3486,7 +3513,7 @@ system_process_attributes (Lisp_Object pid) /* euid egid */ uid = st.st_uid; - attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs); + attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs); block_input (); pw = getpwuid (uid); unblock_input (); @@ -3494,7 +3521,7 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs); gid = st.st_gid; - attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (gid)), attrs); + attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs); block_input (); gr = getgrgid (gid); unblock_input (); @@ -3516,9 +3543,9 @@ system_process_attributes (Lisp_Object pid) if (nread == sizeof pinfo) { - attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (pinfo.pr_ppid)), attrs); - attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (pinfo.pr_pgid)), attrs); - attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (pinfo.pr_sid)), attrs); + attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (pinfo.pr_ppid)), attrs); + attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (pinfo.pr_pgid)), attrs); + attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (pinfo.pr_sid)), attrs); { char state_str[2]; @@ -3546,16 +3573,13 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Qtime, make_lisp_time (pinfo.pr_time)), attrs); attrs = Fcons (Fcons (Qctime, make_lisp_time (pinfo.pr_ctime)), attrs); - attrs = Fcons (Fcons (Qpri, make_number (pinfo.pr_lwp.pr_pri)), attrs); - attrs = Fcons (Fcons (Qnice, make_number (pinfo.pr_lwp.pr_nice)), attrs); - attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (pinfo.pr_nlwp)), - attrs); + attrs = Fcons (Fcons (Qpri, make_fixnum (pinfo.pr_lwp.pr_pri)), attrs); + attrs = Fcons (Fcons (Qnice, make_fixnum (pinfo.pr_lwp.pr_nice)), attrs); + attrs = Fcons (Fcons (Qthcount, INT_TO_INTEGER (pinfo.pr_nlwp)), attrs); attrs = Fcons (Fcons (Qstart, make_lisp_time (pinfo.pr_start)), attrs); - attrs = Fcons (Fcons (Qvsize, make_fixnum_or_float (pinfo.pr_size)), - attrs); - attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (pinfo.pr_rssize)), - attrs); + attrs = Fcons (Fcons (Qvsize, INT_TO_INTEGER (pinfo.pr_size)), attrs); + attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (pinfo.pr_rssize)), attrs); /* pr_pctcpu and pr_pctmem are unsigned integers in the range 0 .. 2**15, representing 0.0 .. 1.0. */ @@ -3575,24 +3599,11 @@ system_process_attributes (Lisp_Object pid) Vlocale_coding_system, 0); attrs = Fcons (Fcons (Qargs, decoded_cmd), attrs); } - unbind_to (count, Qnil); - return attrs; + return unbind_to (count, attrs); } #elif defined __FreeBSD__ -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) { @@ -3614,14 +3625,14 @@ system_process_attributes (Lisp_Object pid) Lisp_Object attrs = Qnil; Lisp_Object decoded_comm; - CHECK_NUMBER_OR_FLOAT (pid); + CHECK_NUMBER (pid); CONS_TO_INTEGER (pid, int, proc_id); mib[3] = proc_id; if (sysctl (mib, 4, &proc, &proclen, NULL, 0) != 0) return attrs; - attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (proc.ki_uid)), attrs); + attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (proc.ki_uid)), attrs); block_input (); pw = getpwuid (proc.ki_uid); @@ -3629,7 +3640,7 @@ system_process_attributes (Lisp_Object pid) if (pw) attrs = Fcons (Fcons (Quser, build_string (pw->pw_name)), attrs); - attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (proc.ki_svgid)), attrs); + attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (proc.ki_svgid)), attrs); block_input (); gr = getgrgid (proc.ki_svgid); @@ -3668,9 +3679,9 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Qstate, build_string (state)), attrs); } - attrs = Fcons (Fcons (Qppid, make_fixnum_or_float (proc.ki_ppid)), attrs); - attrs = Fcons (Fcons (Qpgrp, make_fixnum_or_float (proc.ki_pgid)), attrs); - attrs = Fcons (Fcons (Qsess, make_fixnum_or_float (proc.ki_sid)), attrs); + attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (proc.ki_ppid)), attrs); + attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (proc.ki_pgid)), attrs); + attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (proc.ki_sid)), attrs); block_input (); ttyname = proc.ki_tdev == NODEV ? NULL : devname (proc.ki_tdev, S_IFCHR); @@ -3678,11 +3689,13 @@ system_process_attributes (Lisp_Object pid) if (ttyname) attrs = Fcons (Fcons (Qtty, build_string (ttyname)), attrs); - attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (proc.ki_tpgid)), attrs); - attrs = Fcons (Fcons (Qminflt, make_fixnum_or_float (proc.ki_rusage.ru_minflt)), attrs); - attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (proc.ki_rusage.ru_majflt)), attrs); - attrs = Fcons (Fcons (Qcminflt, make_number (proc.ki_rusage_ch.ru_minflt)), attrs); - attrs = Fcons (Fcons (Qcmajflt, make_number (proc.ki_rusage_ch.ru_majflt)), attrs); + attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (proc.ki_tpgid)), attrs); + attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (proc.ki_rusage.ru_minflt)), + attrs); + attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (proc.ki_rusage.ru_majflt)), + attrs); + attrs = Fcons (Fcons (Qcminflt, make_fixnum (proc.ki_rusage_ch.ru_minflt)), attrs); + attrs = Fcons (Fcons (Qcmajflt, make_fixnum (proc.ki_rusage_ch.ru_majflt)), attrs); attrs = Fcons (Fcons (Qutime, make_lisp_timeval (proc.ki_rusage.ru_utime)), attrs); @@ -3702,13 +3715,12 @@ system_process_attributes (Lisp_Object pid) timeval_to_timespec (proc.ki_rusage_ch.ru_stime)); attrs = Fcons (Fcons (Qctime, make_lisp_time (t)), attrs); - attrs = Fcons (Fcons (Qthcount, make_fixnum_or_float (proc.ki_numthreads)), - attrs); - attrs = Fcons (Fcons (Qpri, make_number (proc.ki_pri.pri_native)), attrs); - attrs = Fcons (Fcons (Qnice, make_number (proc.ki_nice)), attrs); + attrs = Fcons (Fcons (Qthcount, INT_TO_INTEGER (proc.ki_numthreads)), attrs); + attrs = Fcons (Fcons (Qpri, make_fixnum (proc.ki_pri.pri_native)), attrs); + attrs = Fcons (Fcons (Qnice, make_fixnum (proc.ki_nice)), attrs); attrs = Fcons (Fcons (Qstart, make_lisp_timeval (proc.ki_start)), attrs); - attrs = Fcons (Fcons (Qvsize, make_number (proc.ki_size >> 10)), attrs); - attrs = Fcons (Fcons (Qrss, make_number (proc.ki_rssize * pagesize >> 10)), + attrs = Fcons (Fcons (Qvsize, make_fixnum (proc.ki_size >> 10)), attrs); + attrs = Fcons (Fcons (Qrss, make_fixnum (proc.ki_rssize * pagesize >> 10)), attrs); now = current_timespec (); @@ -3725,7 +3737,7 @@ system_process_attributes (Lisp_Object pid) { pcpu = (100.0 * proc.ki_pctcpu / fscale / (1 - exp (proc.ki_swtime * log ((double) ccpu / fscale)))); - attrs = Fcons (Fcons (Qpcpu, make_fixnum_or_float (pcpu)), attrs); + attrs = Fcons (Fcons (Qpcpu, INT_TO_INTEGER (pcpu)), attrs); } } @@ -3735,7 +3747,7 @@ system_process_attributes (Lisp_Object pid) double pmem = (proc.ki_flag & P_INMEM ? 100.0 * proc.ki_rssize / npages : 0); - attrs = Fcons (Fcons (Qpmem, make_fixnum_or_float (pmem)), attrs); + attrs = Fcons (Fcons (Qpmem, INT_TO_INTEGER (pmem)), attrs); } mib[2] = KERN_PROC_ARGS; @@ -3761,18 +3773,6 @@ system_process_attributes (Lisp_Object pid) #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) { @@ -3794,7 +3794,7 @@ system_process_attributes (Lisp_Object pid) Lisp_Object attrs = Qnil; Lisp_Object decoded_comm; - CHECK_NUMBER_OR_FLOAT (pid); + CHECK_NUMBER (pid); CONS_TO_INTEGER (pid, int, proc_id); mib[3] = proc_id; @@ -3802,7 +3802,7 @@ system_process_attributes (Lisp_Object pid) return attrs; uid = proc.kp_eproc.e_ucred.cr_uid; - attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (uid)), attrs); + attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (uid)), attrs); block_input (); pw = getpwuid (uid); @@ -3811,7 +3811,7 @@ system_process_attributes (Lisp_Object pid) 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); + attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (gid)), attrs); block_input (); gr = getgrgid (gid); @@ -3851,10 +3851,8 @@ system_process_attributes (Lisp_Object pid) 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); + attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (proc.kp_eproc.e_ppid)), attrs); + attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (proc.kp_eproc.e_pgid)), attrs); tdev = proc.kp_eproc.e_tdev; block_input (); @@ -3863,15 +3861,15 @@ system_process_attributes (Lisp_Object pid) if (ttyname) attrs = Fcons (Fcons (Qtty, build_string (ttyname)), attrs); - attrs = Fcons (Fcons (Qtpgid, make_fixnum_or_float (proc.kp_eproc.e_tpgid)), + attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (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 = Fcons (Fcons (Qminflt, INT_TO_INTEGER (rusage->ru_minflt)), attrs); - attrs = Fcons (Fcons (Qmajflt, make_fixnum_or_float (rusage->ru_majflt)), + attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (rusage->ru_majflt)), attrs); attrs = Fcons (Fcons (Qutime, make_lisp_timeval (rusage->ru_utime)), @@ -3884,7 +3882,7 @@ system_process_attributes (Lisp_Object pid) } starttime = proc.kp_proc.p_starttime; - attrs = Fcons (Fcons (Qnice, make_number (proc.kp_proc.p_nice)), attrs); + attrs = Fcons (Fcons (Qnice, make_fixnum (proc.kp_proc.p_nice)), attrs); attrs = Fcons (Fcons (Qstart, make_lisp_timeval (starttime)), attrs); now = current_timespec (); @@ -3905,6 +3903,42 @@ system_process_attributes (Lisp_Object pid) } #endif /* !defined (WINDOWSNT) */ + +DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time, + 0, 0, 0, + doc: /* Return the current run time used by Emacs. +The time is returned as in the style of `current-time'. + +On systems that can't determine the run time, `get-internal-run-time' +does the same thing as `current-time'. */) + (void) +{ +#ifdef HAVE_GETRUSAGE + struct rusage usage; + time_t secs; + int usecs; + + if (getrusage (RUSAGE_SELF, &usage) < 0) + /* This shouldn't happen. What action is appropriate? */ + xsignal0 (Qerror); + + /* Sum up user time and system time. */ + secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec; + usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec; + if (usecs >= 1000000) + { + usecs -= 1000000; + secs++; + } + return make_lisp_time (make_timespec (secs, usecs * 1000)); +#else /* ! HAVE_GETRUSAGE */ +#ifdef WINDOWSNT + return w32_get_internal_run_time (); +#else /* ! WINDOWSNT */ + return Fcurrent_time (); +#endif /* WINDOWSNT */ +#endif /* HAVE_GETRUSAGE */ +} /* Wide character string collation. */ @@ -4110,3 +4144,9 @@ str_collate (Lisp_Object s1, Lisp_Object s2, return res; } #endif /* WINDOWSNT */ + +void +syms_of_sysdep (void) +{ + defsubr (&Sget_internal_run_time); +} diff --git a/src/syssignal.h b/src/syssignal.h index 7a360346c3e..01fb41feded 100644 --- a/src/syssignal.h +++ b/src/syssignal.h @@ -32,7 +32,6 @@ 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 index 91f7e4fd156..6f4de536fba 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -18,6 +18,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include <setjmp.h> +#include <stdio.h> +#include <string.h> #include "lisp.h" #ifdef HAVE_NS @@ -74,11 +76,17 @@ sys_thread_self (void) return 0; } -int +bool +sys_thread_equal (sys_thread_t t, sys_thread_t u) +{ + return t == u; +} + +bool sys_thread_create (sys_thread_t *t, const char *name, thread_creation_function *func, void *datum) { - return 0; + return false; } void @@ -97,43 +105,77 @@ sys_thread_yield (void) void sys_mutex_init (sys_mutex_t *mutex) { - pthread_mutex_init (mutex, NULL); + pthread_mutexattr_t *attr_ptr; +#ifdef ENABLE_CHECKING + pthread_mutexattr_t attr; + { + int error = pthread_mutexattr_init (&attr); + eassert (error == 0); + error = pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_ERRORCHECK); + eassert (error == 0); + } + attr_ptr = &attr; +#else + attr_ptr = NULL; +#endif + int error = pthread_mutex_init (mutex, attr_ptr); + /* We could get ENOMEM. Can't do anything except aborting. */ + if (error != 0) + { + fprintf (stderr, "\npthread_mutex_init failed: %s\n", strerror (error)); + emacs_abort (); + } +#ifdef ENABLE_CHECKING + error = pthread_mutexattr_destroy (&attr); + eassert (error == 0); +#endif } void sys_mutex_lock (sys_mutex_t *mutex) { - pthread_mutex_lock (mutex); + int error = pthread_mutex_lock (mutex); + eassert (error == 0); } void sys_mutex_unlock (sys_mutex_t *mutex) { - pthread_mutex_unlock (mutex); + int error = pthread_mutex_unlock (mutex); + eassert (error == 0); } void sys_cond_init (sys_cond_t *cond) { - pthread_cond_init (cond, NULL); + int error = pthread_cond_init (cond, NULL); + /* We could get ENOMEM. Can't do anything except aborting. */ + if (error != 0) + { + fprintf (stderr, "\npthread_cond_init failed: %s\n", strerror (error)); + emacs_abort (); + } } void sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) { - pthread_cond_wait (cond, mutex); + int error = pthread_cond_wait (cond, mutex); + eassert (error == 0); } void sys_cond_signal (sys_cond_t *cond) { - pthread_cond_signal (cond); + int error = pthread_cond_signal (cond); + eassert (error == 0); } void sys_cond_broadcast (sys_cond_t *cond) { - pthread_cond_broadcast (cond); + int error = pthread_cond_broadcast (cond); + eassert (error == 0); #ifdef HAVE_NS /* Send an app defined event to break out of the NS run loop. It seems that if ns_select is running the NS run loop, this @@ -146,7 +188,8 @@ sys_cond_broadcast (sys_cond_t *cond) void sys_cond_destroy (sys_cond_t *cond) { - pthread_cond_destroy (cond); + int error = pthread_cond_destroy (cond); + eassert (error == 0); } sys_thread_t @@ -155,24 +198,31 @@ sys_thread_self (void) return pthread_self (); } -int +bool +sys_thread_equal (sys_thread_t t, sys_thread_t u) +{ + return pthread_equal (t, u); +} + +bool sys_thread_create (sys_thread_t *thread_ptr, const char *name, thread_creation_function *func, void *arg) { pthread_attr_t attr; - int result = 0; + bool result = false; if (pthread_attr_init (&attr)) - return 0; + return false; -#ifdef DARWIN_OS /* Avoid crash on macOS with deeply nested GC (Bug#30364). */ size_t stack_size; size_t required_stack_size = sizeof (void *) * 1024 * 1024; if (pthread_attr_getstacksize (&attr, &stack_size) == 0 && stack_size < required_stack_size) - pthread_attr_setstacksize (&attr, required_stack_size); -#endif + { + if (pthread_attr_setstacksize (&attr, required_stack_size) != 0) + goto out; + } if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED)) { @@ -183,7 +233,9 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name, #endif } - pthread_attr_destroy (&attr); + out: ; + int error = pthread_attr_destroy (&attr); + eassert (error == 0); return result; } @@ -332,6 +384,12 @@ sys_thread_self (void) return (sys_thread_t) GetCurrentThreadId (); } +bool +sys_thread_equal (sys_thread_t t, sys_thread_t u) +{ + return t == u; +} + static thread_creation_function *thread_start_address; /* _beginthread wants a void function, while we are passed a function @@ -343,7 +401,7 @@ w32_beginthread_wrapper (void *arg) (void)thread_start_address (arg); } -int +bool sys_thread_create (sys_thread_t *thread_ptr, const char *name, thread_creation_function *func, void *arg) { @@ -367,7 +425,7 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name, rule in many places... */ thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg); if (thandle == (uintptr_t)-1L) - return 0; + return false; /* 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 @@ -382,7 +440,7 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name, Therefore, we return some more or less arbitrary value of the thread ID from this function. */ *thread_ptr = thandle & 0xFFFFFFFF; - return 1; + return true; } void diff --git a/src/systhread.h b/src/systhread.h index 8d7c1a845c1..a1d2746721d 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -19,6 +19,18 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef SYSTHREAD_H #define SYSTHREAD_H +#include <stdbool.h> + +#ifndef __has_attribute +# define __has_attribute(a) false +#endif + +#if __has_attribute (__warn_unused_result__) +# define ATTRIBUTE_WARN_UNUSED_RESULT __attribute__ ((__warn_unused_result__)) +#else +# define ATTRIBUTE_WARN_UNUSED_RESULT +#endif + #ifdef THREADS_ENABLED #ifdef HAVE_PTHREAD @@ -99,11 +111,14 @@ 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 sys_thread_t sys_thread_self (void) + ATTRIBUTE_WARN_UNUSED_RESULT; +extern bool sys_thread_equal (sys_thread_t, sys_thread_t) + ATTRIBUTE_WARN_UNUSED_RESULT; -extern int sys_thread_create (sys_thread_t *, const char *, - thread_creation_function *, - void *); +extern bool sys_thread_create (sys_thread_t *, const char *, + thread_creation_function *, void *) + ATTRIBUTE_WARN_UNUSED_RESULT; extern void sys_thread_yield (void); diff --git a/src/systime.h b/src/systime.h index 6940dc4d1a6..1812f073f35 100644 --- a/src/systime.h +++ b/src/systime.h @@ -19,16 +19,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef EMACS_SYSTIME_H #define EMACS_SYSTIME_H +#include "lisp.h" #include <timespec.h> INLINE_HEADER_BEGIN -#ifdef emacs -# ifdef HAVE_X_WINDOWS -# include <X11/X.h> -# else +#ifdef HAVE_X_WINDOWS +# include <X11/X.h> +#else typedef unsigned long Time; -# endif #endif /* On some configurations (hpux8.0, X11R4), sys/time.h and X11/Xos.h @@ -58,52 +57,44 @@ invalid_timespec (void) } /* Return true if TIME is a valid timespec. This currently doesn't worry - about whether tv_nsec is less than TIMESPEC_RESOLUTION; leap seconds - might cause a problem if it did. */ + about whether tv_nsec is less than TIMESPEC_HZ; leap seconds might + cause a problem if it did. */ INLINE bool timespec_valid_p (struct timespec t) { return t.tv_nsec >= 0; } -/* Return current system time. */ -INLINE struct timespec -current_timespec (void) -{ - struct timespec r; - gettime (&r); - return r; -} - /* defined in sysdep.c */ extern int set_file_times (int, const char *, struct timespec, struct timespec); -extern struct timeval make_timeval (struct timespec) ATTRIBUTE_CONST; /* defined in keyboard.c */ extern void set_waiting_for_input (struct timespec *); -/* When lisp.h is not included Lisp_Object is not defined (this can - happen when this file is used outside the src directory). */ -#ifdef emacs - /* Emacs uses the integer list (HI LO US PS) to represent the time (HI << LO_TIME_BITS) + LO + US / 1e6 + PS / 1e12. */ enum { LO_TIME_BITS = 16 }; -/* A Lisp time (HI LO US PS), sans the cons cells. */ +/* Components of a new-format Lisp timestamp. */ struct lisp_time { - EMACS_INT hi; - int lo, us, ps; + /* Clock count as a Lisp integer. */ + Lisp_Object ticks; + + /* Clock frequency (ticks per second) as a positive Lisp integer. + (TICKS . HZ) is a valid Lisp timestamp unless HZ < 65536. */ + Lisp_Object hz; }; -/* defined in editfns.c */ +/* defined in timefns.c */ +extern struct timeval make_timeval (struct timespec) ATTRIBUTE_CONST; extern Lisp_Object make_lisp_time (struct timespec); -extern int decode_time_components (Lisp_Object, Lisp_Object, Lisp_Object, - Lisp_Object, struct lisp_time *, double *); -extern struct timespec lisp_to_timespec (struct lisp_time); +extern bool list4_to_timespec (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, struct timespec *); extern struct timespec lisp_time_argument (Lisp_Object); -#endif +extern _Noreturn void time_overflow (void); +extern void init_timefns (bool); +extern void syms_of_timefns (void); INLINE_HEADER_END diff --git a/src/term.c b/src/term.c index dcb7d75aa54..c5a1fb99a15 100644 --- a/src/term.c +++ b/src/term.c @@ -1359,8 +1359,7 @@ term_get_fkeys_1 (void) char *sequence = tgetstr (keys[i].cap, address); if (sequence) Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), - Fmake_vector (make_number (1), - intern (keys[i].name))); + make_vector (1, intern (keys[i].name))); } /* The uses of the "k0" capability are inconsistent; sometimes it @@ -1379,13 +1378,13 @@ term_get_fkeys_1 (void) /* Define f0 first, so that f10 takes precedence in case the key sequences happens to be the same. */ Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0), - Fmake_vector (make_number (1), intern ("f0"))); + make_vector (1, intern ("f0"))); Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k_semi), - Fmake_vector (make_number (1), intern ("f10"))); + make_vector (1, intern ("f10"))); } else if (k0) Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0), - Fmake_vector (make_number (1), intern (k0_name))); + make_vector (1, intern (k0_name))); } /* Set up cookies for numbered function keys above f10. */ @@ -1408,8 +1407,7 @@ term_get_fkeys_1 (void) { sprintf (fkey, "f%d", i); Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), - Fmake_vector (make_number (1), - intern (fkey))); + make_vector (1, intern (fkey))); } } } @@ -1425,8 +1423,7 @@ term_get_fkeys_1 (void) char *sequence = tgetstr (cap2, address); \ if (sequence) \ Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), \ - Fmake_vector (make_number (1), \ - intern (sym))); \ + make_vector (1, intern (sym))); \ } /* if there's no key_next keycap, map key_npage to `next' keysym */ @@ -2050,7 +2047,7 @@ TERMINAL does not refer to a text terminal. */) { struct terminal *t = decode_tty_terminal (terminal); - return make_number (t ? t->display_info.tty->TN_max_colors : 0); + return make_fixnum (t ? t->display_info.tty->TN_max_colors : 0); } #ifndef DOS_NT @@ -2137,7 +2134,7 @@ set_tty_color_mode (struct tty_display_info *tty, struct frame *f) tem = assq_no_quit (Qtty_color_mode, f->param_alist); val = CONSP (tem) ? XCDR (tem) : Qnil; - if (INTEGERP (val)) + if (FIXNUMP (val)) color_mode = val; else if (SYMBOLP (tty_color_mode_alist)) { @@ -2147,7 +2144,7 @@ set_tty_color_mode (struct tty_display_info *tty, struct frame *f) else color_mode = Qnil; - mode = TYPE_RANGED_INTEGERP (int, color_mode) ? XINT (color_mode) : 0; + mode = TYPE_RANGED_FIXNUMP (int, color_mode) ? XFIXNUM (color_mode) : 0; if (mode != tty->previous_color_mode) { @@ -2721,7 +2718,7 @@ typedef struct tty_menu_struct /* Create a brand new menu structure. */ -static tty_menu * +static tty_menu * ATTRIBUTE_MALLOC tty_menu_create (void) { return xzalloc (sizeof *tty_menu_create ()); @@ -2805,8 +2802,8 @@ mouse_get_xy (int *x, int *y) &time_dummy); if (!NILP (lmx)) { - *x = XINT (lmx); - *y = XINT (lmy); + *x = XFIXNUM (lmx); + *y = XFIXNUM (lmy); } } @@ -3132,15 +3129,15 @@ tty_menu_activate (tty_menu *menu, int *pane, int *selidx, SAFE_NALLOCA (state, 1, menu->panecount); memset (state, 0, sizeof (*state)); faces[0] - = lookup_derived_face (sf, intern ("tty-menu-disabled-face"), + = lookup_derived_face (NULL, sf, intern ("tty-menu-disabled-face"), DEFAULT_FACE_ID, 1); faces[1] - = lookup_derived_face (sf, intern ("tty-menu-enabled-face"), + = lookup_derived_face (NULL, sf, intern ("tty-menu-enabled-face"), DEFAULT_FACE_ID, 1); selectface = intern ("tty-menu-selected-face"); - faces[2] = lookup_derived_face (sf, selectface, + faces[2] = lookup_derived_face (NULL, sf, selectface, faces[0], 1); - faces[3] = lookup_derived_face (sf, selectface, + faces[3] = lookup_derived_face (NULL, sf, selectface, faces[1], 1); /* Make sure the menu title is always displayed with @@ -3403,20 +3400,25 @@ tty_menu_help_callback (char const *help_string, int pane, int item) pane_name = first_item[MENU_ITEMS_ITEM_NAME]; /* (menu-item MENU-NAME PANE-NUMBER) */ - menu_object = list3 (Qmenu_item, pane_name, make_number (pane)); + menu_object = list3 (Qmenu_item, pane_name, make_fixnum (pane)); show_help_echo (help_string ? build_string (help_string) : Qnil, - Qnil, menu_object, make_number (item)); + Qnil, menu_object, make_fixnum (item)); } +struct tty_pop_down_menu +{ + tty_menu *menu; + struct buffer *buffer; +}; + static void -tty_pop_down_menu (Lisp_Object arg) +tty_pop_down_menu (void *arg) { - tty_menu *menu = XSAVE_POINTER (arg, 0); - struct buffer *orig_buffer = XSAVE_POINTER (arg, 1); + struct tty_pop_down_menu *data = arg; block_input (); - tty_menu_destroy (menu); - set_buffer_internal (orig_buffer); + tty_menu_destroy (data->menu); + set_buffer_internal (data->buffer); unblock_input (); } @@ -3472,7 +3474,7 @@ tty_menu_new_item_coords (struct frame *f, int which, int *x, int *y) pos = AREF (items, i + 3); if (NILP (str)) return; - ix = XINT (pos); + ix = XFIXNUM (pos); if (ix <= *x /* We use <= so the blank between 2 items on a TTY is considered part of the previous item. */ @@ -3483,14 +3485,14 @@ tty_menu_new_item_coords (struct frame *f, int which, int *x, int *y) if (which == TTYM_NEXT) { if (i < last_i) - *x = XINT (AREF (items, i + 4 + 3)); + *x = XFIXNUM (AREF (items, i + 4 + 3)); else *x = 0; /* Wrap around to the first item. */ } else if (prev_x < 0) { /* Wrap around to the last item. */ - *x = XINT (AREF (items, last_i + 3)); + *x = XFIXNUM (AREF (items, last_i + 3)); } else *x = prev_x; @@ -3697,8 +3699,9 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags, /* We save and restore the current buffer because tty_menu_activate triggers redisplay, which switches buffers at will. */ - record_unwind_protect (tty_pop_down_menu, - make_save_ptr_ptr (menu, current_buffer)); + record_unwind_protect_ptr (tty_pop_down_menu, + &((struct tty_pop_down_menu) + {menu, current_buffer})); specbind (Qoverriding_terminal_local_map, Fsymbol_value (Qtty_menu_navigation_map)); @@ -3748,7 +3751,7 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags, case TTYM_NEXT: case TTYM_PREV: tty_menu_new_item_coords (f, status, &item_x, &item_y); - entry = Fcons (make_number (item_x), make_number (item_y)); + entry = Fcons (make_fixnum (item_x), make_fixnum (item_y)); break; case TTYM_FAILURE: @@ -3770,9 +3773,7 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags, tty_menu_end: - SAFE_FREE (); - unbind_to (specpdl_count, Qnil); - return entry; + return SAFE_FREE_UNBIND_TO (specpdl_count, entry); } #endif /* !MSDOS */ @@ -4145,10 +4146,10 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ tty->TN_max_colors = tgetnum ("Co"); #ifdef TERMINFO - /* Non-standard support for 24-bit colors. */ { const char *fg = tigetstr ("setf24"); const char *bg = tigetstr ("setb24"); + /* Non-standard support for 24-bit colors. */ if (fg && bg && fg != (char *) (intptr_t) -1 && bg != (char *) (intptr_t) -1) @@ -4157,6 +4158,14 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ tty->TS_set_background = bg; tty->TN_max_colors = 16777216; } + /* Standard support for 24-bit colors. */ + else if (tigetflag ("RGB") > 0) + { + /* If the used Terminfo library supports only 16-bit + signed values, tgetnum("Co") and tigetnum("colors") + could return 32767. */ + tty->TN_max_colors = 16777216; + } } #endif diff --git a/src/termhooks.h b/src/termhooks.h index fa15765df4b..ca6782f461b 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -222,6 +222,10 @@ enum event_kind , DBUS_EVENT #endif +#ifdef THREADS_ENABLED + , THREAD_EVENT +#endif + , CONFIG_CHANGED_EVENT #ifdef HAVE_NTGUI @@ -346,7 +350,7 @@ enum { FIXNUM_BITS, so using it to represent a modifier key means that characters thus modified have different integer equivalents depending on the architecture they're running on. Oh, and - applying XINT to a character whose 2^28 bit is set might sign-extend + applying XFIXNUM to a character whose 2^28 bit is set might sign-extend it, so you get a bunch of bits in the mask you didn't want. The CHAR_ macros are defined in lisp.h. */ @@ -657,7 +661,7 @@ struct terminal frames on the terminal when it calls this hook, so infinite recursion is prevented. */ void (*delete_terminal_hook) (struct terminal *); -}; +} GCALIGNED_STRUCT; INLINE bool TERMINALP (Lisp_Object a) @@ -669,7 +673,7 @@ INLINE struct terminal * XTERMINAL (Lisp_Object a) { eassert (TERMINALP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct terminal); } /* Most code should use these functions to set Lisp fields in struct diff --git a/src/terminal.c b/src/terminal.c index a7d99aaf70f..1d7a965dd26 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -490,7 +490,7 @@ static Lisp_Object store_terminal_param (struct terminal *t, Lisp_Object parameter, Lisp_Object value) { Lisp_Object old_alist_elt = Fassq (parameter, t->param_alist); - if (EQ (old_alist_elt, Qnil)) + if (NILP (old_alist_elt)) { tset_param_alist (t, Fcons (Fcons (parameter, value), t->param_alist)); return Qnil; @@ -558,10 +558,10 @@ calculate_glyph_code_table (struct terminal *t) struct unimapdesc unimapdesc = { entry_ct, entries }; if (ioctl (fd, GIO_UNIMAP, &unimapdesc) == 0) { - glyphtab = Fmake_char_table (Qnil, make_number (-1)); + glyphtab = Fmake_char_table (Qnil, make_fixnum (-1)); for (int i = 0; i < unimapdesc.entry_ct; i++) char_table_set (glyphtab, entries[i].unicode, - make_number (entries[i].fontpos)); + make_fixnum (entries[i].fontpos)); break; } if (errno != ENOMEM) diff --git a/src/textprop.c b/src/textprop.c index db9a568d191..ddcdf26884f 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -79,7 +79,7 @@ text_read_only (Lisp_Object propval) static void modify_text_properties (Lisp_Object buffer, Lisp_Object start, Lisp_Object end) { - ptrdiff_t b = XINT (start), e = XINT (end); + ptrdiff_t b = XFIXNUM (start), e = XFIXNUM (end); struct buffer *buf = XBUFFER (buffer), *old = current_buffer; set_buffer_internal (buf); @@ -111,9 +111,6 @@ CHECK_STRING_OR_BUFFER (Lisp_Object x) to by BEGIN and END may be integers or markers; if the latter, they are coerced to integers. - When OBJECT is a string, we increment *BEGIN and *END - to make them origin-one. - Note that buffer points don't correspond to interval indices. For example, point-max is 1 greater than the index of the last character. This difference is handled in the caller, which uses @@ -137,15 +134,15 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, ptrdiff_t searchpos; CHECK_STRING_OR_BUFFER (object); - CHECK_NUMBER_COERCE_MARKER (*begin); - CHECK_NUMBER_COERCE_MARKER (*end); + CHECK_FIXNUM_COERCE_MARKER (*begin); + CHECK_FIXNUM_COERCE_MARKER (*end); /* If we are asked for a point, but from a subr which operates on a range, then return nothing. */ if (EQ (*begin, *end) && begin != end) return NULL; - if (XINT (*begin) > XINT (*end)) + if (XFIXNUM (*begin) > XFIXNUM (*end)) { Lisp_Object n; n = *begin; @@ -157,8 +154,8 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, { register struct buffer *b = XBUFFER (object); - if (!(BUF_BEGV (b) <= XINT (*begin) && XINT (*begin) <= XINT (*end) - && XINT (*end) <= BUF_ZV (b))) + if (!(BUF_BEGV (b) <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) + && XFIXNUM (*end) <= BUF_ZV (b))) args_out_of_range (*begin, *end); i = buffer_intervals (b); @@ -166,24 +163,21 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, if (BUF_BEGV (b) == BUF_ZV (b)) return NULL; - searchpos = XINT (*begin); + searchpos = XFIXNUM (*begin); } else { ptrdiff_t len = SCHARS (object); - if (! (0 <= XINT (*begin) && XINT (*begin) <= XINT (*end) - && XINT (*end) <= len)) + if (! (0 <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) + && XFIXNUM (*end) <= len)) args_out_of_range (*begin, *end); - XSETFASTINT (*begin, XFASTINT (*begin)); - if (begin != end) - XSETFASTINT (*end, XFASTINT (*end)); i = string_intervals (object); if (len == 0) return NULL; - searchpos = XINT (*begin); + searchpos = XFIXNUM (*begin); } if (!i) @@ -544,7 +538,7 @@ interval_of (ptrdiff_t position, Lisp_Object object) } if (!(beg <= position && position <= end)) - args_out_of_range (make_number (position), make_number (position)); + args_out_of_range (make_fixnum (position), make_fixnum (position)); if (beg == end || !i) return NULL; @@ -572,7 +566,7 @@ If POSITION is at the end of OBJECT, the value is nil. */) it means it's the end of OBJECT. There are no properties at the very end, since no character follows. */ - if (XINT (position) == LENGTH (i) + i->position) + if (XFIXNUM (position) == LENGTH (i) + i->position) return Qnil; return i->plist; @@ -604,7 +598,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, { struct window *w = 0; - CHECK_NUMBER_COERCE_MARKER (position); + CHECK_FIXNUM_COERCE_MARKER (position); if (NILP (object)) XSETBUFFER (object, current_buffer); @@ -621,14 +615,14 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, Lisp_Object *overlay_vec; struct buffer *obuf = current_buffer; - if (XINT (position) < BUF_BEGV (XBUFFER (object)) - || XINT (position) > BUF_ZV (XBUFFER (object))) + if (XFIXNUM (position) < BUF_BEGV (XBUFFER (object)) + || XFIXNUM (position) > BUF_ZV (XBUFFER (object))) xsignal1 (Qargs_out_of_range, position); set_buffer_temp (XBUFFER (object)); USE_SAFE_ALLOCA; - GET_OVERLAYS_AT (XINT (position), overlay_vec, noverlays, NULL, false); + GET_OVERLAYS_AT (XFIXNUM (position), overlay_vec, noverlays, NULL, false); noverlays = sort_overlays (overlay_vec, noverlays, w); set_buffer_temp (obuf); @@ -714,8 +708,8 @@ before LIMIT. LIMIT is a no-op if it is greater than (point-max). */) temp = Fnext_overlay_change (position); if (! NILP (limit)) { - CHECK_NUMBER_COERCE_MARKER (limit); - if (XINT (limit) < XINT (temp)) + CHECK_FIXNUM_COERCE_MARKER (limit); + if (XFIXNUM (limit) < XFIXNUM (temp)) temp = limit; } return Fnext_property_change (position, Qnil, temp); @@ -740,8 +734,8 @@ before LIMIT. LIMIT is a no-op if it is less than (point-min). */) temp = Fprevious_overlay_change (position); if (! NILP (limit)) { - CHECK_NUMBER_COERCE_MARKER (limit); - if (XINT (limit) > XINT (temp)) + CHECK_FIXNUM_COERCE_MARKER (limit); + if (XFIXNUM (limit) > XFIXNUM (temp)) temp = limit; } return Fprevious_property_change (position, Qnil, temp); @@ -774,10 +768,10 @@ last valid position in OBJECT. */) if (NILP (position)) { if (NILP (limit)) - position = make_number (SCHARS (object)); + position = make_fixnum (SCHARS (object)); else { - CHECK_NUMBER (limit); + CHECK_FIXNUM (limit); position = limit; } } @@ -796,26 +790,26 @@ last valid position in OBJECT. */) Fset_buffer (object); } - CHECK_NUMBER_COERCE_MARKER (position); + CHECK_FIXNUM_COERCE_MARKER (position); initial_value = Fget_char_property (position, prop, object); if (NILP (limit)) XSETFASTINT (limit, ZV); else - CHECK_NUMBER_COERCE_MARKER (limit); + CHECK_FIXNUM_COERCE_MARKER (limit); - if (XFASTINT (position) >= XFASTINT (limit)) + if (XFIXNAT (position) >= XFIXNAT (limit)) { position = limit; - if (XFASTINT (position) > ZV) + if (XFIXNAT (position) > ZV) XSETFASTINT (position, ZV); } else while (true) { position = Fnext_char_property_change (position, limit); - if (XFASTINT (position) >= XFASTINT (limit)) + if (XFIXNAT (position) >= XFIXNAT (limit)) { position = limit; break; @@ -826,7 +820,7 @@ last valid position in OBJECT. */) break; } - unbind_to (count, Qnil); + position = unbind_to (count, position); } return position; @@ -859,10 +853,10 @@ first valid position in OBJECT. */) if (NILP (position)) { if (NILP (limit)) - position = make_number (0); + position = make_fixnum (0); else { - CHECK_NUMBER (limit); + CHECK_FIXNUM (limit); position = limit; } } @@ -880,30 +874,30 @@ first valid position in OBJECT. */) Fset_buffer (object); } - CHECK_NUMBER_COERCE_MARKER (position); + CHECK_FIXNUM_COERCE_MARKER (position); if (NILP (limit)) XSETFASTINT (limit, BEGV); else - CHECK_NUMBER_COERCE_MARKER (limit); + CHECK_FIXNUM_COERCE_MARKER (limit); - if (XFASTINT (position) <= XFASTINT (limit)) + if (XFIXNAT (position) <= XFIXNAT (limit)) { position = limit; - if (XFASTINT (position) < BEGV) + if (XFIXNAT (position) < BEGV) XSETFASTINT (position, BEGV); } else { Lisp_Object initial_value - = Fget_char_property (make_number (XFASTINT (position) - 1), + = Fget_char_property (make_fixnum (XFIXNAT (position) - 1), prop, object); while (true) { position = Fprevious_char_property_change (position, limit); - if (XFASTINT (position) <= XFASTINT (limit)) + if (XFIXNAT (position) <= XFIXNAT (limit)) { position = limit; break; @@ -911,7 +905,7 @@ first valid position in OBJECT. */) else { Lisp_Object value - = Fget_char_property (make_number (XFASTINT (position) - 1), + = Fget_char_property (make_fixnum (XFIXNAT (position) - 1), prop, object); if (!EQ (value, initial_value)) @@ -920,7 +914,7 @@ first valid position in OBJECT. */) } } - unbind_to (count, Qnil); + position = unbind_to (count, position); } return position; @@ -948,7 +942,7 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */) XSETBUFFER (object, current_buffer); if (!NILP (limit) && !EQ (limit, Qt)) - CHECK_NUMBER_COERCE_MARKER (limit); + CHECK_FIXNUM_COERCE_MARKER (limit); i = validate_interval_range (object, &position, &position, soft); @@ -976,19 +970,19 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */) next = next_interval (i); while (next && intervals_equal (i, next) - && (NILP (limit) || next->position < XFASTINT (limit))) + && (NILP (limit) || next->position < XFIXNAT (limit))) next = next_interval (next); if (!next || (next->position - >= (INTEGERP (limit) - ? XFASTINT (limit) + >= (FIXNUMP (limit) + ? XFIXNAT (limit) : (STRINGP (object) ? SCHARS (object) : BUF_ZV (XBUFFER (object)))))) return limit; else - return make_number (next->position); + return make_fixnum (next->position); } DEFUN ("next-single-property-change", Fnext_single_property_change, @@ -1015,7 +1009,7 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */) XSETBUFFER (object, current_buffer); if (!NILP (limit)) - CHECK_NUMBER_COERCE_MARKER (limit); + CHECK_FIXNUM_COERCE_MARKER (limit); i = validate_interval_range (object, &position, &position, soft); if (!i) @@ -1025,19 +1019,19 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */) next = next_interval (i); while (next && EQ (here_val, textget (next->plist, prop)) - && (NILP (limit) || next->position < XFASTINT (limit))) + && (NILP (limit) || next->position < XFIXNAT (limit))) next = next_interval (next); if (!next || (next->position - >= (INTEGERP (limit) - ? XFASTINT (limit) + >= (FIXNUMP (limit) + ? XFIXNAT (limit) : (STRINGP (object) ? SCHARS (object) : BUF_ZV (XBUFFER (object)))))) return limit; else - return make_number (next->position); + return make_fixnum (next->position); } DEFUN ("previous-property-change", Fprevious_property_change, @@ -1062,30 +1056,30 @@ back past position LIMIT; return LIMIT if nothing is found until LIMIT. */) XSETBUFFER (object, current_buffer); if (!NILP (limit)) - CHECK_NUMBER_COERCE_MARKER (limit); + CHECK_FIXNUM_COERCE_MARKER (limit); i = validate_interval_range (object, &position, &position, soft); if (!i) return limit; /* Start with the interval containing the char before point. */ - if (i->position == XFASTINT (position)) + if (i->position == XFIXNAT (position)) i = previous_interval (i); previous = previous_interval (i); while (previous && intervals_equal (previous, i) && (NILP (limit) - || (previous->position + LENGTH (previous) > XFASTINT (limit)))) + || (previous->position + LENGTH (previous) > XFIXNAT (limit)))) previous = previous_interval (previous); if (!previous || (previous->position + LENGTH (previous) - <= (INTEGERP (limit) - ? XFASTINT (limit) + <= (FIXNUMP (limit) + ? XFIXNAT (limit) : (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object)))))) return limit; else - return make_number (previous->position + LENGTH (previous)); + return make_fixnum (previous->position + LENGTH (previous)); } DEFUN ("previous-single-property-change", Fprevious_single_property_change, @@ -1112,12 +1106,12 @@ back past position LIMIT; return LIMIT if nothing is found until LIMIT. */) XSETBUFFER (object, current_buffer); if (!NILP (limit)) - CHECK_NUMBER_COERCE_MARKER (limit); + CHECK_FIXNUM_COERCE_MARKER (limit); i = validate_interval_range (object, &position, &position, soft); /* Start with the interval containing the char before point. */ - if (i && i->position == XFASTINT (position)) + if (i && i->position == XFIXNAT (position)) i = previous_interval (i); if (!i) @@ -1128,17 +1122,17 @@ back past position LIMIT; return LIMIT if nothing is found until LIMIT. */) while (previous && EQ (here_val, textget (previous->plist, prop)) && (NILP (limit) - || (previous->position + LENGTH (previous) > XFASTINT (limit)))) + || (previous->position + LENGTH (previous) > XFIXNAT (limit)))) previous = previous_interval (previous); if (!previous || (previous->position + LENGTH (previous) - <= (INTEGERP (limit) - ? XFASTINT (limit) + <= (FIXNUMP (limit) + ? XFIXNAT (limit) : (STRINGP (object) ? 0 : BUF_BEGV (XBUFFER (object)))))) return limit; else - return make_number (previous->position + LENGTH (previous)); + return make_fixnum (previous->position + LENGTH (previous)); } /* Used by add-text-properties and add-face-text-property. */ @@ -1164,8 +1158,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end, if (!i) return Qnil; - s = XINT (start); - len = XINT (end) - s; + s = XFIXNUM (start); + len = XFIXNUM (end) - s; /* If this interval already has the properties, we can skip it. */ if (interval_has_all_properties (properties, i)) @@ -1221,8 +1215,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end, if (interval_has_all_properties (properties, i)) { if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); eassert (modified); return Qt; @@ -1232,8 +1226,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end, { add_properties (properties, i, object, set_type); if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } @@ -1243,8 +1237,8 @@ add_text_properties_1 (Lisp_Object start, Lisp_Object end, copy_properties (unchanged, i); add_properties (properties, i, object, set_type); if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } @@ -1348,13 +1342,9 @@ Lisp_Object set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object, Lisp_Object coherent_change_p) { - register INTERVAL i; - Lisp_Object ostart, oend; + INTERVAL i; bool first_time = true; - ostart = start; - oend = end; - properties = validate_plist (properties); if (NILP (object)) @@ -1363,8 +1353,8 @@ set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties, /* If we want no properties for a whole string, get rid of its intervals. */ if (NILP (properties) && STRINGP (object) - && XFASTINT (start) == 0 - && XFASTINT (end) == SCHARS (object)) + && XFIXNAT (start) == 0 + && XFIXNAT (end) == SCHARS (object)) { if (!string_intervals (object)) return Qnil; @@ -1382,11 +1372,6 @@ set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties, if (NILP (properties)) return Qnil; - /* Restore the original START and END values - because validate_interval_range increments them for strings. */ - start = ostart; - end = oend; - i = validate_interval_range (object, &start, &end, hard); /* This can return if start == end. */ if (!i) @@ -1413,42 +1398,33 @@ set_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object properties, set_text_properties_1 (start, end, properties, object, i); if (BUFFERP (object) && !NILP (coherent_change_p)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } /* Replace properties of text from START to END with new list of properties PROPERTIES. OBJECT is the buffer or string containing the text. This does not obey any hooks. - You should provide the interval that START is located in as I. - START and END can be in any order. */ + I is the interval that START is located in. */ void -set_text_properties_1 (Lisp_Object start, Lisp_Object end, Lisp_Object properties, Lisp_Object object, INTERVAL i) +set_text_properties_1 (Lisp_Object start, Lisp_Object end, + Lisp_Object properties, Lisp_Object object, INTERVAL i) { - register INTERVAL prev_changed = NULL; - register ptrdiff_t s, len; - INTERVAL unchanged; + INTERVAL prev_changed = NULL; + ptrdiff_t s = XFIXNUM (start); + ptrdiff_t len = XFIXNUM (end) - s; - if (XINT (start) < XINT (end)) - { - s = XINT (start); - len = XINT (end) - s; - } - else if (XINT (end) < XINT (start)) - { - s = XINT (end); - len = XINT (start) - s; - } - else + if (len == 0) return; + eassert (0 < len); eassert (i); if (i->position != s) { - unchanged = i; + INTERVAL unchanged = i; i = split_interval_right (unchanged, s - unchanged->position); if (LENGTH (i) > len) @@ -1531,8 +1507,8 @@ Use `set-text-properties' if you want to remove all text properties. */) if (!i) return Qnil; - s = XINT (start); - len = XINT (end) - s; + s = XFIXNUM (start); + len = XFIXNUM (end) - s; /* If there are no properties on this entire interval, return. */ if (! interval_has_some_properties (properties, i)) @@ -1589,8 +1565,8 @@ Use `set-text-properties' if you want to remove all text properties. */) { eassert (modified); if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } @@ -1598,8 +1574,8 @@ Use `set-text-properties' if you want to remove all text properties. */) { remove_properties (properties, Qnil, i, object); if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } @@ -1609,8 +1585,8 @@ Use `set-text-properties' if you want to remove all text properties. */) copy_properties (unchanged, i); remove_properties (properties, Qnil, i, object); if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } @@ -1643,8 +1619,8 @@ Return t if any property was actually removed, nil otherwise. */) if (!i) return Qnil; - s = XINT (start); - len = XINT (end) - s; + s = XFIXNUM (start); + len = XFIXNUM (end) - s; /* If there are no properties on the interval, return. */ if (! interval_has_some_properties_list (properties, i)) @@ -1687,9 +1663,9 @@ Return t if any property was actually removed, nil otherwise. */) if (modified) { if (BUFFERP (object)) - signal_after_change (XINT (start), - XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } else @@ -1701,8 +1677,8 @@ Return t if any property was actually removed, nil otherwise. */) modify_text_properties (object, start, end); remove_properties (Qnil, properties, i, object); if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } else @@ -1714,8 +1690,8 @@ Return t if any property was actually removed, nil otherwise. */) modify_text_properties (object, start, end); remove_properties (Qnil, properties, i, object); if (BUFFERP (object)) - signal_after_change (XINT (start), XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } } @@ -1733,9 +1709,9 @@ Return t if any property was actually removed, nil otherwise. */) if (modified) { if (BUFFERP (object)) - signal_after_change (XINT (start), - XINT (end) - XINT (start), - XINT (end) - XINT (start)); + signal_after_change (XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start), + XFIXNUM (end) - XFIXNUM (start)); return Qt; } else @@ -1762,7 +1738,7 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */ i = validate_interval_range (object, &start, &end, soft); if (!i) return (!NILP (value) || EQ (start, end) ? Qnil : start); - e = XINT (end); + e = XFIXNUM (end); while (i) { @@ -1771,9 +1747,9 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */ if (EQ (textget (i->plist, property), value)) { pos = i->position; - if (pos < XINT (start)) - pos = XINT (start); - return make_number (pos); + if (pos < XFIXNUM (start)) + pos = XFIXNUM (start); + return make_fixnum (pos); } i = next_interval (i); } @@ -1798,8 +1774,8 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */ i = validate_interval_range (object, &start, &end, soft); if (!i) return (NILP (value) || EQ (start, end)) ? Qnil : start; - s = XINT (start); - e = XINT (end); + s = XFIXNUM (start); + e = XFIXNUM (end); while (i) { @@ -1809,7 +1785,7 @@ markers). If OBJECT is a string, START and END are 0-based indices into it. */ { if (i->position > s) s = i->position; - return make_number (s); + return make_fixnum (s); } i = next_interval (i); } @@ -1827,7 +1803,7 @@ int text_property_stickiness (Lisp_Object prop, Lisp_Object pos, Lisp_Object buffer) { bool ignore_previous_character; - Lisp_Object prev_pos = make_number (XINT (pos) - 1); + Lisp_Object prev_pos = make_fixnum (XFIXNUM (pos) - 1); Lisp_Object front_sticky; bool is_rear_sticky = true, is_front_sticky = false; /* defaults */ Lisp_Object defalt = Fassq (prop, Vtext_property_default_nonsticky); @@ -1835,7 +1811,7 @@ text_property_stickiness (Lisp_Object prop, Lisp_Object pos, Lisp_Object buffer) if (NILP (buffer)) XSETBUFFER (buffer, current_buffer); - ignore_previous_character = XINT (pos) <= BUF_BEGV (XBUFFER (buffer)); + ignore_previous_character = XFIXNUM (pos) <= BUF_BEGV (XBUFFER (buffer)); if (ignore_previous_character || (CONSP (defalt) && !NILP (XCDR (defalt)))) is_rear_sticky = false; @@ -1896,45 +1872,30 @@ Lisp_Object copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src, Lisp_Object pos, Lisp_Object dest, Lisp_Object prop) { - INTERVAL i; - Lisp_Object res; - Lisp_Object stuff; - Lisp_Object plist; - ptrdiff_t s, e, e2, p, len; - bool modified = false; - - i = validate_interval_range (src, &start, &end, soft); + INTERVAL i = validate_interval_range (src, &start, &end, soft); if (!i) return Qnil; - CHECK_NUMBER_COERCE_MARKER (pos); - { - Lisp_Object dest_start, dest_end; + CHECK_FIXNUM_COERCE_MARKER (pos); - e = XINT (pos) + (XINT (end) - XINT (start)); - if (MOST_POSITIVE_FIXNUM < e) - args_out_of_range (pos, end); - dest_start = pos; - XSETFASTINT (dest_end, e); - /* Apply this to a copy of pos; it will try to increment its arguments, - which we don't want. */ - validate_interval_range (dest, &dest_start, &dest_end, soft); - } + EMACS_INT dest_e = XFIXNUM (pos) + (XFIXNUM (end) - XFIXNUM (start)); + if (MOST_POSITIVE_FIXNUM < dest_e) + args_out_of_range (pos, end); + Lisp_Object dest_end = make_fixnum (dest_e); + validate_interval_range (dest, &pos, &dest_end, soft); - s = XINT (start); - e = XINT (end); - p = XINT (pos); + ptrdiff_t s = XFIXNUM (start), e = XFIXNUM (end), p = XFIXNUM (pos); - stuff = Qnil; + Lisp_Object stuff = Qnil; while (s < e) { - e2 = i->position + LENGTH (i); + ptrdiff_t e2 = i->position + LENGTH (i); if (e2 > e) e2 = e; - len = e2 - s; + ptrdiff_t len = e2 - s; - plist = i->plist; + Lisp_Object plist = i->plist; if (! NILP (prop)) while (! NILP (plist)) { @@ -1948,7 +1909,7 @@ copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src, if (! NILP (plist)) /* Must defer modifications to the interval tree in case src and dest refer to the same string or buffer. */ - stuff = Fcons (list3 (make_number (p), make_number (p + len), plist), + stuff = Fcons (list3 (make_fixnum (p), make_fixnum (p + len), plist), stuff); i = next_interval (i); @@ -1959,9 +1920,11 @@ copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src, s = i->position; } + bool modified = false; + while (! NILP (stuff)) { - res = Fcar (stuff); + Lisp_Object res = Fcar (stuff); res = Fadd_text_properties (Fcar (res), Fcar (Fcdr (res)), Fcar (Fcdr (Fcdr (res))), dest); if (! NILP (res)) @@ -1991,8 +1954,8 @@ text_property_list (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp i = validate_interval_range (object, &start, &end, soft); if (i) { - ptrdiff_t s = XINT (start); - ptrdiff_t e = XINT (end); + ptrdiff_t s = XFIXNUM (start); + ptrdiff_t e = XFIXNUM (end); while (s < e) { @@ -2015,7 +1978,7 @@ text_property_list (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp } if (!NILP (plist)) - result = Fcons (list3 (make_number (s), make_number (s + len), + result = Fcons (list3 (make_fixnum (s), make_fixnum (s + len), plist), result); @@ -2043,8 +2006,8 @@ add_text_properties_from_list (Lisp_Object object, Lisp_Object list, Lisp_Object Lisp_Object item, start, end, plist; item = XCAR (list); - start = make_number (XINT (XCAR (item)) + XINT (delta)); - end = make_number (XINT (XCAR (XCDR (item))) + XINT (delta)); + start = make_fixnum (XFIXNUM (XCAR (item)) + XFIXNUM (delta)); + end = make_fixnum (XFIXNUM (XCAR (XCDR (item))) + XFIXNUM (delta)); plist = XCAR (XCDR (XCDR (item))); Fadd_text_properties (start, end, plist, object); @@ -2062,7 +2025,7 @@ Lisp_Object 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); + ptrdiff_t max = XFIXNUM (new_end); for (; CONSP (list); prev = list, list = XCDR (list)) { @@ -2071,9 +2034,9 @@ extend_property_ranges (Lisp_Object list, Lisp_Object old_end, Lisp_Object new_e item = XCAR (list); beg = XCAR (item); - end = XINT (XCAR (XCDR (item))); + end = XFIXNUM (XCAR (XCDR (item))); - if (XINT (beg) >= max) + if (XFIXNUM (beg) >= max) { /* The start-point is past the end of the new string. Discard this property. */ @@ -2082,7 +2045,7 @@ extend_property_ranges (Lisp_Object list, Lisp_Object old_end, Lisp_Object new_e else XSETCDR (prev, XCDR (list)); } - else if ((end == XINT (old_end) && end != max) + else if ((end == XFIXNUM (old_end) && end != max) || end > max) { /* Either the end-point is past the end of the new string, @@ -2285,10 +2248,10 @@ verify_interval_modification (struct buffer *buf, if (!inhibit_modification_hooks) { hooks = Fnreverse (hooks); - while (! EQ (hooks, Qnil)) + while (! NILP (hooks)) { - call_mod_hooks (Fcar (hooks), make_number (start), - make_number (end)); + call_mod_hooks (Fcar (hooks), make_fixnum (start), + make_fixnum (end)); hooks = Fcdr (hooks); } } diff --git a/src/thread.c b/src/thread.c index 0cd1ae33dc2..ec06493b9e4 100644 --- a/src/thread.c +++ b/src/thread.c @@ -25,16 +25,23 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "process.h" #include "coding.h" #include "syssignal.h" +#include "keyboard.h" -static struct thread_state main_thread; +union aligned_thread_state +{ + struct thread_state s; + GCALIGNED_UNION_MEMBER +}; +verify (GCALIGNED (union aligned_thread_state)); -struct thread_state *current_thread = &main_thread; +static union aligned_thread_state main_thread; -static struct thread_state *all_threads = &main_thread; +struct thread_state *current_thread = &main_thread.s; + +static struct thread_state *all_threads = &main_thread.s; static sys_mutex_t global_lock; -extern int poll_suppress_count; extern volatile int interrupt_input_blocked; @@ -113,7 +120,7 @@ maybe_reacquire_global_lock (void) /* SIGINT handler is always run on the main thread, see deliver_process_signal, so reflect that in our thread-tracking variables. */ - current_thread = &main_thread; + current_thread = &main_thread.s; if (current_thread->not_holding_lock) { @@ -656,6 +663,12 @@ mark_threads (void) flush_stack_call_func (mark_threads_callback, NULL); } +void +unmark_main_thread (void) +{ + main_thread.s.header.size &= ~ARRAY_MARK_FLAG; +} + static void @@ -681,7 +694,7 @@ invoke_thread_function (void) { ptrdiff_t count = SPECPDL_INDEX (); - Ffuncall (1, ¤t_thread->function); + current_thread->result = Ffuncall (1, ¤t_thread->function); return unbind_to (count, Qnil); } @@ -789,6 +802,7 @@ If NAME is given, it must be a string; it names the new thread. */) 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->result = Qnil; new_thread->error_symbol = Qnil; new_thread->error_data = Qnil; new_thread->event_object = Qnil; @@ -862,7 +876,8 @@ DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0, 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. */) +or `thread-join' in the target thread. +If THREAD is the main thread, just the error message is shown. */) (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data) { struct thread_state *tstate; @@ -873,13 +888,31 @@ or `thread-join' in the target 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; +#ifdef THREADS_ENABLED + if (main_thread_p (tstate)) + { + /* Construct an event. */ + struct input_event event; + EVENT_INIT (event); + event.kind = THREAD_EVENT; + event.frame_or_window = Qnil; + event.arg = list3 (Fcurrent_thread (), error_symbol, data); + + /* Store it into the input event queue. */ + kbd_buffer_store_event (&event); + } - if (tstate->wait_condvar) - flush_stack_call_func (thread_signal_callback, tstate); + else +#endif + { + /* 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; } @@ -933,12 +966,13 @@ thread_join_callback (void *arg) 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. */) +This blocks the current thread until THREAD exits or until the current +thread is signaled. It returns the result of the THREAD function. It +is an error for a thread to try to join itself. */) (Lisp_Object thread) { struct thread_state *tstate; + Lisp_Object error_symbol, error_data; CHECK_THREAD (thread); tstate = XTHREAD (thread); @@ -946,10 +980,16 @@ It is an error for a thread to try to join itself. */) if (tstate == current_thread) error ("Cannot join current thread"); + error_symbol = tstate->error_symbol; + error_data = tstate->error_data; + if (thread_live_p (tstate)) flush_stack_call_func (thread_join_callback, tstate); - return Qnil; + if (!NILP (error_symbol)) + Fsignal (error_symbol, error_data); + + return tstate->result; } DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, @@ -973,11 +1013,17 @@ DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, return result; } -DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 0, 0, - doc: /* Return the last error form recorded by a dying thread. */) - (void) +DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 1, 0, + doc: /* Return the last error form recorded by a dying thread. +If CLEANUP is non-nil, remove this error form from history. */) + (Lisp_Object cleanup) { - return last_thread_error; + Lisp_Object result = last_thread_error; + + if (!NILP (cleanup)) + last_thread_error = Qnil; + + return result; } @@ -1004,22 +1050,31 @@ thread_check_current_buffer (struct buffer *buffer) static void init_main_thread (void) { - main_thread.header.size + main_thread.s.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; + XSETPVECTYPE (&main_thread.s, PVEC_THREAD); + main_thread.s.m_last_thing_searched = Qnil; + main_thread.s.m_saved_last_thing_searched = Qnil; + main_thread.s.name = Qnil; + main_thread.s.function = Qnil; + main_thread.s.result = Qnil; + main_thread.s.error_symbol = Qnil; + main_thread.s.error_data = Qnil; + main_thread.s.event_object = Qnil; } bool main_thread_p (void *ptr) { - return ptr == &main_thread; + return ptr == &main_thread.s; +} + +bool +in_current_thread (void) +{ + if (current_thread == NULL) + return false; + return sys_thread_equal (sys_thread_self (), current_thread->thread_id); } void @@ -1032,11 +1087,11 @@ void init_threads (void) { init_main_thread (); - sys_cond_init (&main_thread.thread_condvar); + sys_cond_init (&main_thread.s.thread_condvar); sys_mutex_init (&global_lock); sys_mutex_lock (&global_lock); - current_thread = &main_thread; - main_thread.thread_id = sys_thread_self (); + current_thread = &main_thread.s; + main_thread.s.thread_id = sys_thread_self (); } void @@ -1078,4 +1133,12 @@ syms_of_threads (void) DEFSYM (Qthreadp, "threadp"); DEFSYM (Qmutexp, "mutexp"); DEFSYM (Qcondition_variable_p, "condition-variable-p"); + + DEFVAR_LISP ("main-thread", Vmain_thread, + doc: /* The main thread of Emacs. */); +#ifdef THREADS_ENABLED + XSETTHREAD (Vmain_thread, &main_thread.s); +#else + Vmain_thread = Qnil; +#endif } diff --git a/src/thread.h b/src/thread.h index 8877f22ffa5..288b671257d 100644 --- a/src/thread.h +++ b/src/thread.h @@ -19,7 +19,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef THREAD_H #define THREAD_H -#include "regex.h" +#include "regex-emacs.h" #ifdef WINDOWSNT #include <sys/socket.h> @@ -30,7 +30,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #endif #include "sysselect.h" /* FIXME */ -#include "systime.h" /* FIXME */ #include "systhread.h" struct thread_state @@ -52,6 +51,9 @@ struct thread_state /* The thread's function. */ Lisp_Object function; + /* The thread's result, if function has finished. */ + Lisp_Object result; + /* If non-nil, this thread has been signaled. */ Lisp_Object error_symbol; Lisp_Object error_data; @@ -109,8 +111,8 @@ struct thread_state 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 + /* Every call to re_match_2, etc., must pass &search_regs as the regs + argument unless you can show it is unnecessary (i.e., if re_match_2 is certainly going to be called again before region-around-match can be called). @@ -137,15 +139,6 @@ struct thread_state 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 @@ -190,7 +183,7 @@ struct thread_state /* Threads are kept on a linked list. */ struct thread_state *next_thread; -}; +} GCALIGNED_STRUCT; INLINE bool THREADP (Lisp_Object a) @@ -208,7 +201,7 @@ INLINE struct thread_state * XTHREAD (Lisp_Object a) { eassert (THREADP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct thread_state); } /* A mutex in lisp is represented by a system condition variable. @@ -237,7 +230,7 @@ struct Lisp_Mutex /* The lower-level mutex object. */ lisp_mutex_t mutex; -}; +} GCALIGNED_STRUCT; INLINE bool MUTEXP (Lisp_Object a) @@ -255,7 +248,7 @@ INLINE struct Lisp_Mutex * XMUTEX (Lisp_Object a) { eassert (MUTEXP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Mutex); } /* A condition variable as a lisp object. */ @@ -271,7 +264,7 @@ struct Lisp_CondVar /* The lower-level condition variable object. */ sys_cond_t cond; -}; +} GCALIGNED_STRUCT; INLINE bool CONDVARP (Lisp_Object a) @@ -289,7 +282,7 @@ INLINE struct Lisp_CondVar * XCONDVAR (Lisp_Object a) { eassert (CONDVARP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_CondVar); } extern struct thread_state *current_thread; @@ -303,6 +296,7 @@ extern void init_threads_once (void); extern void init_threads (void); extern void syms_of_threads (void); extern bool main_thread_p (void *); +extern bool in_current_thread (void); typedef int select_func (int, fd_set *, fd_set *, fd_set *, const struct timespec *, const sigset_t *); diff --git a/src/timefns.c b/src/timefns.c new file mode 100644 index 00000000000..58dda1c7061 --- /dev/null +++ b/src/timefns.c @@ -0,0 +1,1752 @@ +/* Timestamp functions for Emacs + +Copyright (C) 1985-1987, 1989, 1993-2018 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include "systime.h" + +#include "blockinput.h" +#include "bignum.h" +#include "coding.h" +#include "lisp.h" + +#include <strftime.h> + +#include <errno.h> +#include <limits.h> +#include <math.h> +#include <stdio.h> +#include <stdlib.h> + +#ifdef HAVE_TIMEZONE_T +# include <sys/param.h> +# if defined __NetBSD_Version__ && __NetBSD_Version__ < 700000000 +# define HAVE_TZALLOC_BUG true +# endif +#endif +#ifndef HAVE_TZALLOC_BUG +# define HAVE_TZALLOC_BUG false +#endif + +#define TM_YEAR_BASE 1900 + +#ifndef HAVE_TM_GMTOFF +# define HAVE_TM_GMTOFF false +#endif + +#ifndef TIME_T_MIN +# define TIME_T_MIN TYPE_MINIMUM (time_t) +#endif +#ifndef TIME_T_MAX +# define TIME_T_MAX TYPE_MAXIMUM (time_t) +#endif + +/* Compile with -DFASTER_TIMEFNS=0 to disable common optimizations and + allow easier testing of some slow-path code. */ +#ifndef FASTER_TIMEFNS +# define FASTER_TIMEFNS 1 +#endif + +/* Whether to warn about Lisp timestamps (TICKS . HZ) that may be + instances of obsolete-format timestamps (HI . LO) where HI is + the high-order bits and LO the low-order 16 bits. Currently this + is true, but it should change to false in a future version of + Emacs. Compile with -DWARN_OBSOLETE_TIMESTAMPS=0 to see what the + future will be like. */ +#ifndef WARN_OBSOLETE_TIMESTAMPS +enum { WARN_OBSOLETE_TIMESTAMPS = true }; +#endif + +/* Although current-time etc. generate list-format timestamps + (HI LO US PS), the plan is to change these functions to generate + frequency-based timestamps (TICKS . HZ) in a future release. + To try this now, compile with -DCURRENT_TIME_LIST=0. */ +#ifndef CURRENT_TIME_LIST +enum { CURRENT_TIME_LIST = true }; +#endif + +#if FIXNUM_OVERFLOW_P (1000000000) +static Lisp_Object timespec_hz; +#else +# define timespec_hz make_fixnum (TIMESPEC_HZ) +#endif + +#define TRILLION 1000000000000 +#if FIXNUM_OVERFLOW_P (TRILLION) +static Lisp_Object trillion; +# define ztrillion (XBIGNUM (trillion)->value) +#else +# define trillion make_fixnum (TRILLION) +# if ULONG_MAX < TRILLION || !FASTER_TIMEFNS +mpz_t ztrillion; +# endif +#endif + +/* Return a struct timeval that is roughly equivalent to T. + Use the least timeval not less than T. + Return an extremal value if the result would overflow. */ +struct timeval +make_timeval (struct timespec t) +{ + struct timeval tv; + tv.tv_sec = t.tv_sec; + tv.tv_usec = t.tv_nsec / 1000; + + if (t.tv_nsec % 1000 != 0) + { + if (tv.tv_usec < 999999) + tv.tv_usec++; + else if (tv.tv_sec < TIME_T_MAX) + { + tv.tv_sec++; + tv.tv_usec = 0; + } + } + + return tv; +} + +/* Yield A's UTC offset, or an unspecified value if unknown. */ +static long int +tm_gmtoff (struct tm *a) +{ +#if HAVE_TM_GMTOFF + return a->tm_gmtoff; +#else + return 0; +#endif +} + +/* Yield A - B, measured in seconds. + This function is copied from the GNU C Library. */ +static int +tm_diff (struct tm *a, struct tm *b) +{ + /* Compute intervening leap days correctly even if year is negative. + Take care to avoid int overflow in leap day calculations, + but it's OK to assume that A and B are close to each other. */ + int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3); + int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3); + int a100 = a4 / 25 - (a4 % 25 < 0); + int b100 = b4 / 25 - (b4 % 25 < 0); + int a400 = a100 >> 2; + int b400 = b100 >> 2; + int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400); + int years = a->tm_year - b->tm_year; + int days = (365 * years + intervening_leap_days + + (a->tm_yday - b->tm_yday)); + return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour)) + + (a->tm_min - b->tm_min)) + + (a->tm_sec - b->tm_sec)); +} + +enum { tzeqlen = sizeof "TZ=" - 1 }; + +/* Time zones equivalent to current local time and to UTC, respectively. */ +static timezone_t local_tz; +static timezone_t const utc_tz = 0; + +static struct tm * +emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm) +{ + tm = localtime_rz (tz, t, tm); + if (!tm && errno == ENOMEM) + memory_full (SIZE_MAX); + return tm; +} + +static _Noreturn void +invalid_time_zone_specification (Lisp_Object zone) +{ + xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone); +} + +/* Free a timezone, except do not free the time zone for local time. + Freeing utc_tz is also a no-op. */ +static void +xtzfree (timezone_t tz) +{ + if (tz != local_tz) + tzfree (tz); +} + +/* Convert the Lisp time zone rule ZONE to a timezone_t object. + The returned value either is 0, or is LOCAL_TZ, or is newly allocated. + If SETTZ, set Emacs local time to the time zone rule; otherwise, + the caller should eventually pass the returned value to xtzfree. */ +static timezone_t +tzlookup (Lisp_Object zone, bool settz) +{ + 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; + + if (NILP (zone)) + return local_tz; + else if (EQ (zone, Qt) || EQ (zone, make_fixnum (0))) + { + zone_string = "UTC0"; + new_tz = utc_tz; + } + else + { + bool plain_integer = FIXNUMP (zone); + + if (EQ (zone, Qwall)) + zone_string = 0; + else if (STRINGP (zone)) + zone_string = SSDATA (ENCODE_SYSTEM (zone)); + else if (plain_integer || (CONSP (zone) && FIXNUMP (XCAR (zone)) + && CONSP (XCDR (zone)))) + { + Lisp_Object abbr UNINIT; + if (!plain_integer) + { + abbr = XCAR (XCDR (zone)); + zone = XCAR (zone); + } + + EMACS_INT abszone = eabs (XFIXNUM (zone)), hour = abszone / (60 * 60); + 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, + XFIXNUM (zone) < 0 ? -numzone : numzone, + &"-"[XFIXNUM (zone) < 0], hour, min, sec); + zone_string = tzbuf; + } + else + { + AUTO_STRING (leading, "<"); + AUTO_STRING_WITH_LEN (trailing, tzbuf, + sprintf (tzbuf, trailing_tzbuf_format, + &"-"[XFIXNUM (zone) < 0], + hour, min, sec)); + zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr), + trailing)); + } + } + else + invalid_time_zone_specification (zone); + + new_tz = tzalloc (zone_string); + + if (HAVE_TZALLOC_BUG && !new_tz && errno != ENOMEM && plain_integer + && XFIXNUM (zone) % (60 * 60) == 0) + { + /* tzalloc mishandles POSIX strings; fall back on tzdb if + possible (Bug#30738). */ + sprintf (tzbuf, "Etc/GMT%+"pI"d", - (XFIXNUM (zone) / (60 * 60))); + new_tz = tzalloc (zone_string); + } + + if (!new_tz) + { + if (errno == ENOMEM) + memory_full (SIZE_MAX); + invalid_time_zone_specification (zone); + } + } + + if (settz) + { + block_input (); + emacs_setenv_TZ (zone_string); + tzset (); + timezone_t old_tz = local_tz; + local_tz = new_tz; + tzfree (old_tz); + unblock_input (); + } + + return new_tz; +} + +void +init_timefns (bool dumping) +{ +#ifndef CANNOT_DUMP + /* 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"; + + /* When just dumping out, set the time zone to a known unlikely value + and skip the rest of this function. */ + if (dumping) + { + xputenv (dump_tz_string); + tzset (); + return; + } +#endif + + char *tz = getenv ("TZ"); + +#if !defined CANNOT_DUMP + /* If the execution TZ happens to be the same as the dump TZ, + change it to some other value and then change it back, + to force the underlying implementation to reload the TZ info. + This is needed on implementations that load TZ info from files, + since the TZ file contents may differ between dump and execution. */ + if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0) + { + ++*tz; + tzset (); + --*tz; + } +#endif + + /* Set the time zone rule now, so that the call to putenv is done + before multiple threads are active. */ + tzlookup (tz ? build_string (tz) : Qwall, true); +} + +/* Report that a time value is out of range for Emacs. */ +void +time_overflow (void) +{ + error ("Specified time is not representable"); +} + +static _Noreturn void +time_error (int err) +{ + switch (err) + { + case ENOMEM: memory_full (SIZE_MAX); + case EOVERFLOW: time_overflow (); + default: error ("Invalid time specification"); + } +} + +static _Noreturn void +invalid_hz (Lisp_Object hz) +{ + xsignal2 (Qerror, build_string ("Invalid time frequency"), hz); +} + +/* Return the upper part of the time T (everything but the bottom 16 bits). */ +static Lisp_Object +hi_time (time_t t) +{ + return INT_TO_INTEGER (t >> LO_TIME_BITS); +} + +/* Return the bottom bits of the time T. */ +static Lisp_Object +lo_time (time_t t) +{ + return make_fixnum (t & ((1 << LO_TIME_BITS) - 1)); +} + +/* Convert T into an Emacs time *RESULT, truncating toward minus infinity. + Return zero if successful, an error number otherwise. */ +static int +decode_float_time (double t, struct lisp_time *result) +{ + if (!isfinite (t)) + return isnan (t) ? EINVAL : EOVERFLOW; + /* Actual hz unknown; guess TIMESPEC_HZ. */ + mpz_set_d (mpz[1], t); + mpz_set_si (mpz[0], floor ((t - trunc (t)) * TIMESPEC_HZ)); + mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ); + result->ticks = make_integer_mpz (); + result->hz = timespec_hz; + return 0; +} + +/* Compute S + NS/TIMESPEC_HZ as a double. + Calls to this function suffer from double-rounding; + work around some of the problem by using long double. */ +static double +s_ns_to_double (long double s, long double ns) +{ + return s + ns / TIMESPEC_HZ; +} + +/* Make a 4-element timestamp (HI LO US PS) from TICKS and HZ. + Drop any excess precision. */ +static Lisp_Object +ticks_hz_list4 (Lisp_Object ticks, Lisp_Object hz) +{ + mpz_t *zticks = bignum_integer (&mpz[0], ticks); +#if FASTER_TIMEFNS && TRILLION <= ULONG_MAX + mpz_mul_ui (mpz[0], *zticks, TRILLION); +#else + mpz_mul (mpz[0], *zticks, ztrillion); +#endif + mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz)); +#if FASTER_TIMEFNS && TRILLION <= ULONG_MAX + unsigned long int fullps = mpz_fdiv_q_ui (mpz[0], mpz[0], TRILLION); + int us = fullps / 1000000; + int ps = fullps % 1000000; +#else + mpz_fdiv_qr (mpz[0], mpz[1], mpz[0], ztrillion); + int ps = mpz_fdiv_q_ui (mpz[1], mpz[1], 1000000); + int us = mpz_get_ui (mpz[1]); +#endif + unsigned long ulo = mpz_get_ui (mpz[0]); + if (mpz_sgn (mpz[0]) < 0) + ulo = -ulo; + int lo = ulo & ((1 << LO_TIME_BITS) - 1); + mpz_fdiv_q_2exp (mpz[0], mpz[0], LO_TIME_BITS); + return list4 (make_integer_mpz (), make_fixnum (lo), + make_fixnum (us), make_fixnum (ps)); +} + +/* Set ROP to T. */ +static void +mpz_set_time (mpz_t rop, time_t t) +{ + if (EXPR_SIGNED (t)) + mpz_set_intmax (rop, t); + else + mpz_set_uintmax (rop, t); +} + +/* Store into mpz[0] a clock tick count for T, assuming a + TIMESPEC_HZ-frequency clock. Use mpz[1] as a temp. */ +static void +timespec_mpz (struct timespec t) +{ + mpz_set_ui (mpz[0], t.tv_nsec); + mpz_set_time (mpz[1], t.tv_sec); + mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ); +} + +/* Convert T to a Lisp integer counting TIMESPEC_HZ ticks. */ +static Lisp_Object +timespec_ticks (struct timespec t) +{ + intmax_t accum; + if (FASTER_TIMEFNS + && !INT_MULTIPLY_WRAPV (t.tv_sec, TIMESPEC_HZ, &accum) + && !INT_ADD_WRAPV (t.tv_nsec, accum, &accum)) + return make_int (accum); + timespec_mpz (t); + return make_integer_mpz (); +} + +/* Convert T to a Lisp integer counting HZ ticks, taking the floor. + Assume T is valid, but check HZ. */ +static Lisp_Object +time_hz_ticks (time_t t, Lisp_Object hz) +{ + if (FIXNUMP (hz)) + { + if (XFIXNUM (hz) <= 0) + invalid_hz (hz); + intmax_t ticks; + if (FASTER_TIMEFNS && !INT_MULTIPLY_WRAPV (t, XFIXNUM (hz), &ticks)) + return make_int (ticks); + } + else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value))) + invalid_hz (hz); + + mpz_set_time (mpz[0], t); + mpz_mul (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz)); + return make_integer_mpz (); +} +static Lisp_Object +lisp_time_hz_ticks (struct lisp_time t, Lisp_Object hz) +{ + if (FASTER_TIMEFNS && EQ (t.hz, hz)) + return t.ticks; + if (FIXNUMP (hz)) + { + if (XFIXNUM (hz) <= 0) + invalid_hz (hz); + intmax_t ticks; + if (FASTER_TIMEFNS && FIXNUMP (t.ticks) && FIXNUMP (t.hz) + && !INT_MULTIPLY_WRAPV (XFIXNUM (t.ticks), XFIXNUM (hz), &ticks)) + return make_int (ticks / XFIXNUM (t.hz) + - (ticks % XFIXNUM (t.hz) < 0)); + } + else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value))) + invalid_hz (hz); + + mpz_mul (mpz[0], + *bignum_integer (&mpz[0], t.ticks), + *bignum_integer (&mpz[1], hz)); + mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], t.hz)); + return make_integer_mpz (); +} + +/* Convert T to a Lisp integer counting seconds, taking the floor. */ +static Lisp_Object +lisp_time_seconds (struct lisp_time t) +{ + if (!FASTER_TIMEFNS) + return lisp_time_hz_ticks (t, make_fixnum (1)); + if (FIXNUMP (t.ticks) && FIXNUMP (t.hz)) + return make_fixnum (XFIXNUM (t.ticks) / XFIXNUM (t.hz) + - (XFIXNUM (t.ticks) % XFIXNUM (t.hz) < 0)); + mpz_fdiv_q (mpz[0], + *bignum_integer (&mpz[0], t.ticks), + *bignum_integer (&mpz[1], t.hz)); + return make_integer_mpz (); +} + +/* Convert T to a Lisp timestamp. */ +Lisp_Object +make_lisp_time (struct timespec t) +{ + if (CURRENT_TIME_LIST) + { + time_t s = t.tv_sec; + int ns = t.tv_nsec; + return list4 (hi_time (s), lo_time (s), + make_fixnum (ns / 1000), make_fixnum (ns % 1000 * 1000)); + } + else + return Fcons (timespec_ticks (t), timespec_hz); +} + +/* Convert T to a Lisp timestamp. FORM specifies the timestamp format. */ +static Lisp_Object +time_form_stamp (time_t t, Lisp_Object form) +{ + if (NILP (form)) + form = CURRENT_TIME_LIST ? Qlist : Qt; + if (EQ (form, Qlist)) + return list2 (hi_time (t), lo_time (t)); + if (EQ (form, Qt) || EQ (form, Qinteger)) + return INT_TO_INTEGER (t); + return Fcons (time_hz_ticks (t, form), form); +} +static Lisp_Object +lisp_time_form_stamp (struct lisp_time t, Lisp_Object form) +{ + if (NILP (form)) + form = CURRENT_TIME_LIST ? Qlist : Qt; + if (EQ (form, Qlist)) + return ticks_hz_list4 (t.ticks, t.hz); + if (EQ (form, Qinteger)) + return lisp_time_seconds (t); + if (EQ (form, Qt)) + form = t.hz; + return Fcons (lisp_time_hz_ticks (t, form), form); +} + +/* From what should be a valid timestamp (TICKS . HZ), generate the + corresponding time values. + + If RESULT is not null, store into *RESULT the converted time. + Otherwise, store into *DRESULT the number of seconds since the + start of the POSIX Epoch. Unsuccessful calls may or may not store + results. + + Return zero if successful, an error number if (TICKS . HZ) would not + be a valid new-format timestamp. */ +static int +decode_ticks_hz (Lisp_Object ticks, Lisp_Object hz, + struct lisp_time *result, double *dresult) +{ + int ns; + mpz_t *q = &mpz[0]; + + if (! (INTEGERP (ticks) + && ((FIXNUMP (hz) && 0 < XFIXNUM (hz)) + || (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value))))) + return EINVAL; + + if (result) + { + result->ticks = ticks; + result->hz = hz; + } + else + { + if (FASTER_TIMEFNS && EQ (hz, timespec_hz)) + { + if (FIXNUMP (ticks)) + { + verify (1 < TIMESPEC_HZ); + EMACS_INT s = XFIXNUM (ticks) / TIMESPEC_HZ; + ns = XFIXNUM (ticks) % TIMESPEC_HZ; + if (ns < 0) + s--, ns += TIMESPEC_HZ; + *dresult = s_ns_to_double (s, ns); + return 0; + } + ns = mpz_fdiv_q_ui (*q, XBIGNUM (ticks)->value, TIMESPEC_HZ); + } + else if (FASTER_TIMEFNS && EQ (hz, make_fixnum (1))) + { + ns = 0; + if (FIXNUMP (ticks)) + { + *dresult = XFIXNUM (ticks); + return 0; + } + q = &XBIGNUM (ticks)->value; + } + else + { + mpz_mul_ui (*q, *bignum_integer (&mpz[1], ticks), TIMESPEC_HZ); + mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], hz)); + ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ); + } + + *dresult = s_ns_to_double (mpz_get_d (*q), ns); + } + + return 0; +} + +/* Lisp timestamp classification. */ +enum timeform + { + TIMEFORM_INVALID = 0, + TIMEFORM_HI_LO, /* seconds in the form (HI << LO_TIME_BITS) + LO. */ + TIMEFORM_HI_LO_US, /* seconds plus microseconds (HI LO US) */ + TIMEFORM_NIL, /* current time in nanoseconds */ + TIMEFORM_HI_LO_US_PS, /* seconds plus micro and picoseconds (HI LO US PS) */ + TIMEFORM_FLOAT, /* time as a float */ + TIMEFORM_TICKS_HZ /* fractional time: HI is ticks, LO is ticks per second */ + }; + +/* From the valid form FORM and the time components HIGH, LOW, USEC + and PSEC, generate the corresponding time value. If LOW is + floating point, the other components should be zero and FORM should + not be TIMEFORM_TICKS_HZ. + + If RESULT is not null, store into *RESULT the converted time. + Otherwise, store into *DRESULT the number of seconds since the + start of the POSIX Epoch. Unsuccessful calls may or may not store + results. + + Return zero if successful, an error number otherwise. */ +static int +decode_time_components (enum timeform form, + Lisp_Object high, Lisp_Object low, + Lisp_Object usec, Lisp_Object psec, + struct lisp_time *result, double *dresult) +{ + switch (form) + { + case TIMEFORM_INVALID: + return EINVAL; + + case TIMEFORM_TICKS_HZ: + return decode_ticks_hz (high, low, result, dresult); + + case TIMEFORM_FLOAT: + { + double t = XFLOAT_DATA (low); + if (result) + return decode_float_time (t, result); + else + { + *dresult = t; + return 0; + } + } + + case TIMEFORM_NIL: + { + struct timespec now = current_timespec (); + if (result) + { + result->ticks = timespec_ticks (now); + result->hz = timespec_hz; + } + else + *dresult = s_ns_to_double (now.tv_sec, now.tv_nsec); + return 0; + } + + default: + break; + } + + if (! (INTEGERP (high) && INTEGERP (low) + && FIXNUMP (usec) && FIXNUMP (psec))) + return EINVAL; + EMACS_INT us = XFIXNUM (usec); + EMACS_INT ps = XFIXNUM (psec); + + /* Normalize out-of-range lower-order components by carrying + each overflow into the next higher-order component. */ + us += ps / 1000000 - (ps % 1000000 < 0); + mpz_set_intmax (mpz[0], us / 1000000 - (us % 1000000 < 0)); + mpz_add (mpz[0], mpz[0], *bignum_integer (&mpz[1], low)); + mpz_addmul_ui (mpz[0], *bignum_integer (&mpz[1], high), 1 << LO_TIME_BITS); + ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0); + us = us % 1000000 + 1000000 * (us % 1000000 < 0); + + if (result) + { + switch (form) + { + case TIMEFORM_HI_LO: + /* Floats and nil were handled above, so it was an integer. */ + result->hz = make_fixnum (1); + break; + + case TIMEFORM_HI_LO_US: + mpz_mul_ui (mpz[0], mpz[0], 1000000); + mpz_add_ui (mpz[0], mpz[0], us); + result->hz = make_fixnum (1000000); + break; + + case TIMEFORM_HI_LO_US_PS: + mpz_mul_ui (mpz[0], mpz[0], 1000000); + mpz_add_ui (mpz[0], mpz[0], us); + mpz_mul_ui (mpz[0], mpz[0], 1000000); + mpz_add_ui (mpz[0], mpz[0], ps); + result->hz = trillion; + break; + + default: + eassume (false); + } + result->ticks = make_integer_mpz (); + } + else + *dresult = mpz_get_d (mpz[0]) + (us * 1e6L + ps) / 1e12L; + + return 0; +} + +enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 }; + +/* Decode a Lisp timestamp SPECIFIED_TIME that represents a time. + + FLAGS specifies conversion flags. If FLAGS & DECODE_SECS_ONLY, + ignore and do not validate any sub-second components of an + old-format SPECIFIED_TIME. If FLAGS & WARN_OBSOLETE_TIMESTAMPS, + diagnose what could be obsolete (HIGH . LOW) timestamps. + + If PFORM is not null, store into *PFORM the form of SPECIFIED-TIME. + If RESULT is not null, store into *RESULT the converted time; + otherwise, store into *DRESULT the number of seconds since the + start of the POSIX Epoch. Unsuccessful calls may or may not store + results. + + Signal an error if unsuccessful. */ +static void +decode_lisp_time (Lisp_Object specified_time, int flags, + enum timeform *pform, + struct lisp_time *result, double *dresult) +{ + Lisp_Object high = make_fixnum (0); + Lisp_Object low = specified_time; + Lisp_Object usec = make_fixnum (0); + Lisp_Object psec = make_fixnum (0); + enum timeform form = TIMEFORM_HI_LO; + + if (NILP (specified_time)) + form = TIMEFORM_NIL; + else if (FLOATP (specified_time)) + form = TIMEFORM_FLOAT; + else if (CONSP (specified_time)) + { + high = XCAR (specified_time); + low = XCDR (specified_time); + if (CONSP (low)) + { + Lisp_Object low_tail = XCDR (low); + low = XCAR (low); + if (! (flags & DECODE_SECS_ONLY)) + { + if (CONSP (low_tail)) + { + usec = XCAR (low_tail); + low_tail = XCDR (low_tail); + if (CONSP (low_tail)) + { + psec = XCAR (low_tail); + form = TIMEFORM_HI_LO_US_PS; + } + else + form = TIMEFORM_HI_LO_US; + } + else if (!NILP (low_tail)) + { + usec = low_tail; + form = TIMEFORM_HI_LO_US; + } + } + } + else + { + if (flags & WARN_OBSOLETE_TIMESTAMPS + && RANGED_FIXNUMP (0, low, (1 << LO_TIME_BITS) - 1)) + message ("obsolete timestamp with cdr %"pI"d", XFIXNUM (low)); + form = TIMEFORM_TICKS_HZ; + } + + /* Require LOW to be an integer, as otherwise the computation + would be considerably trickier. */ + if (! INTEGERP (low)) + form = TIMEFORM_INVALID; + } + + if (pform) + *pform = form; + int err = decode_time_components (form, high, low, usec, psec, + result, dresult); + if (err) + time_error (err); +} + +/* Convert Z to time_t, returning true if it fits. */ +static bool +mpz_time (mpz_t const z, time_t *t) +{ + if (TYPE_SIGNED (time_t)) + { + intmax_t i; + if (! (mpz_to_intmax (z, &i) && TIME_T_MIN <= i && i <= TIME_T_MAX)) + return false; + *t = i; + } + else + { + uintmax_t i; + if (! (mpz_to_uintmax (z, &i) && i <= TIME_T_MAX)) + return false; + *t = i; + } + return true; +} + +/* Convert T to struct timespec, returning an invalid timespec + if T does not fit. */ +static struct timespec +lisp_to_timespec (struct lisp_time t) +{ + struct timespec result = invalid_timespec (); + int ns; + mpz_t *q = &mpz[0]; + + if (FASTER_TIMEFNS && EQ (t.hz, timespec_hz)) + { + if (FIXNUMP (t.ticks)) + { + EMACS_INT s = XFIXNUM (t.ticks) / TIMESPEC_HZ; + ns = XFIXNUM (t.ticks) % TIMESPEC_HZ; + if (ns < 0) + s--, ns += TIMESPEC_HZ; + if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s) + && s <= TIME_T_MAX) + { + result.tv_sec = s; + result.tv_nsec = ns; + } + return result; + } + else + ns = mpz_fdiv_q_ui (*q, XBIGNUM (t.ticks)->value, TIMESPEC_HZ); + } + else if (FASTER_TIMEFNS && EQ (t.hz, make_fixnum (1))) + { + ns = 0; + if (FIXNUMP (t.ticks)) + { + EMACS_INT s = XFIXNUM (t.ticks); + if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s) + && s <= TIME_T_MAX) + { + result.tv_sec = s; + result.tv_nsec = ns; + } + return result; + } + else + q = &XBIGNUM (t.ticks)->value; + } + else + { + mpz_mul_ui (*q, *bignum_integer (q, t.ticks), TIMESPEC_HZ); + mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], t.hz)); + ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ); + } + + /* With some versions of MinGW, tv_sec is a 64-bit type, whereas + time_t is a 32-bit type. */ + time_t sec; + if (mpz_time (*q, &sec)) + { + result.tv_sec = sec; + result.tv_nsec = ns; + } + return result; +} + +/* Convert (HIGH LOW USEC PSEC) to struct timespec. + Return true if successful. */ +bool +list4_to_timespec (Lisp_Object high, Lisp_Object low, + Lisp_Object usec, Lisp_Object psec, + struct timespec *result) +{ + struct lisp_time t; + if (decode_time_components (TIMEFORM_HI_LO_US_PS, high, low, usec, psec, + &t, 0)) + return false; + *result = lisp_to_timespec (t); + return timespec_valid_p (*result); +} + +/* Decode a Lisp list SPECIFIED_TIME that represents a time. + If SPECIFIED_TIME is nil, use the current time. + Signal an error if SPECIFIED_TIME does not represent a time. */ +static struct lisp_time +lisp_time_struct (Lisp_Object specified_time, enum timeform *pform) +{ + struct lisp_time t; + decode_lisp_time (specified_time, WARN_OBSOLETE_TIMESTAMPS, pform, &t, 0); + return t; +} + +/* Decode a Lisp list SPECIFIED_TIME that represents a time. + Discard any low-order (sub-ns) resolution. + If SPECIFIED_TIME is nil, use the current time. + Signal an error if SPECIFIED_TIME does not represent a timespec. */ +struct timespec +lisp_time_argument (Lisp_Object specified_time) +{ + struct lisp_time lt = lisp_time_struct (specified_time, 0); + struct timespec t = lisp_to_timespec (lt); + if (! timespec_valid_p (t)) + time_overflow (); + return t; +} + +/* Like lisp_time_argument, except decode only the seconds part, and + do not check the subseconds part. */ +static time_t +lisp_seconds_argument (Lisp_Object specified_time) +{ + int flags = WARN_OBSOLETE_TIMESTAMPS | DECODE_SECS_ONLY; + struct lisp_time lt; + decode_lisp_time (specified_time, flags, 0, <, 0); + struct timespec t = lisp_to_timespec (lt); + if (! timespec_valid_p (t)) + time_overflow (); + return t.tv_sec; +} + +/* Given Lisp operands A and B, add their values, and return the + result as a Lisp timestamp that is in (TICKS . HZ) form if either A + or B are in that form, (HI LO US PS) form otherwise. Subtract + instead of adding if SUBTRACT. */ +static Lisp_Object +time_arith (Lisp_Object a, Lisp_Object b, bool subtract) +{ + if (FLOATP (a) && !isfinite (XFLOAT_DATA (a))) + { + double da = XFLOAT_DATA (a); + double db = XFLOAT_DATA (Ffloat_time (b)); + return make_float (subtract ? da - db : da + db); + } + if (FLOATP (b) && !isfinite (XFLOAT_DATA (b))) + return subtract ? make_float (-XFLOAT_DATA (b)) : b; + + enum timeform aform, bform; + struct lisp_time ta = lisp_time_struct (a, &aform); + struct lisp_time tb = lisp_time_struct (b, &bform); + Lisp_Object ticks, hz; + + if (FASTER_TIMEFNS && EQ (ta.hz, tb.hz)) + { + hz = ta.hz; + if (FIXNUMP (ta.ticks) && FIXNUMP (tb.ticks)) + ticks = make_int (subtract + ? XFIXNUM (ta.ticks) - XFIXNUM (tb.ticks) + : XFIXNUM (ta.ticks) + XFIXNUM (tb.ticks)); + else + { + (subtract ? mpz_sub : mpz_add) + (mpz[0], + *bignum_integer (&mpz[0], ta.ticks), + *bignum_integer (&mpz[1], tb.ticks)); + ticks = make_integer_mpz (); + } + } + else + { + /* The plan is to decompose ta into na/da and tb into nb/db. + Start by computing da and db. */ + mpz_t *da = bignum_integer (&mpz[1], ta.hz); + mpz_t *db = bignum_integer (&mpz[2], tb.hz); + + /* The plan is to compute (na * (db/g) + nb * (da/g)) / lcm (da, db) + where g = gcd (da, db). Start by computing g. */ + mpz_t *g = &mpz[3]; + mpz_gcd (*g, *da, *db); + + /* fa = da/g, fb = db/g. */ + mpz_t *fa = &mpz[1], *fb = &mpz[3]; + mpz_tdiv_q (*fa, *da, *g); + mpz_tdiv_q (*fb, *db, *g); + + /* FIXME: Maybe omit need for extra temp by computing fa * db here? */ + + /* hz = fa * db. This is equal to lcm (da, db). */ + mpz_mul (mpz[0], *fa, *db); + hz = make_integer_mpz (); + + /* ticks = (fb * na) OPER (fa * nb), where OPER is + or -. + OP is the multiply-add or multiply-sub form of OPER. */ + mpz_t *na = bignum_integer (&mpz[0], ta.ticks); + mpz_mul (mpz[0], *fb, *na); + mpz_t *nb = bignum_integer (&mpz[3], tb.ticks); + (subtract ? mpz_submul : mpz_addmul) (mpz[0], *fa, *nb); + ticks = make_integer_mpz (); + } + + /* Return the (TICKS . HZ) form if either argument is that way, + otherwise the (HI LO US PS) form for backward compatibility. */ + return (aform == TIMEFORM_TICKS_HZ || bform == TIMEFORM_TICKS_HZ + ? Fcons (ticks, hz) + : ticks_hz_list4 (ticks, hz)); +} + +DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0, + doc: /* Return the sum of two time values A and B, as a time value. +See `format-time-string' for the various forms of a time value. +For example, nil stands for the current time. */) + (Lisp_Object a, Lisp_Object b) +{ + return time_arith (a, b, false); +} + +DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0, + doc: /* Return the difference between two time values A and B, as a time value. +You can use `float-time' to convert the difference into elapsed seconds. +See `format-time-string' for the various forms of a time value. +For example, nil stands for the current time. */) + (Lisp_Object a, Lisp_Object b) +{ + return time_arith (a, b, true); +} + +/* Return negative, 0, positive if a < b, a == b, a > b respectively. + Return positive if either a or b is a NaN; this is good enough + for the current callers. */ +static int +time_cmp (Lisp_Object a, Lisp_Object b) +{ + if ((FLOATP (a) && !isfinite (XFLOAT_DATA (a))) + || (FLOATP (b) && !isfinite (XFLOAT_DATA (b)))) + { + double da = FLOATP (a) ? XFLOAT_DATA (a) : 0; + double db = FLOATP (b) ? XFLOAT_DATA (b) : 0; + return da < db ? -1 : da != db; + } + + struct lisp_time ta = lisp_time_struct (a, 0); + + /* Compare nil to nil correctly, and other eq values while we're at it. + Compare here rather than earlier, to handle NaNs and check formats. */ + if (EQ (a, b)) + return 0; + + struct lisp_time tb = lisp_time_struct (b, 0); + mpz_t *za = bignum_integer (&mpz[0], ta.ticks); + mpz_t *zb = bignum_integer (&mpz[1], tb.ticks); + if (! (FASTER_TIMEFNS && EQ (ta.hz, tb.hz))) + { + /* This could be sped up by looking at the signs, sizes, and + number of bits of the two sides; see how GMP does mpq_cmp. + It may not be worth the trouble here, though. */ + mpz_mul (mpz[0], *za, *bignum_integer (&mpz[2], tb.hz)); + mpz_mul (mpz[1], *zb, *bignum_integer (&mpz[2], ta.hz)); + za = &mpz[0]; + zb = &mpz[1]; + } + return mpz_cmp (*za, *zb); +} + +DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0, + doc: /* Return non-nil if time value A is less than time value B. +See `format-time-string' for the various forms of a time value. +For example, nil stands for the current time. */) + (Lisp_Object a, Lisp_Object b) +{ + return time_cmp (a, b) < 0 ? Qt : Qnil; +} + +DEFUN ("time-equal-p", Ftime_equal_p, Stime_equal_p, 2, 2, 0, + doc: /* Return non-nil if A and B are equal time values. +See `format-time-string' for the various forms of a time value. */) + (Lisp_Object a, Lisp_Object b) +{ + return time_cmp (a, b) == 0 ? Qt : Qnil; +} + + +DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0, + doc: /* Return the current time, as a float number of seconds since the epoch. +If SPECIFIED-TIME is given, it is a time value to convert to float +instead of the current time. See `format-time-string' for the various +forms of a time value. + +WARNING: Since the result is floating point, it may not be exact. +If precise time stamps are required, use either `encode-time', +or (if you need time as a string) `format-time-string'. */) + (Lisp_Object specified_time) +{ + double t; + decode_lisp_time (specified_time, 0, 0, 0, &t); + return make_float (t); +} + +/* Write information into buffer S of size MAXSIZE, according to the + FORMAT of length FORMAT_LEN, using time information taken from *TP. + Use the time zone specified by TZ. + Use NS as the number of nanoseconds in the %N directive. + Return the number of bytes written, not including the terminating + '\0'. If S is NULL, nothing will be written anywhere; so to + determine how many bytes would be written, use NULL for S and + ((size_t) -1) for MAXSIZE. + + This function behaves like nstrftime, except it allows null + bytes in FORMAT and it does not support nanoseconds. */ +static size_t +emacs_nmemftime (char *s, size_t maxsize, const char *format, + size_t format_len, const struct tm *tp, timezone_t tz, int ns) +{ + size_t total = 0; + + /* Loop through all the null-terminated strings in the format + argument. Normally there's just one null-terminated string, but + there can be arbitrarily many, concatenated together, if the + format contains '\0' bytes. nstrftime stops at the first + '\0' byte so we must invoke it separately for each such string. */ + for (;;) + { + size_t len; + size_t result; + + if (s) + s[0] = '\1'; + + result = nstrftime (s, maxsize, format, tp, tz, ns); + + if (s) + { + if (result == 0 && s[0] != '\0') + return 0; + s += result + 1; + } + + maxsize -= result + 1; + total += result; + len = strlen (format); + if (len == format_len) + return total; + total++; + format += len + 1; + format_len -= len + 1; + } +} + +static Lisp_Object +format_time_string (char const *format, ptrdiff_t formatlen, + struct timespec t, Lisp_Object zone, struct tm *tmp) +{ + char buffer[4000]; + char *buf = buffer; + ptrdiff_t size = sizeof buffer; + size_t len; + int ns = t.tv_nsec; + USE_SAFE_ALLOCA; + + timezone_t tz = tzlookup (zone, false); + /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is + a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz + expects a pointer to time_t value. */ + time_t tsec = t.tv_sec; + tmp = emacs_localtime_rz (tz, &tsec, tmp); + if (! tmp) + { + int localtime_errno = errno; + xtzfree (tz); + time_error (localtime_errno); + } + synchronize_system_time_locale (); + + while (true) + { + buf[0] = '\1'; + len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns); + if ((0 < len && len < size) || (len == 0 && buf[0] == '\0')) + break; + + /* Buffer was too small, so make it bigger and try again. */ + len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns); + if (STRING_BYTES_BOUND <= len) + { + xtzfree (tz); + string_overflow (); + } + size = len + 1; + buf = SAFE_ALLOCA (size); + } + + xtzfree (tz); + AUTO_STRING_WITH_LEN (bufstring, buf, len); + Lisp_Object result = code_convert_string_norecord (bufstring, + Vlocale_coding_system, 0); + SAFE_FREE (); + return result; +} + +DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0, + doc: /* Use FORMAT-STRING to format the time value TIME. +A time value that is omitted or nil stands for the current time, +a number stands for that many seconds, an integer pair (TICKS . HZ) +stands for TICKS/HZ seconds, and an integer list (HI LO US PS) stands +for HI*2**16 + LO + US/10**6 + PS/10**12 seconds. This function +treats seconds as time since the epoch of 1970-01-01 00:00:00 UTC. + +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: + +%Y is the year, %y within the century, %C the century. +%G is the year corresponding to the ISO week, %g within the century. +%m is the numeric month. +%b and %h are the locale's abbreviated month name, %B the full name. + (%h is not supported on MS-Windows.) +%d is the day of the month, zero-padded, %e is blank-padded. +%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6. +%a is the locale's abbreviated name of the day of week, %A the full name. +%U is the week number starting on Sunday, %W starting on Monday, + %V according to ISO 8601. +%j is the day of the year. + +%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 (00-59). +%S is the second (00-59; 00-60 on platforms with leap seconds) +%s is the number of seconds since 1970-01-01 00:00:00 +0000. +%N is the nanosecond, %6N the microsecond, %3N the millisecond, etc. +%Z is the time zone abbreviation, %z is the numeric form. + +%c is the locale's date and time format. +%x is the locale's "preferred" date format. +%D is like "%m/%d/%y". +%F is the ISO 8601 date format (like "%Y-%m-%d"). + +%R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p". +%X is the locale's "preferred" time format. + +Finally, %n is a newline, %t is a tab, %% is a literal %, and +unrecognized %-sequences stand for themselves. + +Certain flags and modifiers are available with some format controls. +The flags are `_', `-', `^' and `#'. For certain characters X, +%_X is like %X, but padded with blanks; %-X is like %X, +but without padding. %^X is like %X, but with all textual +characters up-cased; %#X is like %X, but with letter-case of +all textual characters reversed. +%NX (where N stands for an integer) is like %X, +but takes up at least N (a number) positions. +The modifiers are `E' and `O'. For certain characters X, +%EX is a locale's alternative version of %X; +%OX is like %X, but uses the locale's number symbols. + +For example, to produce full ISO 8601 format, use "%FT%T%z". + +usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */) + (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone) +{ + struct timespec t = lisp_time_argument (timeval); + struct tm tm; + + CHECK_STRING (format_string); + format_string = code_convert_string_norecord (format_string, + Vlocale_coding_system, 1); + return format_time_string (SSDATA (format_string), SBYTES (format_string), + t, zone, &tm); +} + +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 TIME is the time value to convert. See +`format-time-string' for the various forms of a time value. + +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 (the UTC offset in seconds) 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 +support. MINUTE is an integer between 0 and 59. HOUR is an integer +between 0 and 23. DAY is an integer between 1 and 31. MONTH is an +integer between 1 and 12. YEAR is an integer indicating the +four-digit year. DOW is the day of week, an integer between 0 and 6, +where 0 is Sunday. DST is t if daylight saving time is in effect, +nil if it is not in effect, and -1 if daylight saving information is +not available. UTCOFF is an integer indicating the UTC offset in +seconds, i.e., the number of seconds east of Greenwich. (Note that +Common Lisp has different meanings for DOW and UTCOFF.) + +usage: (decode-time &optional TIME ZONE) */) + (Lisp_Object specified_time, Lisp_Object zone) +{ + time_t time_spec = lisp_seconds_argument (specified_time); + struct tm local_tm, gmt_tm; + timezone_t tz = tzlookup (zone, false); + struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm); + int localtime_errno = errno; + xtzfree (tz); + + if (!tm) + time_error (localtime_errno); + if (! (MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year + && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)) + time_overflow (); + + /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */ + EMACS_INT tm_year_base = TM_YEAR_BASE; + + return CALLN (Flist, + make_fixnum (local_tm.tm_sec), + make_fixnum (local_tm.tm_min), + make_fixnum (local_tm.tm_hour), + make_fixnum (local_tm.tm_mday), + make_fixnum (local_tm.tm_mon + 1), + make_fixnum (local_tm.tm_year + tm_year_base), + make_fixnum (local_tm.tm_wday), + (local_tm.tm_isdst < 0 ? make_fixnum (-1) + : local_tm.tm_isdst == 0 ? Qnil : Qt), + (HAVE_TM_GMTOFF + ? make_fixnum (tm_gmtoff (&local_tm)) + : gmtime_r (&time_spec, &gmt_tm) + ? make_fixnum (tm_diff (&local_tm, &gmt_tm)) + : Qnil)); +} + +/* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that + the result is representable as an int. 0 <= OFFSET <= TM_YEAR_BASE. */ +static int +check_tm_member (Lisp_Object obj, int offset) +{ + if (FASTER_TIMEFNS && INT_MAX <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE) + { + CHECK_FIXNUM (obj); + EMACS_INT n = XFIXNUM (obj); + int i; + if (INT_SUBTRACT_WRAPV (n, offset, &i)) + time_overflow (); + return i; + } + else + { + CHECK_INTEGER (obj); + mpz_sub_ui (mpz[0], *bignum_integer (&mpz[0], obj), offset); + intmax_t i; + if (! (mpz_to_intmax (mpz[0], &i) && INT_MIN <= i && i <= INT_MAX)) + time_overflow (); + return i; + } +} + +DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0, + doc: /* Convert optional TIME to a timestamp. +Optional FORM specifies how the returned value should be encoded. +This can act as the reverse operation of `decode-time', which see. + +If TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE) +it is a decoded time in the style of `decode-time', so that (encode-time +(decode-time ...)) works. TIME can also be a time value. +See `format-time-string' for the various forms of a time value. +For example, an omitted TIME stands for the current time. + +If FORM is a positive integer, the time is returned as a pair of +integers (TICKS . FORM), where TICKS is the number of clock ticks and FORM +is the clock frequency in ticks per second. (Currently the positive +integer should be at least 65536 if the returned value is expected to +be given to standard functions expecting Lisp timestamps.) If FORM is +t, the time is returned as (TICKS . PHZ), where PHZ is a platform dependent +clock frequency in ticks per second. If FORM is `integer', the time is +returned as an integer count of seconds. If FORM is `list', the time is +returned as an integer list (HIGH LOW USEC PSEC), where HIGH has the +most significant bits of the seconds, LOW has the least significant 16 +bits, and USEC and PSEC are the microsecond and picosecond counts. +Returned values are rounded toward minus infinity. Although an +omitted or nil FORM currently acts like `list', this is planned to +change, so callers requiring list timestamps should specify `list'. + +As an obsolescent calling convention, if this function is called with +6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR, +DAY, MONTH, and YEAR, and specify the components of a decoded time, +where DST assumed to be -1 and FORM is omitted. If there are more +than 6 arguments the *last* argument is used as ZONE and any other +extra arguments are ignored, so that (apply #\\='encode-time +(decode-time ...)) works; otherwise ZONE is assumed to be nil. + +If the input is a decoded time, ZONE is 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. + +If the input is a decoded time and ZONE specifies a time zone with +daylight-saving transitions, DST is t for daylight saving time and nil +for standard time. If DST is -1, the daylight saving flag is guessed. + +Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed; +for example, a DAY of 0 means the day preceding the given month. +Year numbers less than 100 are treated just like other year numbers. +If you want them to stand for years in this century, you must do that yourself. + +Years before 1970 are not guaranteed to work. On some systems, +year values as low as 1901 do work. + +usage: (encode-time &optional TIME FORM &rest OBSOLESCENT-ARGUMENTS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + struct tm tm; + Lisp_Object form = Qnil, zone = Qnil; + Lisp_Object a = args[0]; + tm.tm_isdst = -1; + + if (nargs <= 2) + { + if (nargs == 2) + form = args[1]; + Lisp_Object tail = a; + for (int i = 0; i < 9; i++, tail = XCDR (tail)) + if (! CONSP (tail)) + { + struct lisp_time t; + decode_lisp_time (a, 0, 0, &t, 0); + return lisp_time_form_stamp (t, form); + } + tm.tm_sec = check_tm_member (XCAR (a), 0); a = XCDR (a); + tm.tm_min = check_tm_member (XCAR (a), 0); a = XCDR (a); + tm.tm_hour = check_tm_member (XCAR (a), 0); a = XCDR (a); + tm.tm_mday = check_tm_member (XCAR (a), 0); a = XCDR (a); + tm.tm_mon = check_tm_member (XCAR (a), 1); a = XCDR (a); + tm.tm_year = check_tm_member (XCAR (a), TM_YEAR_BASE); a = XCDR (a); + a = XCDR (a); + if (SYMBOLP (XCAR (a))) + tm.tm_isdst = !NILP (XCAR (a)); + a = XCDR (a); + zone = XCAR (a); + } + else if (nargs < 6) + xsignal2 (Qwrong_number_of_arguments, Qencode_time, make_fixnum (nargs)); + else + { + if (6 < nargs) + zone = args[nargs - 1]; + tm.tm_sec = check_tm_member (a, 0); + tm.tm_min = check_tm_member (args[1], 0); + tm.tm_hour = check_tm_member (args[2], 0); + tm.tm_mday = check_tm_member (args[3], 0); + tm.tm_mon = check_tm_member (args[4], 1); + tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE); + } + + timezone_t tz = tzlookup (zone, false); + tm.tm_wday = -1; + time_t value = mktime_z (tz, &tm); + int mktime_errno = errno; + xtzfree (tz); + + if (tm.tm_wday < 0) + time_error (mktime_errno); + + return time_form_stamp (value, form); +} + +DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0, + doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00. +The time is returned as a list of integers (HIGH LOW USEC PSEC). +HIGH has the most significant bits of the seconds, while LOW has the +least significant 16 bits. USEC and PSEC are the microsecond and +picosecond counts. Use `encode-time' if you need a particular +timestamp form; for example, (encode-time nil \\='integer) returns the +current time in seconds. */) + (void) +{ + return make_lisp_time (current_timespec ()); +} + +DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, + 0, 2, 0, + doc: /* Return the current local time, as a human-readable string. +Programs can use this function to decode a time, +since the number of columns in each field is fixed +if the year is in the range 1000-9999. +The format is `Sun Sep 16 01:03:52 1973'. +However, see also the functions `decode-time' and `format-time-string' +which provide a much more powerful and general facility. + +If SPECIFIED-TIME is given, it is the time value to format instead of +the current time. See `format-time-string' for the various forms of a +time value. + +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. */) + (Lisp_Object specified_time, Lisp_Object zone) +{ + time_t value = lisp_seconds_argument (specified_time); + timezone_t tz = tzlookup (zone, false); + + /* Convert to a string in ctime format, except without the trailing + newline, and without the 4-digit year limit. Don't use asctime + or ctime, as they might dump core if the year is outside the + range -999 .. 9999. */ + struct tm tm; + struct tm *tmp = emacs_localtime_rz (tz, &value, &tm); + int localtime_errno = errno; + xtzfree (tz); + if (! tmp) + time_error (localtime_errno); + + static char const wday_name[][4] = + { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" }; + static char const mon_name[][4] = + { "Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }; + printmax_t year_base = TM_YEAR_BASE; + char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1]; + int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd, + wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday, + tm.tm_hour, tm.tm_min, tm.tm_sec, + tm.tm_year + year_base); + + return make_unibyte_string (buf, len); +} + +DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0, + doc: /* Return the offset and name for the local time zone. +This returns a list of the form (OFFSET NAME). +OFFSET is an integer number of seconds ahead of UTC (east of Greenwich). + A negative value means west of Greenwich. +NAME is a string giving the name of the time zone. +If SPECIFIED-TIME is given, the time zone offset is determined from it +instead of using the current time. The argument should be a Lisp +time value; see `format-time-string' for the various forms of a time +value. + +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 +the data it can't find. */) + (Lisp_Object specified_time, Lisp_Object zone) +{ + struct timespec value; + struct tm local_tm, gmt_tm; + Lisp_Object zone_offset, zone_name; + + zone_offset = Qnil; + value = make_timespec (lisp_seconds_argument (specified_time), 0); + zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value, + zone, &local_tm); + + /* gmtime_r expects a pointer to time_t, but tv_sec of struct + timespec on some systems (MinGW) is a 64-bit field. */ + time_t tsec = value.tv_sec; + if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm)) + { + long int offset = (HAVE_TM_GMTOFF + ? tm_gmtoff (&local_tm) + : tm_diff (&local_tm, &gmt_tm)); + zone_offset = make_fixnum (offset); + if (SCHARS (zone_name) == 0) + { + /* 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_prec, min, sec_prec, sec); + } + } + + return list2 (zone_offset, zone_name); +} + +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 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 +of `decode-time', `encode-time', or `format-time-string', pass the +function a ZONE argument. To change local time consistently +throughout Emacs, call (setenv "TZ" TZ): this changes both the +environment of the Emacs process and the variable +`process-environment', whereas `set-time-zone-rule' affects only the +former. */) + (Lisp_Object tz) +{ + tzlookup (NILP (tz) ? Qwall : tz, true); + return Qnil; +} + +/* A buffer holding a string of the form "TZ=value", intended + to be part of the environment. If TZ is supposed to be unset, + the buffer string is "tZ=". */ + static char *tzvalbuf; + +/* Get the local time zone rule. */ +char * +emacs_getenv_TZ (void) +{ + return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0; +} + +/* Set the local time zone rule to TZSTRING, which can be null to + denote wall clock time. Do not record the setting in LOCAL_TZ. + + This function is not thread-safe, in theory because putenv is not, + but mostly because of the static storage it updates. Other threads + that invoke localtime etc. may be adversely affected while this + function is executing. */ + +int +emacs_setenv_TZ (const char *tzstring) +{ + static ptrdiff_t tzvalbufsize; + ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0; + char *tzval = tzvalbuf; + bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen; + + if (new_tzvalbuf) + { + /* Do not attempt to free the old tzvalbuf, since another thread + may be using it. In practice, the first allocation is large + enough and memory does not leak. */ + tzval = xpalloc (NULL, &tzvalbufsize, + tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1); + tzvalbuf = tzval; + tzval[1] = 'Z'; + tzval[2] = '='; + } + + if (tzstring) + { + /* Modify TZVAL in place. Although this is dicey in a + multithreaded environment, we know of no portable alternative. + Calling putenv or setenv could crash some other thread. */ + tzval[0] = 'T'; + strcpy (tzval + tzeqlen, tzstring); + } + else + { + /* Turn 'TZ=whatever' into an empty environment variable 'tZ='. + Although this is also dicey, calling unsetenv here can crash Emacs. + See Bug#8705. */ + tzval[0] = 't'; + tzval[tzeqlen] = 0; + } + + +#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 + if (need_putenv) + xputenv (tzval); + + return 0; +} + +void +syms_of_timefns (void) +{ +#ifndef timespec_hz + timespec_hz = make_int (TIMESPEC_HZ); + staticpro (×pec_hz); +#endif +#ifndef trillion + trillion = make_int (1000000000000); + staticpro (&trillion); +#endif +#if (ULONG_MAX < TRILLION || !FASTER_TIMEFNS) && !defined ztrillion + mpz_init_set_ui (ztrillion, 1000000); + mpz_mul_ui (ztrillion, ztrillion, 1000000); +#endif + + DEFSYM (Qencode_time, "encode-time"); + + defsubr (&Scurrent_time); + defsubr (&Stime_add); + defsubr (&Stime_subtract); + defsubr (&Stime_less_p); + defsubr (&Stime_equal_p); + defsubr (&Sformat_time_string); + defsubr (&Sfloat_time); + defsubr (&Sdecode_time); + defsubr (&Sencode_time); + defsubr (&Scurrent_time_string); + defsubr (&Scurrent_time_zone); + defsubr (&Sset_time_zone_rule); +} diff --git a/src/tparam.h b/src/tparam.h index 5aa4ebf4cc2..6918c9e7a0f 100644 --- a/src/tparam.h +++ b/src/tparam.h @@ -30,14 +30,15 @@ int tgetnum (const char *); char *tgetstr (const char *, char **); char *tgoto (const char *, int, int); -char *tparam (const char *, char *, int, int, int, int, int); +char *tparam (const char *, char *, int, int, int, int, int) ATTRIBUTE_MALLOC; extern char PC; extern char *BC; extern char *UP; #ifdef TERMINFO -char *tigetstr(const char *); +int tigetflag (const char *); +char *tigetstr (const char *); #endif #endif /* EMACS_TPARAM_H */ diff --git a/src/undo.c b/src/undo.c index dded73a13e5..2929f792128 100644 --- a/src/undo.c +++ b/src/undo.c @@ -74,7 +74,7 @@ record_point (ptrdiff_t beg) && point_before_last_command_or_undo != beg && buffer_before_last_command_or_undo == current_buffer ) bset_undo_list (current_buffer, - Fcons (make_number (point_before_last_command_or_undo), + Fcons (make_fixnum (point_before_last_command_or_undo), BVAR (current_buffer, undo_list))); } @@ -102,11 +102,11 @@ record_insert (ptrdiff_t beg, ptrdiff_t length) Lisp_Object elt; elt = XCAR (BVAR (current_buffer, undo_list)); if (CONSP (elt) - && INTEGERP (XCAR (elt)) - && INTEGERP (XCDR (elt)) - && XINT (XCDR (elt)) == beg) + && FIXNUMP (XCAR (elt)) + && FIXNUMP (XCDR (elt)) + && XFIXNUM (XCDR (elt)) == beg) { - XSETCDR (elt, make_number (beg + length)); + XSETCDR (elt, make_fixnum (beg + length)); return; } } @@ -126,15 +126,11 @@ record_insert (ptrdiff_t beg, ptrdiff_t length) static void record_marker_adjustments (ptrdiff_t from, ptrdiff_t to) { - Lisp_Object marker; - register struct Lisp_Marker *m; - register ptrdiff_t charpos, adjustment; - - prepare_record(); + prepare_record (); - for (m = BUF_MARKERS (current_buffer); m; m = m->next) + for (struct Lisp_Marker *m = BUF_MARKERS (current_buffer); m; m = m->next) { - charpos = m->charpos; + ptrdiff_t charpos = m->charpos; eassert (charpos <= Z); if (from <= charpos && charpos <= to) @@ -146,14 +142,14 @@ record_marker_adjustments (ptrdiff_t from, ptrdiff_t to) insertion_type t markers will automatically move forward upon re-inserting the deleted text, so we have to arrange for them to move backward to the correct position. */ - adjustment = (m->insertion_type ? to : from) - charpos; + ptrdiff_t adjustment = (m->insertion_type ? to : from) - charpos; if (adjustment) { - XSETMISC (marker, m); + Lisp_Object marker = make_lisp_ptr (m, Lisp_Vectorlike); bset_undo_list (current_buffer, - Fcons (Fcons (marker, make_number (adjustment)), + Fcons (Fcons (marker, make_fixnum (adjustment)), BVAR (current_buffer, undo_list))); } } @@ -352,14 +348,14 @@ truncate_undo_list (struct buffer *b) /* If by the first boundary we have already passed undo_outer_limit, we're heading for memory full, so offer to clear out the list. */ - if (INTEGERP (Vundo_outer_limit) - && size_so_far > XINT (Vundo_outer_limit) + if (FIXNUMP (Vundo_outer_limit) + && size_so_far > XFIXNUM (Vundo_outer_limit) && !NILP (Vundo_outer_limit_function)) { Lisp_Object tem; /* Normally the function this calls is undo-outer-limit-truncate. */ - tem = call1 (Vundo_outer_limit_function, make_number (size_so_far)); + tem = call1 (Vundo_outer_limit_function, make_fixnum (size_so_far)); if (! NILP (tem)) { /* The function is responsible for making @@ -472,7 +468,7 @@ In fact, this calls the function which is the value of `undo-outer-limit-function' with one argument, the size. The text above describes the behavior of the function that variable usually specifies. */); - Vundo_outer_limit = make_number (12000000); + Vundo_outer_limit = make_fixnum (12000000); DEFVAR_LISP ("undo-outer-limit-function", Vundo_outer_limit_function, doc: /* Function to call when an undo list exceeds `undo-outer-limit'. diff --git a/src/unexcw.c b/src/unexcw.c index 8caaafcaab0..a6e30f6a21e 100644 --- a/src/unexcw.c +++ b/src/unexcw.c @@ -48,7 +48,7 @@ static exe_header_t * read_exe_header (int fd, exe_header_t * exe_header_buffer) { int i; - int ret; + int ret ATTRIBUTE_UNUSED; assert (fd >= 0); assert (exe_header_buffer != 0); @@ -111,7 +111,7 @@ fixup_executable (int fd) exe_header_t exe_header_buffer; exe_header_t *exe_header; int i; - int ret; + int ret ATTRIBUTE_UNUSED; int found_data = 0; int found_bss = 0; @@ -269,7 +269,7 @@ unexec (const char *outfile, const char *infile) int fd_in; int fd_out; int ret; - int ret2; + int ret2 ATTRIBUTE_UNUSED; infile = add_exe_suffix_if_necessary (infile, infile_buffer); outfile = add_exe_suffix_if_necessary (outfile, outfile_buffer); diff --git a/src/w16select.c b/src/w16select.c index fb8161b61fa..b935b9f4f54 100644 --- a/src/w16select.c +++ b/src/w16select.c @@ -2,6 +2,8 @@ Copyright (C) 1996-1997, 2001-2019 Free Software Foundation, Inc. +Author: Dale P. Smith <dpsm@en.com> + This file is part of GNU Emacs. GNU Emacs is free software: you can redistribute it and/or modify @@ -22,7 +24,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ "old" (character-mode) application access to Dynamic Data Exchange, menus, and the Windows clipboard. */ -/* Written by Dale P. Smith <dpsm@en.com> */ /* Adapted to DJGPP by Eli Zaretskii <eliz@gnu.org> */ #ifdef MSDOS @@ -535,7 +536,7 @@ DEFUN ("w16-set-clipboard-data", Fw16_set_clipboard_data, Sw16_set_clipboard_dat message3 (make_unibyte_string (system_error_msg, sizeof (system_error_msg) - 1)); break; } - sit_for (make_number (2), 0, 2); + sit_for (make_fixnum (2), 0, 2); } done: @@ -678,43 +679,11 @@ syms_of_win16select (void) defsubr (&Sw16_selection_exists_p); DEFVAR_LISP ("selection-coding-system", Vselection_coding_system, - doc: /* Coding system for communicating with other programs. - -For MS-Windows and MS-DOS: -When sending or receiving text via selection and clipboard, the text -is encoded or decoded by this coding system. The default value is -the current system default encoding on 9x/Me, `utf-16le-dos' -\(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS. - -For X Windows: -When sending text via selection and clipboard, if the target -data-type matches with the type of this coding system, it is used -for encoding the text. Otherwise (including the case that this -variable is nil), a proper coding system is used as below: - -data-type coding system ---------- ------------- -UTF8_STRING utf-8 -COMPOUND_TEXT compound-text-with-extensions -STRING iso-latin-1 -C_STRING no-conversion - -When receiving text, if this coding system is non-nil, it is used -for decoding regardless of the data-type. If this is nil, a -proper coding system is used according to the data-type as above. - -See also the documentation of the variable `x-select-request-type' how -to control which data-type to request for receiving text. - -The default value is nil. */); + doc: /* SKIP: real doc in select.el. */); Vselection_coding_system = intern ("iso-latin-1-dos"); DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system, - doc: /* Coding system for the next communication with other programs. -Usually, `selection-coding-system' is used for communicating with -other programs (X Windows clients or MS Windows programs). But, if this -variable is set, it is used for the next communication only. -After the communication, this variable is set to nil. */); + doc: /* SKIP: real doc in select.el. */); Vnext_selection_coding_system = Qnil; DEFSYM (QCLIPBOARD, "CLIPBOARD"); diff --git a/src/w32.c b/src/w32.c index 374011cb290..d141dbd20bb 100644 --- a/src/w32.c +++ b/src/w32.c @@ -326,6 +326,9 @@ static BOOL g_b_init_set_file_security_a; static BOOL g_b_init_set_named_security_info_w; static BOOL g_b_init_set_named_security_info_a; static BOOL g_b_init_get_adapters_info; +static BOOL g_b_init_reg_open_key_ex_w; +static BOOL g_b_init_reg_query_value_ex_w; +static BOOL g_b_init_expand_environment_strings_w; BOOL g_b_init_compare_string_w; BOOL g_b_init_debug_break_process; @@ -504,6 +507,9 @@ typedef DWORD (WINAPI *GetAdaptersInfo_Proc) ( int (WINAPI *pMultiByteToWideChar)(UINT,DWORD,LPCSTR,int,LPWSTR,int); int (WINAPI *pWideCharToMultiByte)(UINT,DWORD,LPCWSTR,int,LPSTR,int,LPCSTR,LPBOOL); DWORD multiByteToWideCharFlags; +typedef LONG (WINAPI *RegOpenKeyExW_Proc) (HKEY,LPCWSTR,DWORD,REGSAM,PHKEY); +typedef LONG (WINAPI *RegQueryValueExW_Proc) (HKEY,LPCWSTR,LPDWORD,LPDWORD,LPBYTE,LPDWORD); +typedef DWORD (WINAPI *ExpandEnvironmentStringsW_Proc) (LPCWSTR,LPWSTR,DWORD); /* ** A utility function ** */ static BOOL @@ -529,8 +535,6 @@ 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) { @@ -570,8 +574,8 @@ open_process_token (HANDLE ProcessHandle, { g_b_init_open_process_token = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Open_Process_Token = - (OpenProcessToken_Proc) GetProcAddress (hm_advapi32, "OpenProcessToken"); + s_pfn_Open_Process_Token = (OpenProcessToken_Proc) + get_proc_addr (hm_advapi32, "OpenProcessToken"); } if (s_pfn_Open_Process_Token == NULL) { @@ -602,8 +606,8 @@ get_token_information (HANDLE TokenHandle, { g_b_init_get_token_information = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Token_Information = - (GetTokenInformation_Proc) GetProcAddress (hm_advapi32, "GetTokenInformation"); + s_pfn_Get_Token_Information = (GetTokenInformation_Proc) + get_proc_addr (hm_advapi32, "GetTokenInformation"); } if (s_pfn_Get_Token_Information == NULL) { @@ -638,8 +642,8 @@ lookup_account_sid (LPCTSTR lpSystemName, { g_b_init_lookup_account_sid = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Lookup_Account_Sid = - (LookupAccountSid_Proc) GetProcAddress (hm_advapi32, LookupAccountSid_Name); + s_pfn_Lookup_Account_Sid = (LookupAccountSid_Proc) + get_proc_addr (hm_advapi32, LookupAccountSid_Name); } if (s_pfn_Lookup_Account_Sid == NULL) { @@ -671,9 +675,8 @@ get_sid_sub_authority (PSID pSid, DWORD n) { g_b_init_get_sid_sub_authority = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Sid_Sub_Authority = - (GetSidSubAuthority_Proc) GetProcAddress ( - hm_advapi32, "GetSidSubAuthority"); + s_pfn_Get_Sid_Sub_Authority = (GetSidSubAuthority_Proc) + get_proc_addr (hm_advapi32, "GetSidSubAuthority"); } if (s_pfn_Get_Sid_Sub_Authority == NULL) { @@ -696,9 +699,8 @@ get_sid_sub_authority_count (PSID pSid) { g_b_init_get_sid_sub_authority_count = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Sid_Sub_Authority_Count = - (GetSidSubAuthorityCount_Proc) GetProcAddress ( - hm_advapi32, "GetSidSubAuthorityCount"); + s_pfn_Get_Sid_Sub_Authority_Count = (GetSidSubAuthorityCount_Proc) + get_proc_addr (hm_advapi32, "GetSidSubAuthorityCount"); } if (s_pfn_Get_Sid_Sub_Authority_Count == NULL) { @@ -727,9 +729,8 @@ get_security_info (HANDLE handle, { g_b_init_get_security_info = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Security_Info = - (GetSecurityInfo_Proc) GetProcAddress ( - hm_advapi32, "GetSecurityInfo"); + s_pfn_Get_Security_Info = (GetSecurityInfo_Proc) + get_proc_addr (hm_advapi32, "GetSecurityInfo"); } if (s_pfn_Get_Security_Info == NULL) { @@ -763,9 +764,8 @@ get_file_security (const char *lpFileName, { g_b_init_get_file_security_w = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_File_SecurityW = - (GetFileSecurityW_Proc) GetProcAddress (hm_advapi32, - "GetFileSecurityW"); + s_pfn_Get_File_SecurityW = (GetFileSecurityW_Proc) + get_proc_addr (hm_advapi32, "GetFileSecurityW"); } if (s_pfn_Get_File_SecurityW == NULL) { @@ -785,9 +785,8 @@ get_file_security (const char *lpFileName, { g_b_init_get_file_security_a = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_File_SecurityA = - (GetFileSecurityA_Proc) GetProcAddress (hm_advapi32, - "GetFileSecurityA"); + s_pfn_Get_File_SecurityA = (GetFileSecurityA_Proc) + get_proc_addr (hm_advapi32, "GetFileSecurityA"); } if (s_pfn_Get_File_SecurityA == NULL) { @@ -822,9 +821,8 @@ set_file_security (const char *lpFileName, { g_b_init_set_file_security_w = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Set_File_SecurityW = - (SetFileSecurityW_Proc) GetProcAddress (hm_advapi32, - "SetFileSecurityW"); + s_pfn_Set_File_SecurityW = (SetFileSecurityW_Proc) + get_proc_addr (hm_advapi32, "SetFileSecurityW"); } if (s_pfn_Set_File_SecurityW == NULL) { @@ -843,9 +841,8 @@ set_file_security (const char *lpFileName, { g_b_init_set_file_security_a = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Set_File_SecurityA = - (SetFileSecurityA_Proc) GetProcAddress (hm_advapi32, - "SetFileSecurityA"); + s_pfn_Set_File_SecurityA = (SetFileSecurityA_Proc) + get_proc_addr (hm_advapi32, "SetFileSecurityA"); } if (s_pfn_Set_File_SecurityA == NULL) { @@ -883,9 +880,8 @@ set_named_security_info (LPCTSTR lpObjectName, { g_b_init_set_named_security_info_w = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Set_Named_Security_InfoW = - (SetNamedSecurityInfoW_Proc) GetProcAddress (hm_advapi32, - "SetNamedSecurityInfoW"); + s_pfn_Set_Named_Security_InfoW = (SetNamedSecurityInfoW_Proc) + get_proc_addr (hm_advapi32, "SetNamedSecurityInfoW"); } if (s_pfn_Set_Named_Security_InfoW == NULL) { @@ -905,9 +901,8 @@ set_named_security_info (LPCTSTR lpObjectName, { g_b_init_set_named_security_info_a = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Set_Named_Security_InfoA = - (SetNamedSecurityInfoA_Proc) GetProcAddress (hm_advapi32, - "SetNamedSecurityInfoA"); + s_pfn_Set_Named_Security_InfoA = (SetNamedSecurityInfoA_Proc) + get_proc_addr (hm_advapi32, "SetNamedSecurityInfoA"); } if (s_pfn_Set_Named_Security_InfoA == NULL) { @@ -937,9 +932,8 @@ get_security_descriptor_owner (PSECURITY_DESCRIPTOR pSecurityDescriptor, { g_b_init_get_security_descriptor_owner = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Security_Descriptor_Owner = - (GetSecurityDescriptorOwner_Proc) GetProcAddress ( - hm_advapi32, "GetSecurityDescriptorOwner"); + s_pfn_Get_Security_Descriptor_Owner = (GetSecurityDescriptorOwner_Proc) + get_proc_addr (hm_advapi32, "GetSecurityDescriptorOwner"); } if (s_pfn_Get_Security_Descriptor_Owner == NULL) { @@ -966,9 +960,8 @@ get_security_descriptor_group (PSECURITY_DESCRIPTOR pSecurityDescriptor, { g_b_init_get_security_descriptor_group = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Security_Descriptor_Group = - (GetSecurityDescriptorGroup_Proc) GetProcAddress ( - hm_advapi32, "GetSecurityDescriptorGroup"); + s_pfn_Get_Security_Descriptor_Group = (GetSecurityDescriptorGroup_Proc) + get_proc_addr (hm_advapi32, "GetSecurityDescriptorGroup"); } if (s_pfn_Get_Security_Descriptor_Group == NULL) { @@ -996,9 +989,8 @@ get_security_descriptor_dacl (PSECURITY_DESCRIPTOR pSecurityDescriptor, { g_b_init_get_security_descriptor_dacl = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Security_Descriptor_Dacl = - (GetSecurityDescriptorDacl_Proc) GetProcAddress ( - hm_advapi32, "GetSecurityDescriptorDacl"); + s_pfn_Get_Security_Descriptor_Dacl = (GetSecurityDescriptorDacl_Proc) + get_proc_addr (hm_advapi32, "GetSecurityDescriptorDacl"); } if (s_pfn_Get_Security_Descriptor_Dacl == NULL) { @@ -1023,9 +1015,8 @@ is_valid_sid (PSID sid) { g_b_init_is_valid_sid = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Is_Valid_Sid = - (IsValidSid_Proc) GetProcAddress ( - hm_advapi32, "IsValidSid"); + s_pfn_Is_Valid_Sid = (IsValidSid_Proc) + get_proc_addr (hm_advapi32, "IsValidSid"); } if (s_pfn_Is_Valid_Sid == NULL) { @@ -1047,9 +1038,8 @@ equal_sid (PSID sid1, PSID sid2) { g_b_init_equal_sid = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Equal_Sid = - (EqualSid_Proc) GetProcAddress ( - hm_advapi32, "EqualSid"); + s_pfn_Equal_Sid = (EqualSid_Proc) + get_proc_addr (hm_advapi32, "EqualSid"); } if (s_pfn_Equal_Sid == NULL) { @@ -1071,9 +1061,8 @@ get_length_sid (PSID sid) { g_b_init_get_length_sid = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Get_Length_Sid = - (GetLengthSid_Proc) GetProcAddress ( - hm_advapi32, "GetLengthSid"); + s_pfn_Get_Length_Sid = (GetLengthSid_Proc) + get_proc_addr (hm_advapi32, "GetLengthSid"); } if (s_pfn_Get_Length_Sid == NULL) { @@ -1095,9 +1084,8 @@ copy_sid (DWORD destlen, PSID dest, PSID src) { g_b_init_copy_sid = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Copy_Sid = - (CopySid_Proc) GetProcAddress ( - hm_advapi32, "CopySid"); + s_pfn_Copy_Sid = (CopySid_Proc) + get_proc_addr (hm_advapi32, "CopySid"); } if (s_pfn_Copy_Sid == NULL) { @@ -1121,9 +1109,9 @@ get_native_system_info (LPSYSTEM_INFO lpSystemInfo) if (g_b_init_get_native_system_info == 0) { g_b_init_get_native_system_info = 1; - s_pfn_Get_Native_System_Info = - (GetNativeSystemInfo_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"), - "GetNativeSystemInfo"); + s_pfn_Get_Native_System_Info = (GetNativeSystemInfo_Proc) + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "GetNativeSystemInfo"); } if (s_pfn_Get_Native_System_Info != NULL) s_pfn_Get_Native_System_Info (lpSystemInfo); @@ -1145,9 +1133,9 @@ get_system_times (LPFILETIME lpIdleTime, if (g_b_init_get_system_times == 0) { g_b_init_get_system_times = 1; - s_pfn_Get_System_times = - (GetSystemTimes_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"), - "GetSystemTimes"); + s_pfn_Get_System_times = (GetSystemTimes_Proc) + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "GetSystemTimes"); } if (s_pfn_Get_System_times == NULL) return FALSE; @@ -1175,9 +1163,9 @@ create_symbolic_link (LPCSTR lpSymlinkFilename, if (g_b_init_create_symbolic_link_w == 0) { g_b_init_create_symbolic_link_w = 1; - s_pfn_Create_Symbolic_LinkW = - (CreateSymbolicLinkW_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"), - "CreateSymbolicLinkW"); + s_pfn_Create_Symbolic_LinkW = (CreateSymbolicLinkW_Proc) + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "CreateSymbolicLinkW"); } if (s_pfn_Create_Symbolic_LinkW == NULL) { @@ -1210,9 +1198,9 @@ create_symbolic_link (LPCSTR lpSymlinkFilename, if (g_b_init_create_symbolic_link_a == 0) { g_b_init_create_symbolic_link_a = 1; - s_pfn_Create_Symbolic_LinkA = - (CreateSymbolicLinkA_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"), - "CreateSymbolicLinkA"); + s_pfn_Create_Symbolic_LinkA = (CreateSymbolicLinkA_Proc) + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "CreateSymbolicLinkA"); } if (s_pfn_Create_Symbolic_LinkA == NULL) { @@ -1255,9 +1243,9 @@ is_valid_security_descriptor (PSECURITY_DESCRIPTOR pSecurityDescriptor) if (g_b_init_is_valid_security_descriptor == 0) { g_b_init_is_valid_security_descriptor = 1; - s_pfn_Is_Valid_Security_Descriptor_Proc = - (IsValidSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"), - "IsValidSecurityDescriptor"); + s_pfn_Is_Valid_Security_Descriptor_Proc = (IsValidSecurityDescriptor_Proc) + get_proc_addr (GetModuleHandle ("Advapi32.dll"), + "IsValidSecurityDescriptor"); } if (s_pfn_Is_Valid_Security_Descriptor_Proc == NULL) { @@ -1289,12 +1277,14 @@ convert_sd_to_sddl (PSECURITY_DESCRIPTOR SecurityDescriptor, g_b_init_convert_sd_to_sddl = 1; #ifdef _UNICODE s_pfn_Convert_SD_To_SDDL = - (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"), - "ConvertSecurityDescriptorToStringSecurityDescriptorW"); + (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc) + get_proc_addr (GetModuleHandle ("Advapi32.dll"), + "ConvertSecurityDescriptorToStringSecurityDescriptorW"); #else s_pfn_Convert_SD_To_SDDL = - (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"), - "ConvertSecurityDescriptorToStringSecurityDescriptorA"); + (ConvertSecurityDescriptorToStringSecurityDescriptor_Proc) + get_proc_addr (GetModuleHandle ("Advapi32.dll"), + "ConvertSecurityDescriptorToStringSecurityDescriptorA"); #endif } if (s_pfn_Convert_SD_To_SDDL == NULL) @@ -1332,12 +1322,14 @@ convert_sddl_to_sd (LPCTSTR StringSecurityDescriptor, g_b_init_convert_sddl_to_sd = 1; #ifdef _UNICODE s_pfn_Convert_SDDL_To_SD = - (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"), - "ConvertStringSecurityDescriptorToSecurityDescriptorW"); + (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc) + get_proc_addr (GetModuleHandle ("Advapi32.dll"), + "ConvertStringSecurityDescriptorToSecurityDescriptorW"); #else s_pfn_Convert_SDDL_To_SD = - (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc)GetProcAddress (GetModuleHandle ("Advapi32.dll"), - "ConvertStringSecurityDescriptorToSecurityDescriptorA"); + (ConvertStringSecurityDescriptorToSecurityDescriptor_Proc) + get_proc_addr (GetModuleHandle ("Advapi32.dll"), + "ConvertStringSecurityDescriptorToSecurityDescriptorA"); #endif } if (s_pfn_Convert_SDDL_To_SD == NULL) @@ -1369,13 +1361,86 @@ get_adapters_info (PIP_ADAPTER_INFO pAdapterInfo, PULONG pOutBufLen) hm_iphlpapi = LoadLibrary ("Iphlpapi.dll"); if (hm_iphlpapi) s_pfn_Get_Adapters_Info = (GetAdaptersInfo_Proc) - GetProcAddress (hm_iphlpapi, "GetAdaptersInfo"); + get_proc_addr (hm_iphlpapi, "GetAdaptersInfo"); } if (s_pfn_Get_Adapters_Info == NULL) return ERROR_NOT_SUPPORTED; return s_pfn_Get_Adapters_Info (pAdapterInfo, pOutBufLen); } +static LONG WINAPI +reg_open_key_ex_w (HKEY hkey, LPCWSTR lpSubKey, DWORD ulOptions, + REGSAM samDesired, PHKEY phkResult) +{ + static RegOpenKeyExW_Proc s_pfn_Reg_Open_Key_Ex_w = NULL; + HMODULE hm_advapi32 = NULL; + + if (is_windows_9x () == TRUE) + return ERROR_NOT_SUPPORTED; + + if (g_b_init_reg_open_key_ex_w == 0) + { + g_b_init_reg_open_key_ex_w = 1; + hm_advapi32 = LoadLibrary ("Advapi32.dll"); + if (hm_advapi32) + s_pfn_Reg_Open_Key_Ex_w = (RegOpenKeyExW_Proc) + get_proc_addr (hm_advapi32, "RegOpenKeyExW"); + } + if (s_pfn_Reg_Open_Key_Ex_w == NULL) + return ERROR_NOT_SUPPORTED; + return s_pfn_Reg_Open_Key_Ex_w (hkey, lpSubKey, ulOptions, + samDesired, phkResult); +} + +static LONG WINAPI +reg_query_value_ex_w (HKEY hkey, LPCWSTR lpValueName, LPDWORD lpReserved, + LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData) +{ + static RegQueryValueExW_Proc s_pfn_Reg_Query_Value_Ex_w = NULL; + HMODULE hm_advapi32 = NULL; + + if (is_windows_9x () == TRUE) + return ERROR_NOT_SUPPORTED; + + if (g_b_init_reg_query_value_ex_w == 0) + { + g_b_init_reg_query_value_ex_w = 1; + hm_advapi32 = LoadLibrary ("Advapi32.dll"); + if (hm_advapi32) + s_pfn_Reg_Query_Value_Ex_w = (RegQueryValueExW_Proc) + get_proc_addr (hm_advapi32, "RegQueryValueExW"); + } + if (s_pfn_Reg_Query_Value_Ex_w == NULL) + return ERROR_NOT_SUPPORTED; + return s_pfn_Reg_Query_Value_Ex_w (hkey, lpValueName, lpReserved, + lpType, lpData, lpcbData); +} + +static DWORD WINAPI +expand_environment_strings_w (LPCWSTR lpSrc, LPWSTR lpDst, DWORD nSize) +{ + static ExpandEnvironmentStringsW_Proc s_pfn_Expand_Environment_Strings_w = NULL; + HMODULE hm_kernel32 = NULL; + + if (is_windows_9x () == TRUE) + return ERROR_NOT_SUPPORTED; + + if (g_b_init_expand_environment_strings_w == 0) + { + g_b_init_expand_environment_strings_w = 1; + hm_kernel32 = LoadLibrary ("Kernel32.dll"); + if (hm_kernel32) + s_pfn_Expand_Environment_Strings_w = (ExpandEnvironmentStringsW_Proc) + get_proc_addr (hm_kernel32, "ExpandEnvironmentStringsW"); + } + if (s_pfn_Expand_Environment_Strings_w == NULL) + { + errno = ENOSYS; + return FALSE; + } + return s_pfn_Expand_Environment_Strings_w (lpSrc, lpDst, nSize); +} + /* Return 1 if P is a valid pointer to an object of size SIZE. Return @@ -1706,7 +1771,40 @@ filename_from_ansi (const char *fn_in, char *fn_out) /* The directory where we started, in UTF-8. */ static char startup_dir[MAX_UTF8_PATH]; -/* Get the current working directory. */ +/* Get the current working directory. The caller must arrange for CWD + to be allocated with enough space to hold a 260-char directory name + in UTF-8. IOW, the space should be at least MAX_UTF8_PATH bytes. */ +static void +w32_get_current_directory (char *cwd) +{ + /* FIXME: Do we need to resolve possible symlinks in startup_dir? + Does it matter anywhere in Emacs? */ + if (w32_unicode_filenames) + { + wchar_t wstartup_dir[MAX_PATH]; + + if (!GetCurrentDirectoryW (MAX_PATH, wstartup_dir)) + emacs_abort (); + filename_from_utf16 (wstartup_dir, cwd); + } + else + { + char astartup_dir[MAX_PATH]; + + if (!GetCurrentDirectoryA (MAX_PATH, astartup_dir)) + emacs_abort (); + filename_from_ansi (astartup_dir, cwd); + } +} + +/* For external callers. Used by 'main' in emacs.c. */ +void +w32_init_current_directory (void) +{ + w32_get_current_directory (startup_dir); +} + +/* Return the original directory where Emacs started. */ char * getcwd (char *dir, int dirsize) { @@ -1978,7 +2076,9 @@ getpwuid (unsigned uid) struct group * getgrgid (gid_t gid) { - return &dflt_group; + if (gid == dflt_passwd.pw_gid) + return &dflt_group; + return NULL; } struct passwd * @@ -2728,7 +2828,8 @@ init_environment (char ** argv) MSIE 5. */ ShGetFolderPath_fn get_folder_path; get_folder_path = (ShGetFolderPath_fn) - GetProcAddress (GetModuleHandle ("shell32.dll"), "SHGetFolderPathA"); + get_proc_addr (GetModuleHandle ("shell32.dll"), + "SHGetFolderPathA"); if (get_folder_path != NULL) { @@ -2929,24 +3030,7 @@ init_environment (char ** argv) } /* Remember the initial working directory for getcwd. */ - /* FIXME: Do we need to resolve possible symlinks in startup_dir? - Does it matter anywhere in Emacs? */ - if (w32_unicode_filenames) - { - wchar_t wstartup_dir[MAX_PATH]; - - if (!GetCurrentDirectoryW (MAX_PATH, wstartup_dir)) - emacs_abort (); - filename_from_utf16 (wstartup_dir, startup_dir); - } - else - { - char astartup_dir[MAX_PATH]; - - if (!GetCurrentDirectoryA (MAX_PATH, astartup_dir)) - emacs_abort (); - filename_from_ansi (astartup_dir, startup_dir); - } + w32_get_current_directory (startup_dir); { static char modname[MAX_PATH]; @@ -3130,22 +3214,7 @@ GetCachedVolumeInformation (char * root_dir) /* NULL for root_dir means use root from current directory. */ if (root_dir == NULL) { - if (w32_unicode_filenames) - { - wchar_t curdirw[MAX_PATH]; - - if (GetCurrentDirectoryW (MAX_PATH, curdirw) == 0) - return NULL; - filename_from_utf16 (curdirw, default_root); - } - else - { - char curdira[MAX_PATH]; - - if (GetCurrentDirectoryA (MAX_PATH, curdira) == 0) - return NULL; - filename_from_ansi (curdira, default_root); - } + w32_get_current_directory (default_root); parse_root (default_root, (const char **)&root_dir); *root_dir = 0; root_dir = default_root; @@ -6560,8 +6629,8 @@ create_toolhelp32_snapshot (DWORD Flags, DWORD Ignored) { g_b_init_create_toolhelp32_snapshot = 1; s_pfn_Create_Toolhelp32_Snapshot = (CreateToolhelp32Snapshot_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), - "CreateToolhelp32Snapshot"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "CreateToolhelp32Snapshot"); } if (s_pfn_Create_Toolhelp32_Snapshot == NULL) { @@ -6579,8 +6648,8 @@ process32_first (HANDLE hSnapshot, LPPROCESSENTRY32 lppe) { g_b_init_process32_first = 1; s_pfn_Process32_First = (Process32First_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), - "Process32First"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "Process32First"); } if (s_pfn_Process32_First == NULL) { @@ -6598,8 +6667,8 @@ process32_next (HANDLE hSnapshot, LPPROCESSENTRY32 lppe) { g_b_init_process32_next = 1; s_pfn_Process32_Next = (Process32Next_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), - "Process32Next"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "Process32Next"); } if (s_pfn_Process32_Next == NULL) { @@ -6625,8 +6694,8 @@ open_thread_token (HANDLE ThreadHandle, { g_b_init_open_thread_token = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Open_Thread_Token = - (OpenThreadToken_Proc) GetProcAddress (hm_advapi32, "OpenThreadToken"); + s_pfn_Open_Thread_Token = (OpenThreadToken_Proc) + get_proc_addr (hm_advapi32, "OpenThreadToken"); } if (s_pfn_Open_Thread_Token == NULL) { @@ -6655,8 +6724,8 @@ impersonate_self (SECURITY_IMPERSONATION_LEVEL ImpersonationLevel) { g_b_init_impersonate_self = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Impersonate_Self = - (ImpersonateSelf_Proc) GetProcAddress (hm_advapi32, "ImpersonateSelf"); + s_pfn_Impersonate_Self = (ImpersonateSelf_Proc) + get_proc_addr (hm_advapi32, "ImpersonateSelf"); } if (s_pfn_Impersonate_Self == NULL) { @@ -6678,8 +6747,8 @@ revert_to_self (void) { g_b_init_revert_to_self = 1; hm_advapi32 = LoadLibrary ("Advapi32.dll"); - s_pfn_Revert_To_Self = - (RevertToSelf_Proc) GetProcAddress (hm_advapi32, "RevertToSelf"); + s_pfn_Revert_To_Self = (RevertToSelf_Proc) + get_proc_addr (hm_advapi32, "RevertToSelf"); } if (s_pfn_Revert_To_Self == NULL) { @@ -6705,7 +6774,7 @@ get_process_memory_info (HANDLE h_proc, hm_psapi = LoadLibrary ("Psapi.dll"); if (hm_psapi) s_pfn_Get_Process_Memory_Info = (GetProcessMemoryInfo_Proc) - GetProcAddress (hm_psapi, "GetProcessMemoryInfo"); + get_proc_addr (hm_psapi, "GetProcessMemoryInfo"); } if (s_pfn_Get_Process_Memory_Info == NULL) { @@ -6730,8 +6799,8 @@ get_process_working_set_size (HANDLE h_proc, { g_b_init_get_process_working_set_size = 1; s_pfn_Get_Process_Working_Set_Size = (GetProcessWorkingSetSize_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), - "GetProcessWorkingSetSize"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "GetProcessWorkingSetSize"); } if (s_pfn_Get_Process_Working_Set_Size == NULL) { @@ -6753,8 +6822,8 @@ global_memory_status (MEMORYSTATUS *buf) { g_b_init_global_memory_status = 1; s_pfn_Global_Memory_Status = (GlobalMemoryStatus_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), - "GlobalMemoryStatus"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "GlobalMemoryStatus"); } if (s_pfn_Global_Memory_Status == NULL) { @@ -6776,8 +6845,8 @@ global_memory_status_ex (MEMORY_STATUS_EX *buf) { g_b_init_global_memory_status_ex = 1; s_pfn_Global_Memory_Status_Ex = (GlobalMemoryStatusEx_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), - "GlobalMemoryStatusEx"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "GlobalMemoryStatusEx"); } if (s_pfn_Global_Memory_Status_Ex == NULL) { @@ -6805,7 +6874,7 @@ list_system_processes (void) res = process32_next (h_snapshot, &proc_entry)) { proc_id = proc_entry.th32ProcessID; - proclist = Fcons (make_fixnum_or_float (proc_id), proclist); + proclist = Fcons (INT_TO_INTEGER (proc_id), proclist); } CloseHandle (h_snapshot); @@ -6963,8 +7032,8 @@ system_process_attributes (Lisp_Object pid) double pcpu; BOOL result = FALSE; - CHECK_NUMBER_OR_FLOAT (pid); - proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XINT (pid); + CHECK_NUMBER (pid); + proc_id = FLOATP (pid) ? XFLOAT_DATA (pid) : XFIXNUM (pid); h_snapshot = create_toolhelp32_snapshot (TH32CS_SNAPPROCESS, 0); @@ -6993,12 +7062,12 @@ system_process_attributes (Lisp_Object pid) } attrs = Fcons (Fcons (Qcomm, decoded_cmd), attrs); attrs = Fcons (Fcons (Qppid, - make_fixnum_or_float (pe.th32ParentProcessID)), + INT_TO_INTEGER (pe.th32ParentProcessID)), attrs); - attrs = Fcons (Fcons (Qpri, make_number (pe.pcPriClassBase)), + attrs = Fcons (Fcons (Qpri, make_fixnum (pe.pcPriClassBase)), attrs); attrs = Fcons (Fcons (Qthcount, - make_fixnum_or_float (pe.cntThreads)), + INT_TO_INTEGER (pe.cntThreads)), attrs); found_proc = 1; break; @@ -7146,12 +7215,12 @@ system_process_attributes (Lisp_Object pid) CloseHandle (token); } - attrs = Fcons (Fcons (Qeuid, make_fixnum_or_float (euid)), attrs); + attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (euid)), attrs); tem = make_unibyte_string (uname, ulength); attrs = Fcons (Fcons (Quser, code_convert_string_norecord (tem, Vlocale_coding_system, 0)), attrs); - attrs = Fcons (Fcons (Qegid, make_fixnum_or_float (egid)), attrs); + attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER (egid)), attrs); tem = make_unibyte_string (gname, glength); attrs = Fcons (Fcons (Qgroup, code_convert_string_norecord (tem, Vlocale_coding_system, 0)), @@ -7182,12 +7251,12 @@ system_process_attributes (Lisp_Object pid) SIZE_T rss = mem_ex.WorkingSetSize / 1024; attrs = Fcons (Fcons (Qmajflt, - make_fixnum_or_float (mem_ex.PageFaultCount)), + INT_TO_INTEGER (mem_ex.PageFaultCount)), attrs); attrs = Fcons (Fcons (Qvsize, - make_fixnum_or_float (mem_ex.PrivateUsage / 1024)), + INT_TO_INTEGER (mem_ex.PrivateUsage / 1024)), attrs); - attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (rss)), attrs); + attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (rss)), attrs); if (totphys) attrs = Fcons (Fcons (Qpmem, make_float (100. * rss / totphys)), attrs); } @@ -7197,9 +7266,9 @@ system_process_attributes (Lisp_Object pid) SIZE_T rss = mem_ex.WorkingSetSize / 1024; attrs = Fcons (Fcons (Qmajflt, - make_fixnum_or_float (mem.PageFaultCount)), + INT_TO_INTEGER (mem.PageFaultCount)), attrs); - attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (rss)), attrs); + attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (rss)), attrs); if (totphys) attrs = Fcons (Fcons (Qpmem, make_float (100. * rss / totphys)), attrs); } @@ -7208,7 +7277,7 @@ system_process_attributes (Lisp_Object pid) { DWORD rss = maxrss / 1024; - attrs = Fcons (Fcons (Qrss, make_fixnum_or_float (maxrss / 1024)), attrs); + attrs = Fcons (Fcons (Qrss, INT_TO_INTEGER (maxrss / 1024)), attrs); if (totphys) attrs = Fcons (Fcons (Qpmem, make_float (100. * rss / totphys)), attrs); } @@ -7350,8 +7419,8 @@ init_winsock (int load_now) return TRUE; pfn_SetHandleInformation - = (void *) GetProcAddress (GetModuleHandle ("kernel32.dll"), - "SetHandleInformation"); + = (void *) get_proc_addr (GetModuleHandle ("kernel32.dll"), + "SetHandleInformation"); winsock_lib = LoadLibrary ("Ws2_32.dll"); @@ -7360,7 +7429,7 @@ init_winsock (int load_now) /* dynamically link to socket functions */ #define LOAD_PROC(fn) \ - if ((pfn_##fn = (void *) GetProcAddress (winsock_lib, #fn)) == NULL) \ + if ((pfn_##fn = (void *) get_proc_addr (winsock_lib, #fn)) == NULL) \ goto fail; LOAD_PROC (WSAStartup); @@ -7395,8 +7464,8 @@ init_winsock (int load_now) #undef LOAD_PROC /* Try loading functions not available before XP. */ - pfn_getaddrinfo = (void *) GetProcAddress (winsock_lib, "getaddrinfo"); - pfn_freeaddrinfo = (void *) GetProcAddress (winsock_lib, "freeaddrinfo"); + pfn_getaddrinfo = (void *) get_proc_addr (winsock_lib, "getaddrinfo"); + pfn_freeaddrinfo = (void *) get_proc_addr (winsock_lib, "freeaddrinfo"); /* Paranoia: these two functions should go together, so if one is absent, we cannot use the other. */ if (pfn_getaddrinfo == NULL) @@ -8391,13 +8460,14 @@ _sys_read_ahead (int fd) { rc = _read (fd, &cp->chr, sizeof (char)); - /* Give subprocess time to buffer some more output for us before - reporting that input is available; we need this because Windows 95 - connects DOS programs to pipes by making the pipe appear to be - the normal console stdout - as a result most DOS programs will - write to stdout without buffering, ie. one character at a - time. Even some W32 programs do this - "dir" in a command - shell on NT is very slow if we don't do this. */ + /* Optionally give subprocess time to buffer some more output + for us before reporting that input is available; we may need + this because Windows 9X connects DOS programs to pipes by + making the pipe appear to be the normal console stdout -- as + a result most DOS programs will write to stdout without + buffering, i.e., one character at a time. Even some W32 + programs do this -- "dir" in a command shell on NT is very + slow if we don't do this. */ if (rc > 0) { int wait = w32_pipe_read_delay; @@ -9135,7 +9205,7 @@ network_interface_get_info (Lisp_Object ifname) res); else if (strcmp (namebuf, SSDATA (ifname)) == 0) { - Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil); + Lisp_Object hwaddr = Fmake_vector (make_fixnum (6), Qnil); register struct Lisp_Vector *p = XVECTOR (hwaddr); Lisp_Object flags = Qnil; int n; @@ -9164,11 +9234,11 @@ network_interface_get_info (Lisp_Object ifname) /* Hardware address and its family. */ for (n = 0; n < adapter->AddressLength; n++) - p->contents[n] = make_number ((int) adapter->Address[n]); + p->contents[n] = make_fixnum ((int) adapter->Address[n]); /* Windows does not support AF_LINK or AF_PACKET family of addresses. Use an arbitrary family number that is identical to what GNU/Linux returns. */ - res = Fcons (Fcons (make_number (1), hwaddr), res); + res = Fcons (Fcons (make_fixnum (1), hwaddr), res); /* Network mask. */ sa.sin_family = AF_INET; @@ -9230,9 +9300,9 @@ network_interface_get_info (Lisp_Object ifname) Fcons (intern ("up"), Qnil))), Qnil); /* 772 is what 3 different GNU/Linux systems report for the loopback interface. */ - res = Fcons (Fcons (make_number (772), - Fmake_vector (make_number (6), - make_number (0))), + res = Fcons (Fcons (make_fixnum (772), + Fmake_vector (make_fixnum (6), + make_fixnum (0))), res); sa.sin_addr.s_addr = sys_inet_addr ("255.0.0.0"); res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa, @@ -9270,6 +9340,215 @@ network_interface_info (Lisp_Object ifname) } +/* Workhorse for w32-read-registry, which see. */ +Lisp_Object +w32_read_registry (HKEY rootkey, Lisp_Object lkey, Lisp_Object lname) +{ + HKEY hkey = NULL; + LONG status; + DWORD vsize, vtype; + LPBYTE pvalue; + Lisp_Object val, retval; + const char *key, *value_name = NULL; + /* The following sizes are according to size limitations + documented in MSDN. */ + wchar_t key_w[255+1]; + wchar_t value_w[16*1024+1]; + bool use_unicode = is_windows_9x () == 0; + + if (use_unicode) + { + Lisp_Object encoded_key, encoded_vname; + + /* Convert input strings to UTF-16. */ + encoded_key = code_convert_string_norecord (lkey, Qutf_16le, 1); + memcpy (key_w, SSDATA (encoded_key), SBYTES (encoded_key)); + /* wchar_t strings need to be terminated by 2 null bytes. */ + key_w [SBYTES (encoded_key)/2] = L'\0'; + encoded_vname = code_convert_string_norecord (lname, Qutf_16le, 1); + memcpy (value_w, SSDATA (encoded_vname), SBYTES (encoded_vname)); + value_w[SBYTES (encoded_vname)/2] = L'\0'; + + /* Mirror the slashes, if required. */ + for (int i = 0; i < SBYTES (encoded_key)/2; i++) + { + if (key_w[i] == L'/') + key_w[i] = L'\\'; + } + if ((status = reg_open_key_ex_w (rootkey, key_w, 0, + KEY_READ, &hkey)) == ERROR_NOT_SUPPORTED + || (status = reg_query_value_ex_w (hkey, value_w, NULL, NULL, NULL, + &vsize)) == ERROR_NOT_SUPPORTED + || status != ERROR_SUCCESS) + { + if (hkey) + RegCloseKey (hkey); + if (status != ERROR_NOT_SUPPORTED) + return Qnil; + use_unicode = 0; /* fall back to non-Unicode calls */ + } + } + if (!use_unicode) + { + /* Need to copy LKEY because we are going to modify it. */ + Lisp_Object local_lkey = Fcopy_sequence (lkey); + + /* Mirror the slashes. Note: this has to be done before + encoding, because after encoding we cannot guarantee that a + slash '/' always stands for itself, it could be part of some + multibyte sequence. */ + for (int i = 0; i < SBYTES (local_lkey); i++) + { + if (SSDATA (local_lkey)[i] == '/') + SSDATA (local_lkey)[i] = '\\'; + } + + key = SSDATA (ENCODE_SYSTEM (local_lkey)); + value_name = SSDATA (ENCODE_SYSTEM (lname)); + + if ((status = RegOpenKeyEx (rootkey, key, 0, + KEY_READ, &hkey)) != ERROR_SUCCESS + || (status = RegQueryValueEx (hkey, value_name, NULL, + NULL, NULL, &vsize)) != ERROR_SUCCESS) + { + if (hkey) + RegCloseKey (hkey); + return Qnil; + } + } + + pvalue = xzalloc (vsize); + if (use_unicode) + status = reg_query_value_ex_w (hkey, value_w, NULL, &vtype, pvalue, &vsize); + else + status = RegQueryValueEx (hkey, value_name, NULL, &vtype, pvalue, &vsize); + if (status != ERROR_SUCCESS) + { + xfree (pvalue); + RegCloseKey (hkey); + return Qnil; + } + + switch (vtype) + { + case REG_NONE: + retval = Qt; + break; + case REG_DWORD: + retval = INT_TO_INTEGER (*((DWORD *)pvalue)); + break; + case REG_QWORD: + retval = INT_TO_INTEGER (*((long long *)pvalue)); + break; + case REG_BINARY: + { + int i; + unsigned char *dbuf = (unsigned char *)pvalue; + + val = make_uninit_vector (vsize); + for (i = 0; i < vsize; i++) + ASET (val, i, make_fixnum (dbuf[i])); + + retval = val; + break; + } + case REG_SZ: + if (use_unicode) + { + /* pvalue ends with 2 null bytes, but we need only one, + and AUTO_STRING_WITH_LEN will add it. */ + if (pvalue[vsize - 1] == '\0') + vsize -= 2; + AUTO_STRING_WITH_LEN (sval, (char *)pvalue, vsize); + retval = from_unicode (sval); + } + else + { + /* Don't waste a byte on the terminating null character, + since make_unibyte_string will add one anyway. */ + if (pvalue[vsize - 1] == '\0') + vsize--; + retval = DECODE_SYSTEM (make_unibyte_string (pvalue, vsize)); + } + break; + case REG_EXPAND_SZ: + if (use_unicode) + { + wchar_t expanded_w[32*1024]; + DWORD dsize = sizeof (expanded_w) / 2; + DWORD produced = expand_environment_strings_w ((wchar_t *)pvalue, + expanded_w, + dsize); + if (produced > 0 && produced < dsize) + { + AUTO_STRING_WITH_LEN (sval, (char *)expanded_w, + produced * 2 - 2); + retval = from_unicode (sval); + } + else + { + if (pvalue[vsize - 1] == '\0') + vsize -= 2; + AUTO_STRING_WITH_LEN (sval, (char *)pvalue, vsize); + retval = from_unicode (sval); + } + } + else + { + char expanded[32*1024]; /* size limitation according to MSDN */ + DWORD produced = ExpandEnvironmentStrings ((char *)pvalue, + expanded, + sizeof (expanded)); + if (produced > 0 && produced < sizeof (expanded)) + retval = make_unibyte_string (expanded, produced - 1); + else + { + if (pvalue[vsize - 1] == '\0') + vsize--; + retval = make_unibyte_string (pvalue, vsize); + } + + retval = DECODE_SYSTEM (retval); + } + break; + case REG_MULTI_SZ: + if (use_unicode) + { + wchar_t *wp = (wchar_t *)pvalue; + + val = Qnil; + do { + size_t wslen = wcslen (wp); + AUTO_STRING_WITH_LEN (sval, (char *)wp, wslen * 2); + val = Fcons (from_unicode (sval), val); + wp += wslen + 1; + } while (*wp); + } + else + { + char *p = (char *)pvalue; + + val = Qnil; + do { + size_t slen = strlen (p); + + val = Fcons (DECODE_SYSTEM (make_unibyte_string (p, slen)), val); + p += slen + 1; + } while (*p); + } + + retval = Fnreverse (val); + break; + default: + error ("unsupported registry data type: %d", (int)vtype); + } + + xfree (pvalue); + RegCloseKey (hkey); + return retval; +} + + /* The Windows CRT functions are "optimized for speed", so they don't check for timezone and DST changes if they were last called less than 1 minute ago (see http://support.microsoft.com/kb/821231). So @@ -9604,10 +9883,10 @@ maybe_load_unicows_dll (void) pointers, and assign the correct addresses to these pointers at program startup (see emacs.c, which calls this function early on). */ - pMultiByteToWideChar = - (MultiByteToWideChar_Proc)GetProcAddress (ret, "MultiByteToWideChar"); - pWideCharToMultiByte = - (WideCharToMultiByte_Proc)GetProcAddress (ret, "WideCharToMultiByte"); + pMultiByteToWideChar = (MultiByteToWideChar_Proc) + get_proc_addr (ret, "MultiByteToWideChar"); + pWideCharToMultiByte = (WideCharToMultiByte_Proc) + get_proc_addr (ret, "WideCharToMultiByte"); multiByteToWideCharFlags = MB_ERR_INVALID_CHARS; return ret; } @@ -9658,7 +9937,7 @@ globals_of_w32 (void) HMODULE kernel32 = GetModuleHandle ("kernel32.dll"); get_process_times_fn = (GetProcessTimes_Proc) - GetProcAddress (kernel32, "GetProcessTimes"); + get_proc_addr (kernel32, "GetProcessTimes"); DEFSYM (QCloaded_from, ":loaded-from"); @@ -9700,6 +9979,9 @@ globals_of_w32 (void) g_b_init_set_named_security_info_w = 0; g_b_init_set_named_security_info_a = 0; g_b_init_get_adapters_info = 0; + g_b_init_reg_open_key_ex_w = 0; + g_b_init_reg_query_value_ex_w = 0; + g_b_init_expand_environment_strings_w = 0; g_b_init_compare_string_w = 0; g_b_init_debug_break_process = 0; num_of_processors = 0; @@ -9815,8 +10097,8 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact) tem = Fplist_get (contact, QCspeed); else tem = Fplist_get (p->childp, QCspeed); - CHECK_NUMBER (tem); - dcb.BaudRate = XINT (tem); + CHECK_FIXNUM (tem); + dcb.BaudRate = XFIXNUM (tem); childp2 = Fplist_put (childp2, QCspeed, tem); /* Configure bytesize. */ @@ -9825,12 +10107,12 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact) else tem = Fplist_get (p->childp, QCbytesize); if (NILP (tem)) - tem = make_number (8); - CHECK_NUMBER (tem); - if (XINT (tem) != 7 && XINT (tem) != 8) + tem = make_fixnum (8); + CHECK_FIXNUM (tem); + if (XFIXNUM (tem) != 7 && XFIXNUM (tem) != 8) error (":bytesize must be nil (8), 7, or 8"); - dcb.ByteSize = XINT (tem); - summary[0] = XINT (tem) + '0'; + dcb.ByteSize = XFIXNUM (tem); + summary[0] = XFIXNUM (tem) + '0'; childp2 = Fplist_put (childp2, QCbytesize, tem); /* Configure parity. */ @@ -9869,14 +10151,14 @@ serial_configure (struct Lisp_Process *p, Lisp_Object contact) else tem = Fplist_get (p->childp, QCstopbits); if (NILP (tem)) - tem = make_number (1); - CHECK_NUMBER (tem); - if (XINT (tem) != 1 && XINT (tem) != 2) + tem = make_fixnum (1); + CHECK_FIXNUM (tem); + if (XFIXNUM (tem) != 1 && XFIXNUM (tem) != 2) error (":stopbits must be nil (1 stopbit), 1, or 2"); - summary[2] = XINT (tem) + '0'; - if (XINT (tem) == 1) + summary[2] = XFIXNUM (tem) + '0'; + if (XFIXNUM (tem) == 1) dcb.StopBits = ONESTOPBIT; - else if (XINT (tem) == 2) + else if (XFIXNUM (tem) == 2) dcb.StopBits = TWOSTOPBITS; childp2 = Fplist_put (childp2, QCstopbits, tem); diff --git a/src/w32.h b/src/w32.h index 7194ca2d1c8..6faa90d3177 100644 --- a/src/w32.h +++ b/src/w32.h @@ -195,11 +195,13 @@ extern int filename_from_ansi (const char *, char *); extern int filename_to_ansi (const char *, char *); extern int filename_from_utf16 (const wchar_t *, char *); extern int filename_to_utf16 (const char *, wchar_t *); +extern Lisp_Object w32_get_internal_run_time (void); extern void w32_init_file_name_codepage (void); extern int codepage_for_filenames (CPINFO *); extern Lisp_Object ansi_encode_filename (Lisp_Object); extern int w32_copy_file (const char *, const char *, int, int, int); extern int w32_accessible_directory_p (const char *, ptrdiff_t); +extern void w32_init_current_directory (void); extern BOOL init_winsock (int load_now); extern void srandom (int); @@ -227,6 +229,8 @@ extern int w32_compare_strings (const char *, const char *, char *, int); /* Return a cryptographically secure seed for PRNG. */ extern int w32_init_random (void *, ptrdiff_t); +extern Lisp_Object w32_read_registry (HKEY, Lisp_Object, Lisp_Object); + #ifdef HAVE_GNUTLS #include <gnutls/gnutls.h> @@ -239,17 +243,4 @@ extern ssize_t emacs_gnutls_push (gnutls_transport_ptr_t p, const void* buf, size_t sz); #endif /* HAVE_GNUTLS */ -/* Definine a function that will be loaded from a DLL. */ -#define DEF_DLL_FN(type, func, args) static type (FAR CDECL *fn_##func) args - -/* Load a function from the DLL. */ -#define LOAD_DLL_FN(lib, func) \ - do \ - { \ - fn_##func = (void *) GetProcAddress (lib, #func); \ - if (!fn_##func) \ - return false; \ - } \ - while (false) - #endif /* EMACS_W32_H */ diff --git a/src/w32common.h b/src/w32common.h index ff939963032..bca5244caaa 100644 --- a/src/w32common.h +++ b/src/w32common.h @@ -50,4 +50,35 @@ extern int os_subtype; /* Cache system info, e.g., the NT page size. */ extern void cache_system_info (void); +typedef void (* VOIDFNPTR) (void); + +/* Load a function address from a DLL. Cast the result via VOIDFNPTR + to pacify -Wcast-function-type in GCC 8.1. The return value must + be cast to the correct function pointer type. */ +INLINE VOIDFNPTR get_proc_addr (HINSTANCE, LPCSTR); +INLINE VOIDFNPTR +get_proc_addr (HINSTANCE handle, LPCSTR fname) +{ + return (VOIDFNPTR) GetProcAddress (handle, fname); +} + +/* Define a function that will be loaded from a DLL. The variable + arguments should contain the argument list for the function, and + optionally be followed by function attributes. For example: + DEF_DLL_FN (void, png_longjmp, (png_structp, int) PNG_NORETURN); + */ +#define DEF_DLL_FN(type, func, ...) \ + typedef type (CDECL *W32_PFN_##func) __VA_ARGS__; \ + static W32_PFN_##func fn_##func + +/* Load a function from the DLL. */ +#define LOAD_DLL_FN(lib, func) \ + do \ + { \ + fn_##func = (W32_PFN_##func) get_proc_addr (lib, #func); \ + if (!fn_##func) \ + return false; \ + } \ + while (false) + #endif /* W32COMMON_H */ diff --git a/src/w32console.c b/src/w32console.c index cb758c1ef89..df232ecd1a1 100644 --- a/src/w32console.c +++ b/src/w32console.c @@ -506,7 +506,7 @@ w32con_set_terminal_modes (struct terminal *t) /* Initialize input mode: interrupt_input off, no flow control, allow 8 bit character input, standard quit char. */ - Fset_input_mode (Qnil, Qnil, make_number (2), Qnil); + Fset_input_mode (Qnil, Qnil, make_fixnum (2), Qnil); } /* hmmm... perhaps these let us bracket screen changes so that we can flush @@ -813,9 +813,9 @@ DEFUN ("set-screen-color", Fset_screen_color, Sset_screen_color, 2, 2, 0, Arguments should be indices between 0 and 15, see w32console.el. */) (Lisp_Object foreground, Lisp_Object background) { - char_attr_normal = XFASTINT (foreground) + (XFASTINT (background) << 4); + char_attr_normal = XFIXNAT (foreground) + (XFIXNAT (background) << 4); - Frecenter (Qnil); + Frecenter (Qnil, Qt); return Qt; } @@ -827,8 +827,8 @@ See w32console.el and `tty-defined-color-alist' for mapping of indices to colors. */) (void) { - return Fcons (make_number (char_attr_normal & 0x000f), - Fcons (make_number ((char_attr_normal >> 4) & 0x000f), Qnil)); + return Fcons (make_fixnum (char_attr_normal & 0x000f), + Fcons (make_fixnum ((char_attr_normal >> 4) & 0x000f), Qnil)); } DEFUN ("set-cursor-size", Fset_cursor_size, Sset_cursor_size, 1, 1, 0, @@ -836,7 +836,7 @@ DEFUN ("set-cursor-size", Fset_cursor_size, Sset_cursor_size, 1, 1, 0, (Lisp_Object size) { CONSOLE_CURSOR_INFO cci; - cci.dwSize = XFASTINT (size); + cci.dwSize = XFIXNAT (size); cci.bVisible = TRUE; (void) SetConsoleCursorInfo (cur_screen, &cci); diff --git a/src/w32cygwinx.c b/src/w32cygwinx.c new file mode 100644 index 00000000000..bc401239787 --- /dev/null +++ b/src/w32cygwinx.c @@ -0,0 +1,135 @@ +/* Common functions for the Microsoft Windows and Cygwin builds. + +Copyright (C) 2018 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <stdio.h> + +#include "lisp.h" +#include "w32common.h" + +static Lisp_Object ATTRIBUTE_FORMAT_PRINTF (1, 2) +format_string (char const *format, ...) +{ + va_list args; + va_start (args, format); + Lisp_Object str = vformat_string (format, args); + va_end (args); + return str; +} + +DEFUN ("w32-battery-status", Fw32_battery_status, Sw32_battery_status, 0, 0, 0, + doc: /* Get power status information from Windows system. + +The following %-sequences are provided: +%L AC line status (verbose) +%B Battery status (verbose) +%b Battery status, empty means high, `-' means low, + `!' means critical, and `+' means charging +%p Battery load percentage +%s Remaining time (to charge or discharge) in seconds +%m Remaining time (to charge or discharge) in minutes +%h Remaining time (to charge or discharge) in hours +%t Remaining time (to charge or discharge) in the form `h:min' */) + (void) +{ + Lisp_Object status = Qnil; + + SYSTEM_POWER_STATUS system_status; + if (GetSystemPowerStatus (&system_status)) + { + Lisp_Object line_status, battery_status, battery_status_symbol; + Lisp_Object load_percentage, seconds, minutes, hours, remain; + + long seconds_left = (long) system_status.BatteryLifeTime; + + if (system_status.ACLineStatus == 0) + line_status = build_string ("off-line"); + else if (system_status.ACLineStatus == 1) + line_status = build_string ("on-line"); + else + line_status = build_string ("N/A"); + + if (system_status.BatteryFlag & 128) + { + battery_status = build_string ("N/A"); + battery_status_symbol = empty_unibyte_string; + } + else if (system_status.BatteryFlag & 8) + { + battery_status = build_string ("charging"); + battery_status_symbol = build_string ("+"); + if (system_status.BatteryFullLifeTime != -1L) + seconds_left = system_status.BatteryFullLifeTime - seconds_left; + } + else if (system_status.BatteryFlag & 4) + { + battery_status = build_string ("critical"); + battery_status_symbol = build_string ("!"); + } + else if (system_status.BatteryFlag & 2) + { + battery_status = build_string ("low"); + battery_status_symbol = build_string ("-"); + } + else if (system_status.BatteryFlag & 1) + { + battery_status = build_string ("high"); + battery_status_symbol = empty_unibyte_string; + } + else + { + battery_status = build_string ("medium"); + battery_status_symbol = empty_unibyte_string; + } + + if (system_status.BatteryLifePercent > 100) + load_percentage = build_string ("N/A"); + else + load_percentage = format_string ("%d", system_status.BatteryLifePercent); + + if (seconds_left < 0) + seconds = minutes = hours = remain = build_string ("N/A"); + else + { + long m = seconds_left / 60; + seconds = format_string ("%ld", seconds_left); + minutes = format_string ("%ld", m); + hours = format_string ("%3.1f", seconds_left / 3600.0); + remain = format_string ("%ld:%02ld", m / 60, m % 60); + } + + status = listn (CONSTYPE_HEAP, 8, + Fcons (make_fixnum ('L'), line_status), + Fcons (make_fixnum ('B'), battery_status), + Fcons (make_fixnum ('b'), battery_status_symbol), + Fcons (make_fixnum ('p'), load_percentage), + Fcons (make_fixnum ('s'), seconds), + Fcons (make_fixnum ('m'), minutes), + Fcons (make_fixnum ('h'), hours), + Fcons (make_fixnum ('t'), remain)); + } + return status; +} + +void +syms_of_w32cygwinx (void) +{ + defsubr (&Sw32_battery_status); +} diff --git a/src/w32fns.c b/src/w32fns.c index f9060ce5ac1..2c239dc7b49 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -457,12 +457,12 @@ if the entry is new. */) Lisp_Object oldrgb = Qnil; Lisp_Object entry; - CHECK_NUMBER (red); - CHECK_NUMBER (green); - CHECK_NUMBER (blue); + CHECK_FIXNUM (red); + CHECK_FIXNUM (green); + CHECK_FIXNUM (blue); CHECK_STRING (name); - XSETINT (rgb, RGB (XUINT (red), XUINT (green), XUINT (blue))); + XSETINT (rgb, RGB (XUFIXNUM (red), XUFIXNUM (green), XUFIXNUM (blue))); block_input (); @@ -748,7 +748,7 @@ w32_default_color_map (void) for (i = 0; i < ARRAYELTS (w32_color_map); pc++, i++) cmap = Fcons (Fcons (build_string (pc->name), - make_number (pc->colorref)), + make_fixnum (pc->colorref)), cmap); unblock_input (); @@ -828,7 +828,7 @@ add_system_logical_colors_to_map (Lisp_Object *system_colors) 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))), + make_fixnum (RGB (r, g, b))), *system_colors); name_size = sizeof (full_name_buffer) - SYSTEM_COLOR_PREFIX_LEN; @@ -1182,7 +1182,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def, if (f) { /* Apply gamma correction. */ - w32_color_ref = XUINT (tem); + w32_color_ref = XUFIXNUM (tem); gamma_correct (f, &w32_color_ref); XSETINT (tem, w32_color_ref); } @@ -1198,7 +1198,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def, /* check if color is already mapped */ while (entry) { - if (W32_COLOR (entry->entry) == XUINT (tem)) + if (W32_COLOR (entry->entry) == XUFIXNUM (tem)) break; prev = &entry->next; entry = entry->next; @@ -1208,7 +1208,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def, { /* not already mapped, so add to list */ entry = xmalloc (sizeof (struct w32_palette_entry)); - SET_W32_COLOR (entry->entry, XUINT (tem)); + SET_W32_COLOR (entry->entry, XUFIXNUM (tem)); entry->next = NULL; *prev = entry; one_w32_display_info.num_colors++; @@ -1220,7 +1220,7 @@ w32_defined_color (struct frame *f, const char *color, XColor *color_def, /* Ensure COLORREF value is snapped to nearest color in (default) palette by simulating the PALETTERGB macro. This works whether or not the display device has a palette. */ - w32_color_ref = XUINT (tem) | 0x2000000; + w32_color_ref = XUFIXNUM (tem) | 0x2000000; color_def->pixel = w32_color_ref; color_def->red = GetRValue (w32_color_ref) * 256; @@ -1343,8 +1343,8 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (!EQ (Qnil, Vx_pointer_shape)) { - CHECK_NUMBER (Vx_pointer_shape); - cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XINT (Vx_pointer_shape)); + CHECK_FIXNUM (Vx_pointer_shape); + cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XFIXNUM (Vx_pointer_shape)); } else cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm); @@ -1352,9 +1352,9 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (!EQ (Qnil, Vx_nontext_pointer_shape)) { - CHECK_NUMBER (Vx_nontext_pointer_shape); + CHECK_FIXNUM (Vx_nontext_pointer_shape); nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), - XINT (Vx_nontext_pointer_shape)); + XFIXNUM (Vx_nontext_pointer_shape)); } else nontext_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_left_ptr); @@ -1362,9 +1362,9 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (!EQ (Qnil, Vx_hourglass_pointer_shape)) { - CHECK_NUMBER (Vx_hourglass_pointer_shape); + CHECK_FIXNUM (Vx_hourglass_pointer_shape); hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), - XINT (Vx_hourglass_pointer_shape)); + XFIXNUM (Vx_hourglass_pointer_shape)); } else hourglass_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_watch); @@ -1373,9 +1373,9 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) x_check_errors (FRAME_W32_DISPLAY (f), "bad nontext pointer cursor: %s"); if (!EQ (Qnil, Vx_mode_pointer_shape)) { - CHECK_NUMBER (Vx_mode_pointer_shape); + CHECK_FIXNUM (Vx_mode_pointer_shape); mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), - XINT (Vx_mode_pointer_shape)); + XFIXNUM (Vx_mode_pointer_shape)); } else mode_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_xterm); @@ -1383,20 +1383,20 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (!EQ (Qnil, Vx_sensitive_text_pointer_shape)) { - CHECK_NUMBER (Vx_sensitive_text_pointer_shape); + CHECK_FIXNUM (Vx_sensitive_text_pointer_shape); hand_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), - XINT (Vx_sensitive_text_pointer_shape)); + XFIXNUM (Vx_sensitive_text_pointer_shape)); } else hand_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), XC_crosshair); if (!NILP (Vx_window_horizontal_drag_shape)) { - CHECK_NUMBER (Vx_window_horizontal_drag_shape); + CHECK_FIXNUM (Vx_window_horizontal_drag_shape); horizontal_drag_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), - XINT (Vx_window_horizontal_drag_shape)); + XFIXNUM (Vx_window_horizontal_drag_shape)); } else horizontal_drag_cursor @@ -1404,10 +1404,10 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (!NILP (Vx_window_vertical_drag_shape)) { - CHECK_NUMBER (Vx_window_vertical_drag_shape); + CHECK_FIXNUM (Vx_window_vertical_drag_shape); vertical_drag_cursor = XCreateFontCursor (FRAME_W32_DISPLAY (f), - XINT (Vx_window_vertical_drag_shape)); + XFIXNUM (Vx_window_vertical_drag_shape)); } else vertical_drag_cursor @@ -1689,7 +1689,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva int border; CHECK_TYPE_RANGED_INTEGER (int, arg); - border = max (XINT (arg), 0); + border = max (XFIXNUM (arg), 0); if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { @@ -1725,7 +1725,7 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) if (!FRAME_MINIBUF_ONLY_P (f) && !FRAME_PARENT_FRAME (f)) { boolean old = FRAME_EXTERNAL_MENU_BAR (f); - boolean new = (INTEGERP (value) && XINT (value) > 0) ? true : false; + boolean new = (FIXNUMP (value) && XFIXNUM (value) > 0) ? true : false; FRAME_MENU_BAR_LINES (f) = 0; FRAME_MENU_BAR_HEIGHT (f) = 0; @@ -1757,7 +1757,7 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) x_clear_under_internal_border (f); /* Don't store anything but 1 or 0 in the parameter. */ - store_frame_param (f, Qmenu_bar_lines, make_number (new ? 1 : 0)); + store_frame_param (f, Qmenu_bar_lines, make_fixnum (new ? 1 : 0)); } } } @@ -1780,8 +1780,8 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) return; /* Use VALUE only if an integer >= 0. */ - if (INTEGERP (value) && XINT (value) >= 0) - nlines = XFASTINT (value); + if (FIXNUMP (value) && XFIXNUM (value) >= 0) + nlines = XFIXNAT (value); else nlines = 0; @@ -1805,8 +1805,8 @@ x_change_tool_bar_height (struct frame *f, int height) FRAME_TOOL_BAR_HEIGHT (f) = height; FRAME_TOOL_BAR_LINES (f) = lines; /* Store `tool-bar-lines' and `height' frame parameters. */ - store_frame_param (f, Qtool_bar_lines, make_number (lines)); - store_frame_param (f, Qheight, make_number (FRAME_LINES (f))); + store_frame_param (f, Qtool_bar_lines, make_fixnum (lines)); + store_frame_param (f, Qheight, make_fixnum (FRAME_LINES (f))); if (FRAME_W32_WINDOW (f) && FRAME_TOOL_BAR_HEIGHT (f) == 0) { @@ -2027,7 +2027,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value if (!NILP (new_value) && !FRAME_UNDECORATED (f)) { dwStyle = ((dwStyle & ~WS_THICKFRAME & ~WS_CAPTION) - | ((NUMBERP (border_width) && (XINT (border_width) > 0)) + | ((FIXNUMP (border_width) && (XFIXNUM (border_width) > 0)) ? WS_BORDER : false)); SetWindowLong (hwnd, GWL_STYLE, dwStyle); SetWindowPos (hwnd, HWND_TOP, 0, 0, 0, 0, @@ -2334,7 +2334,7 @@ w32_createwindow (struct frame *f, int *coords) if (FRAME_UNDECORATED (f)) { /* If we want a thin border, specify it here. */ - if (NUMBERP (border_width) && (XINT (border_width) > 0)) + if (FIXNUMP (border_width) && (XFIXNUM (border_width) > 0)) f->output_data.w32->dwStyle |= WS_BORDER; } else @@ -2350,7 +2350,7 @@ w32_createwindow (struct frame *f, int *coords) f->output_data.w32->dwStyle = WS_POPUP; /* If we want a thin border, specify it here. */ - if (NUMBERP (border_width) && (XINT (border_width) > 0)) + if (FIXNUMP (border_width) && (XFIXNUM (border_width) > 0)) f->output_data.w32->dwStyle |= WS_BORDER; } else @@ -2640,7 +2640,7 @@ setup_w32_kbdhook (void) if (w32_kbdhook_active) { IsDebuggerPresent_Proc is_debugger_present = (IsDebuggerPresent_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), "IsDebuggerPresent"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), "IsDebuggerPresent"); if (is_debugger_present && is_debugger_present ()) return; } @@ -2655,7 +2655,7 @@ setup_w32_kbdhook (void) (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"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), "GetConsoleWindow"); if (get_console != NULL) kbdhook.console = get_console (); @@ -3116,10 +3116,10 @@ map_keypad_keys (unsigned int virt_key, unsigned int extended) (Windows 2000 and later). */ static Lisp_Object w32_grabbed_keys; -#define HOTKEY(vk, mods) make_number (((vk) & 255) | ((mods) << 8)) -#define HOTKEY_ID(k) (XFASTINT (k) & 0xbfff) -#define HOTKEY_VK_CODE(k) (XFASTINT (k) & 255) -#define HOTKEY_MODIFIERS(k) (XFASTINT (k) >> 8) +#define HOTKEY(vk, mods) make_fixnum (((vk) & 255) | ((mods) << 8)) +#define HOTKEY_ID(k) (XFIXNAT (k) & 0xbfff) +#define HOTKEY_VK_CODE(k) (XFIXNAT (k) & 255) +#define HOTKEY_MODIFIERS(k) (XFIXNAT (k) >> 8) #define RAW_HOTKEY_ID(k) ((k) & 0xbfff) #define RAW_HOTKEY_VK_CODE(k) ((k) & 255) @@ -3140,7 +3140,7 @@ register_hot_keys (HWND hwnd) Lisp_Object key = XCAR (keylist); /* Deleted entries get set to nil. */ - if (!INTEGERP (key)) + if (!FIXNUMP (key)) continue; RegisterHotKey (hwnd, HOTKEY_ID (key), @@ -3157,7 +3157,7 @@ unregister_hot_keys (HWND hwnd) { Lisp_Object key = XCAR (keylist); - if (!INTEGERP (key)) + if (!FIXNUMP (key)) continue; UnregisterHotKey (hwnd, HOTKEY_ID (key)); @@ -4199,8 +4199,8 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) press of Space which we will ignore. */ if (GetAsyncKeyState (wParam) & 1) { - if (NUMBERP (Vw32_phantom_key_code)) - key = XUINT (Vw32_phantom_key_code) & 255; + if (FIXNUMP (Vw32_phantom_key_code)) + key = XUFIXNUM (Vw32_phantom_key_code) & 255; else key = VK_SPACE; dpyinfo->faked_key = key; @@ -4215,8 +4215,8 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) { if (GetAsyncKeyState (wParam) & 1) { - if (NUMBERP (Vw32_phantom_key_code)) - key = XUINT (Vw32_phantom_key_code) & 255; + if (FIXNUMP (Vw32_phantom_key_code)) + key = XUFIXNUM (Vw32_phantom_key_code) & 255; else key = VK_SPACE; dpyinfo->faked_key = key; @@ -5413,11 +5413,11 @@ my_create_window (struct frame * f) if (EQ (left, Qunbound)) coords[0] = CW_USEDEFAULT; else - coords[0] = XINT (left); + coords[0] = XFIXNUM (left); if (EQ (top, Qunbound)) coords[1] = CW_USEDEFAULT; else - coords[1] = XINT (top); + coords[1] = XFIXNUM (top); if (!PostThreadMessage (dwWindowsThreadId, WM_EMACS_CREATEWINDOW, (WPARAM)f, (LPARAM)coords)) @@ -5529,8 +5529,8 @@ x_icon (struct frame *f, Lisp_Object parms) icon_y = x_get_arg (dpyinfo, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER); if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound)) { - CHECK_NUMBER (icon_x); - CHECK_NUMBER (icon_y); + CHECK_FIXNUM (icon_x); + CHECK_FIXNUM (icon_y); } else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound)) error ("Both left and top icon corners of icon must be specified"); @@ -5675,15 +5675,7 @@ x_default_font_parameter (struct frame *f, Lisp_Object parms) DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, 1, 1, 0, - doc: /* Make a new window, which is called a \"frame\" in Emacs terms. -Return an Emacs frame object. -PARAMETERS is an alist of frame parameters. -If the parameters specify that the frame should not have a minibuffer, -and do not specify a specific minibuffer window to use, -then `default-minibuffer-frame' must be a frame whose minibuffer can -be shared by the new frame. - -This function is an internal primitive--use `make-frame' instead. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object parameters) { struct frame *f; @@ -5736,7 +5728,7 @@ This function is an internal primitive--use `make-frame' instead. */) if (EQ (parent, Qunbound)) parent = Qnil; else if (!NILP (parent)) - CHECK_NUMBER (parent); + CHECK_FIXNUM (parent); /* make_frame_without_minibuffer can run Lisp code and garbage collect. */ /* No need to protect DISPLAY because that's not used after passing @@ -5817,7 +5809,7 @@ This function is an internal primitive--use `make-frame' instead. */) { /* Cast to UINT_PTR shuts up compiler warnings about cast to pointer from integer of different size. */ - f->output_data.w32->parent_desc = (Window) (UINT_PTR) XFASTINT (parent); + f->output_data.w32->parent_desc = (Window) (UINT_PTR) XFIXNAT (parent); f->output_data.w32->explicit_parent = true; } else @@ -5853,7 +5845,7 @@ This function is an internal primitive--use `make-frame' instead. */) x_default_font_parameter (f, parameters); /* Default BorderWidth to 0 to match other platforms. */ - x_default_parameter (f, parameters, Qborder_width, make_number (0), + x_default_parameter (f, parameters, Qborder_width, make_fixnum (0), "borderWidth", "BorderWidth", RES_TYPE_NUMBER); /* We recognize either internalBorderWidth or internalBorder @@ -5869,11 +5861,11 @@ This function is an internal primitive--use `make-frame' instead. */) parameters); } - x_default_parameter (f, parameters, Qinternal_border_width, make_number (0), + x_default_parameter (f, parameters, Qinternal_border_width, make_fixnum (0), "internalBorderWidth", "InternalBorder", RES_TYPE_NUMBER); - x_default_parameter (f, parameters, Qright_divider_width, make_number (0), + x_default_parameter (f, parameters, Qright_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); - x_default_parameter (f, parameters, Qbottom_divider_width, make_number (0), + x_default_parameter (f, parameters, Qbottom_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); x_default_parameter (f, parameters, Qvertical_scroll_bars, Qright, "verticalScrollBars", "ScrollBars", RES_TYPE_SYMBOL); @@ -5929,11 +5921,11 @@ This function is an internal primitive--use `make-frame' instead. */) because `frame-windows-min-size' needs them. */ tem = x_get_arg (dpyinfo, parameters, Qmin_width, NULL, NULL, RES_TYPE_NUMBER); - if (NUMBERP (tem)) + if (FIXNUMP (tem)) store_frame_param (f, Qmin_width, tem); tem = x_get_arg (dpyinfo, parameters, Qmin_height, NULL, NULL, RES_TYPE_NUMBER); - if (NUMBERP (tem)) + if (FIXNUMP (tem)) store_frame_param (f, Qmin_height, tem); adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, true, @@ -5946,16 +5938,16 @@ This function is an internal primitive--use `make-frame' instead. */) { x_default_parameter (f, parameters, Qmenu_bar_lines, NILP (Vmenu_bar_mode) - ? make_number (0) : make_number (1), + ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); } else /* No menu bar for child frames. */ - store_frame_param (f, Qmenu_bar_lines, make_number (0)); + store_frame_param (f, Qmenu_bar_lines, make_fixnum (0)); x_default_parameter (f, parameters, Qtool_bar_lines, NILP (Vtool_bar_mode) - ? make_number (0) : make_number (1), + ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); x_default_parameter (f, parameters, Qbuffer_predicate, Qnil, @@ -6102,8 +6094,7 @@ x_get_focus_frame (struct frame *frame) } DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, - doc: /* Internal function called by `color-defined-p', which see. -\(Note that the Nextstep version of this function ignores FRAME.) */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object color, Lisp_Object frame) { XColor foo; @@ -6118,7 +6109,7 @@ DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, } DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, - doc: /* Internal function called by `color-values', which see. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object color, Lisp_Object frame) { XColor foo; @@ -6135,7 +6126,7 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, } DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, - doc: /* Internal function called by `display-color-p', which see. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -6148,11 +6139,7 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, 0, 1, 0, - doc: /* Return t if DISPLAY supports shades of gray. -Note that color displays do support shades of gray. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -6165,57 +6152,37 @@ If omitted or nil, that stands for the selected frame's display. */) DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, 0, 1, 0, - doc: /* Return the width in pixels of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the pixel width for all -physical monitors associated with DISPLAY. To get information for -each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); - return make_number (x_display_pixel_width (dpyinfo)); + return make_fixnum (x_display_pixel_width (dpyinfo)); } DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_height, 0, 1, 0, - doc: /* Return the height in pixels of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the pixel height for all -physical monitors associated with DISPLAY. To get information for -each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); - return make_number (x_display_pixel_height (dpyinfo)); + return make_fixnum (x_display_pixel_height (dpyinfo)); } DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, 0, 1, 0, - doc: /* Return the number of bitplanes of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); - return make_number (dpyinfo->n_planes * dpyinfo->n_cbits); + return make_fixnum (dpyinfo->n_planes * dpyinfo->n_cbits); } DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, 0, 1, 0, - doc: /* Return the number of color cells of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -6227,78 +6194,42 @@ If omitted or nil, that stands for the selected frame's display. */) * anyway. */ cap = 1 << min (dpyinfo->n_planes * dpyinfo->n_cbits, 24); - return make_number (cap); + return make_fixnum (cap); } DEFUN ("x-server-max-request-size", Fx_server_max_request_size, Sx_server_max_request_size, 0, 1, 0, - doc: /* Return the maximum request size of the server of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { - return make_number (1); + return make_fixnum (1); } DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0, - doc: /* Return the "vendor ID" string of the GUI software on TERMINAL. - -\(Labeling every distributor as a "vendor" embodies the false assumption -that operating systems cannot be developed and distributed noncommercially.) - -For GNU and Unix systems, this queries the X server software; for -MS-Windows, this queries the OS. - -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { return build_string ("Microsoft Corp."); } DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0, - doc: /* Return the version numbers of the GUI software on TERMINAL. -The value is a list of three integers specifying the version of the GUI -software in use. - -For GNU and Unix system, the first 2 numbers are the version of the X -Protocol used on TERMINAL and the 3rd number is the distributor-specific -release number. For MS-Windows, the 3 numbers report the version and -the build number of the OS. - -See also the function `x-server-vendor'. - -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { return list3i (w32_major_version, w32_minor_version, w32_build_number); } DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, - doc: /* Return the number of screens on the server of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { - return make_number (1); + return make_fixnum (1); } DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0, - doc: /* Return the height in millimeters of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the height in millimeters for -all physical monitors associated with DISPLAY. To get information -for each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -6310,18 +6241,11 @@ for each physical monitor, use `display-monitor-attributes-list'. */) / GetDeviceCaps (hdc, VERTRES)); ReleaseDC (NULL, hdc); - return make_number (x_display_pixel_height (dpyinfo) * mm_per_pixel + 0.5); + return make_fixnum (x_display_pixel_height (dpyinfo) * mm_per_pixel + 0.5); } DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, - doc: /* Return the width in millimeters of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the width in millimeters for -all physical monitors associated with TERMINAL. To get information -for each physical monitor, use `display-monitor-attributes-list'. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -6333,16 +6257,12 @@ for each physical monitor, use `display-monitor-attributes-list'. */) / GetDeviceCaps (hdc, HORZRES)); ReleaseDC (NULL, hdc); - return make_number (x_display_pixel_width (dpyinfo) * mm_per_pixel + 0.5); + return make_fixnum (x_display_pixel_width (dpyinfo) * mm_per_pixel + 0.5); } DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_store, 0, 1, 0, - doc: /* Return an indication of whether DISPLAY does backing store. -The value may be `always', `when-mapped', or `not-useful'. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { return intern ("not-useful"); @@ -6350,13 +6270,7 @@ If omitted or nil, that stands for the selected frame's display. */) DEFUN ("x-display-visual-class", Fx_display_visual_class, Sx_display_visual_class, 0, 1, 0, - doc: /* Return the visual class of DISPLAY. -The value is one of the symbols `static-gray', `gray-scale', -`static-color', `pseudo-color', `true-color', or `direct-color'. - -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -6365,7 +6279,7 @@ If omitted or nil, that stands for the selected frame's display. */) if (dpyinfo->has_palette) result = intern ("pseudo-color"); else if (dpyinfo->n_planes * dpyinfo->n_cbits == 1) - result = intern ("static-grey"); + result = intern ("static-gray"); else if (dpyinfo->n_planes * dpyinfo->n_cbits == 4) result = intern ("static-color"); else if (dpyinfo->n_planes * dpyinfo->n_cbits > 8) @@ -6376,10 +6290,7 @@ If omitted or nil, that stands for the selected frame's display. */) DEFUN ("x-display-save-under", Fx_display_save_under, Sx_display_save_under, 0, 1, 0, - doc: /* Return t if DISPLAY supports the save-under feature. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { return Qnil; @@ -6390,7 +6301,7 @@ w32_monitor_enum (HMONITOR monitor, HDC hdc, RECT *rcMonitor, LPARAM dwData) { Lisp_Object *monitor_list = (Lisp_Object *) dwData; - *monitor_list = Fcons (make_save_ptr (monitor), *monitor_list); + *monitor_list = Fcons (make_mint_ptr (monitor), *monitor_list); return TRUE; } @@ -6419,16 +6330,16 @@ w32_display_monitor_attributes_list (void) monitors = xmalloc (n_monitors * sizeof (*monitors)); for (i = 0; i < n_monitors; i++) { - monitors[i] = XSAVE_POINTER (XCAR (monitor_list), 0); + monitors[i] = xmint_pointer (XCAR (monitor_list)); monitor_list = XCDR (monitor_list); } - monitor_frames = Fmake_vector (make_number (n_monitors), Qnil); + monitor_frames = Fmake_vector (make_fixnum (n_monitors), Qnil); FOR_EACH_FRAME (rest, frame) { struct frame *f = XFRAME (frame); - if (FRAME_W32_P (f) && !EQ (frame, tip_frame)) + if (FRAME_W32_P (f) && !FRAME_TOOLTIP_P (f)) { HMONITOR monitor = monitor_from_window_fn (FRAME_W32_WINDOW (f), @@ -6515,7 +6426,7 @@ w32_display_monitor_attributes_list_fallback (struct w32_display_info *dpyinfo) { struct frame *f = XFRAME (frame); - if (FRAME_W32_P (f) && !EQ (frame, tip_frame)) + if (FRAME_W32_P (f) && !FRAME_TOOLTIP_P (f)) frames = Fcons (frame, frames); } attributes = Fcons (Fcons (Qframes, frames), attributes); @@ -6644,12 +6555,7 @@ x_display_info_for_name (Lisp_Object name) } DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, - 1, 3, 0, doc: /* Open a connection to a display server. -DISPLAY is the name of the display to connect to. -Optional second arg XRM-STRING is a string of resources in xrdb format. -If the optional third arg MUST-SUCCEED is non-nil, -terminate Emacs if we can't open the connection. -\(In the Nextstep version, the last two arguments are currently ignored.) */) + 1, 3, 0, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display, Lisp_Object xrm_string, Lisp_Object must_succeed) { char *xrm_option; @@ -6731,9 +6637,7 @@ terminate Emacs if we can't open the connection. DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0, - doc: /* Close the connection to DISPLAY's server. -For DISPLAY, specify either a frame or a display name (a string). -If DISPLAY is nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object display) { struct w32_display_info *dpyinfo = check_x_display_info (display); @@ -6751,7 +6655,7 @@ If DISPLAY is nil, that stands for the selected frame's display. */) } DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, - doc: /* Return the list of display names that Emacs has connections to. */) + doc: /* SKIP: real doc in xfns.c. */) (void) { Lisp_Object result = Qnil; @@ -6764,17 +6668,7 @@ DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, } DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0, - doc: /* If ON is non-nil, report X errors as soon as the erring request is made. -This function only has an effect on X Windows. With MS Windows, it is -defined but does nothing. - -If ON is nil, allow buffering of requests. -Turning on synchronization prohibits the Xlib routines from buffering -requests and seriously degrades performance, but makes debugging much -easier. -The optional second argument TERMINAL specifies which display to act on. -TERMINAL should be a terminal object, a frame or a display name (a string). -If TERMINAL is omitted or nil, that stands for the selected frame's display. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object on, Lisp_Object display) { return Qnil; @@ -6790,21 +6684,7 @@ If TERMINAL is omitted or nil, that stands for the selected frame's display. */ DEFUN ("x-change-window-property", Fx_change_window_property, Sx_change_window_property, 2, 6, 0, - doc: /* Change window property PROP to VALUE on the X window of FRAME. -PROP must be a string. VALUE may be a string or a list of conses, -numbers and/or strings. If an element in the list is a string, it is -converted to an atom and the value of the Atom is used. If an element -is a cons, it is converted to a 32 bit number where the car is the 16 -top bits and the cdr is the lower 16 bits. - -FRAME nil or omitted means use the selected frame. -If TYPE is given and non-nil, it is the name of the type of VALUE. -If TYPE is not given or nil, the type is STRING. -FORMAT gives the size in bits of each element if VALUE is a list. -It must be one of 8, 16 or 32. -If VALUE is a string or FORMAT is nil or not given, FORMAT defaults to 8. -If OUTER-P is non-nil, the property is changed for the outer X window of -FRAME. Default is to change on the edit X window. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object prop, Lisp_Object value, Lisp_Object frame, Lisp_Object type, Lisp_Object format, Lisp_Object outer_p) { @@ -6830,8 +6710,7 @@ FRAME. Default is to change on the edit X window. */) DEFUN ("x-delete-window-property", Fx_delete_window_property, Sx_delete_window_property, 1, 2, 0, - doc: /* Remove window property PROP from X window of FRAME. -FRAME nil or omitted means use the selected frame. Value is PROP. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object prop, Lisp_Object frame) { struct frame *f = decode_window_system_frame (frame); @@ -6852,21 +6731,7 @@ FRAME nil or omitted means use the selected frame. Value is PROP. */) DEFUN ("x-window-property", Fx_window_property, Sx_window_property, 1, 6, 0, - doc: /* Value is the value of window property PROP on FRAME. -If FRAME is nil or omitted, use the selected frame. - -On X Windows, the following optional arguments are also accepted: -If TYPE is nil or omitted, get the property as a string. -Otherwise TYPE is the name of the atom that denotes the type expected. -If SOURCE is non-nil, get the property on that window instead of from -FRAME. The number 0 denotes the root window. -If DELETE-P is non-nil, delete the property after retrieving it. -If VECTOR-RET-P is non-nil, don't return a string but a vector of values. - -On MS Windows, this function accepts but ignores those optional arguments. - -Value is nil if FRAME hasn't a property with name PROP or if PROP has -no value of TYPE (always string in the MS Windows case). */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object prop, Lisp_Object frame, Lisp_Object type, Lisp_Object source, Lisp_Object delete_p, Lisp_Object vector_ret_p) { @@ -6921,20 +6786,25 @@ no value of TYPE (always string in the MS Windows case). */) static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object, Lisp_Object, int, int, int *, int *); -/* The frame of a currently visible tooltip. */ - +/* The frame of the currently visible tooltip. */ Lisp_Object tip_frame; -/* If non-nil, a timer started that hides the last tooltip when it - fires. */ +/* The window-system window corresponding to the frame of the + currently visible tooltip. */ +Window tip_window; +/* A timer that hides or deletes the currently visible tooltip when it + fires. */ Lisp_Object tip_timer; -Window tip_window; -/* If non-nil, a vector of 3 elements containing the last args - with which x-show-tip was called. See there. */ +/* STRING argument of last `x-show-tip' call. */ +Lisp_Object tip_last_string; -Lisp_Object last_show_tip_args; +/* Normalized FRAME argument of last `x-show-tip' call. */ +Lisp_Object tip_last_frame; + +/* PARMS argument of last `x-show-tip' call. */ +Lisp_Object tip_last_parms; static void @@ -7007,6 +6877,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms) FRAME_FONTSET (f) = -1; fset_icon_name (f, Qnil); + f->tooltip = true; #ifdef GLYPH_DEBUG image_cache_refcount = @@ -7041,7 +6912,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms) that are needed to determine window geometry. */ x_default_font_parameter (f, parms); - x_default_parameter (f, parms, Qborder_width, make_number (2), + x_default_parameter (f, parms, Qborder_width, make_fixnum (2), "borderWidth", "BorderWidth", RES_TYPE_NUMBER); /* This defaults to 2 in order to match xterm. We recognize either internalBorderWidth or internalBorder (which is what xterm calls @@ -7057,7 +6928,7 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms) parms); } - x_default_parameter (f, parms, Qinternal_border_width, make_number (1), + x_default_parameter (f, parms, Qinternal_border_width, make_fixnum (1), "internalBorderWidth", "internalBorderWidth", RES_TYPE_NUMBER); /* Also do the stuff which must be set before the window exists. */ @@ -7193,8 +7064,8 @@ compute_tip_xy (struct frame *f, /* Move the tooltip window where the mouse pointer is. Resize and show it. */ - if ((!INTEGERP (left) && !INTEGERP (right)) - || (!INTEGERP (top) && !INTEGERP (bottom))) + if ((!FIXNUMP (left) && !FIXNUMP (right)) + || (!FIXNUMP (top) && !FIXNUMP (bottom))) { POINT pt; @@ -7233,40 +7104,50 @@ compute_tip_xy (struct frame *f, } } - if (INTEGERP (top)) - *root_y = XINT (top); - else if (INTEGERP (bottom)) - *root_y = XINT (bottom) - height; - else if (*root_y + XINT (dy) <= min_y) + if (FIXNUMP (top)) + *root_y = XFIXNUM (top); + else if (FIXNUMP (bottom)) + *root_y = XFIXNUM (bottom) - height; + else if (*root_y + XFIXNUM (dy) <= min_y) *root_y = min_y; /* Can happen for negative dy */ - else if (*root_y + XINT (dy) + height <= max_y) + else if (*root_y + XFIXNUM (dy) + height <= max_y) /* It fits below the pointer */ - *root_y += XINT (dy); - else if (height + XINT (dy) + min_y <= *root_y) + *root_y += XFIXNUM (dy); + else if (height + XFIXNUM (dy) + min_y <= *root_y) /* It fits above the pointer. */ - *root_y -= height + XINT (dy); + *root_y -= height + XFIXNUM (dy); else /* Put it on the top. */ *root_y = min_y; - if (INTEGERP (left)) - *root_x = XINT (left); - else if (INTEGERP (right)) - *root_x = XINT (right) - width; - else if (*root_x + XINT (dx) <= min_x) + if (FIXNUMP (left)) + *root_x = XFIXNUM (left); + else if (FIXNUMP (right)) + *root_x = XFIXNUM (right) - width; + else if (*root_x + XFIXNUM (dx) <= min_x) *root_x = 0; /* Can happen for negative dx */ - else if (*root_x + XINT (dx) + width <= max_x) + else if (*root_x + XFIXNUM (dx) + width <= max_x) /* It fits to the right of the pointer. */ - *root_x += XINT (dx); - else if (width + XINT (dx) + min_x <= *root_x) + *root_x += XFIXNUM (dx); + else if (width + XFIXNUM (dx) + min_x <= *root_x) /* It fits to the left of the pointer. */ - *root_x -= width + XINT (dx); + *root_x -= width + XFIXNUM (dx); else /* Put it left justified on the screen -- it ought to fit that way. */ *root_x = min_x; } -/* Hide tooltip. Delete its frame if DELETE is true. */ +/** + * x_hide_tip: + * + * Hide currently visible tooltip and cancel its timer. + * + * This will try to make tooltip_frame invisible (if DELETE is false) + * or delete tooltip_frame (if DELETE is true). + * + * Return Qt if the tooltip was either deleted or made invisible, Qnil + * otherwise. + */ static Lisp_Object x_hide_tip (bool delete) { @@ -7291,15 +7172,20 @@ x_hide_tip (bool delete) if (FRAMEP (tip_frame)) { - if (delete) + if (FRAME_LIVE_P (XFRAME (tip_frame))) { - delete_frame (tip_frame, Qnil); - tip_frame = Qnil; + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (XFRAME (tip_frame)); + + was_open = Qt; } else - x_make_frame_invisible (XFRAME (tip_frame)); - - was_open = Qt; + tip_frame = Qnil; } else tip_frame = Qnil; @@ -7310,36 +7196,9 @@ x_hide_tip (bool delete) 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 window displaying a string. - -This is an internal function; Lisp code should call `tooltip-show'. - -FRAME nil or omitted means use the selected frame. - -PARMS is an optional list of frame parameters which can be -used to change the tooltip's appearance. - -Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil -means use the default timeout of 5 seconds. - -If the list of frame parameters PARMS contains a `left' parameter, -display the tooltip at that x-position. If the list of frame parameters -PARMS contains no `left' but a `right' parameter, display the tooltip -right-adjusted at that x-position. Otherwise display it at the -x-position of the mouse, with offset DX added (default is 5 if DX isn't -specified). - -Likewise for the y-position: If a `top' frame parameter is specified, it -determines the position of the upper edge of the tooltip window. If a -`bottom' parameter but no `top' frame parameter is specified, it -determines the position of the lower edge of the tooltip window. -Otherwise display the tooltip window at the y-position of the mouse, -with offset DY added (default is -10). - -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) + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, + Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) { struct frame *tip_f; struct window *w; @@ -7350,42 +7209,38 @@ Text larger than the specified size is clipped. */) int old_windows_or_buffers_changed = windows_or_buffers_changed; ptrdiff_t count = SPECPDL_INDEX (); ptrdiff_t count_1; - Lisp_Object window, size; - Lisp_Object tip_buf; + Lisp_Object window, size, tip_buf; AUTO_STRING (tip, " *tip*"); specbind (Qinhibit_redisplay, Qt); CHECK_STRING (string); + + if (NILP (frame)) + frame = selected_frame; decode_window_system_frame (frame); + if (NILP (timeout)) - timeout = make_number (5); + timeout = make_fixnum (5); else - CHECK_NATNUM (timeout); + CHECK_FIXNAT (timeout); if (NILP (dx)) - dx = make_number (5); + dx = make_fixnum (5); else - CHECK_NUMBER (dx); + CHECK_FIXNUM (dx); if (NILP (dy)) - dy = make_number (-10); + dy = make_fixnum (-10); else - CHECK_NUMBER (dy); - - if (NILP (last_show_tip_args)) - last_show_tip_args = Fmake_vector (make_number (3), Qnil); + CHECK_FIXNUM (dy); 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 (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && EQ (frame, last_frame) - && !NILP (Fequal_including_properties (last_string, string)) - && !NILP (Fequal (last_parms, parms))) + && EQ (frame, tip_last_frame) + && !NILP (Fequal_including_properties (string, tip_last_string)) + && !NILP (Fequal (parms, tip_last_parms))) { /* Only DX and DY have changed. */ tip_f = XFRAME (tip_frame); @@ -7419,14 +7274,14 @@ Text larger than the specified size is clipped. */) goto start_timer; } - else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame)) + else if (tooltip_reuse_hidden_frame && EQ (frame, tip_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. */ + tip_last_parms. This may destruct tip_last_parms + which, however, will be recreated below. */ for (tail = parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); @@ -7436,7 +7291,7 @@ Text larger than the specified size is clipped. */) if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) && !EQ (parm, Qbottom)) { - last = Fassq (parm, last_parms); + last = Fassq (parm, tip_last_parms); if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) { /* We lost, delete the old tooltip. */ @@ -7444,15 +7299,17 @@ Text larger than the specified size is clipped. */) break; } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } - /* Now check if there's a parameter left in last_parms with a + /* Now check if there's a parameter left in tip_last_parms with a non-nil value. */ - for (tail = last_parms; CONSP (tail); tail = XCDR (tail)) + for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); parm = Fcar (elt); @@ -7473,9 +7330,9 @@ Text larger than the specified size is clipped. */) 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); + tip_last_frame = frame; + tip_last_string = string; + tip_last_parms = parms; /* Block input until the tip has been fully drawn, to avoid crashes when drawing tips in menus. */ @@ -7487,16 +7344,17 @@ Text larger than the specified size is clipped. */) 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); + parms = Fcons (Fcons (Qinternal_border_width, make_fixnum (3)), parms); if (NILP (Fassq (Qborder_width, parms))) - parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); + parms = Fcons (Fcons (Qborder_width, make_fixnum (1)), parms); if (NILP (Fassq (Qborder_color, parms))) - parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), 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 + /* 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))) @@ -7512,8 +7370,8 @@ Text larger than the specified size is clipped. */) tip_buf = Fget_buffer_create (tip); /* We will mark the tip window a "pseudo-window" below, and such windows cannot have display margins. */ - bset_left_margin_cols (XBUFFER (tip_buf), make_number (0)); - bset_right_margin_cols (XBUFFER (tip_buf), make_number (0)); + bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); + bset_right_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); set_window_buffer (window, tip_buf, false, false); w = XWINDOW (window); w->pseudo_window_p = true; @@ -7528,11 +7386,11 @@ Text larger than the specified size is clipped. */) w->pixel_top = 0; if (CONSP (Vx_max_tooltip_size) - && RANGED_INTEGERP (1, XCAR (Vx_max_tooltip_size), INT_MAX) - && RANGED_INTEGERP (1, XCDR (Vx_max_tooltip_size), INT_MAX)) + && RANGED_FIXNUMP (1, XCAR (Vx_max_tooltip_size), INT_MAX) + && RANGED_FIXNUMP (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)); + w->total_cols = XFIXNAT (XCAR (Vx_max_tooltip_size)); + w->total_lines = XFIXNAT (XCDR (Vx_max_tooltip_size)); } else { @@ -7562,18 +7420,18 @@ Text larger than the specified size is clipped. */) 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); + make_fixnum (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); + width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + height = XFIXNUM (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. */ { RECT rect; - int pad = (NUMBERP (Vw32_tooltip_extra_pixels) - ? max (0, XINT (Vw32_tooltip_extra_pixels)) + int pad = (FIXNUMP (Vw32_tooltip_extra_pixels) + ? max (0, XFIXNUM (Vw32_tooltip_extra_pixels)) : FRAME_COLUMN_WIDTH (tip_f)); rect.left = rect.top = 0; @@ -7617,8 +7475,7 @@ Text larger than the specified size is clipped. */) DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, - doc: /* Hide the current tooltip window, if there is any. -Value is t if tooltip was open, nil otherwise. */) + doc: /* SKIP: real doc in xfns.c. */) (void) { return x_hide_tip (!tooltip_reuse_hidden_frame); @@ -7764,18 +7621,7 @@ w32_dialog_in_progress (Lisp_Object in_progress) } DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0, - doc: /* Read file name, prompting with PROMPT in directory DIR. -Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file -selection box, if specified. If MUSTMATCH is non-nil, the returned file -or directory must exist. - -This function is only defined on NS, MS Windows, and X Windows with the -Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored. -Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories. -On Windows 7 and later, the file selection dialog "remembers" the last -directory where the user selected a file, and will open that directory -instead of DIR on subsequent invocations of this function with the same -value of DIR as in previous invocations; this is standard Windows behavior. */) + doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename, Lisp_Object mustmatch, Lisp_Object only_dir_p) { /* Filter index: 1: All Files, 2: Directories only */ @@ -8187,10 +8033,10 @@ If optional parameter FRAME is not specified, use selected frame. */) { struct frame *f = decode_window_system_frame (frame); - CHECK_NUMBER (command); + CHECK_FIXNUM (command); if (FRAME_W32_P (f)) - PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XINT (command), 0); + PostMessage (FRAME_W32_WINDOW (f), WM_SYSCOMMAND, XFIXNUM (command), 0); return Qnil; } @@ -8297,8 +8143,8 @@ a ShowWindow flag: } result = (intptr_t) ShellExecuteW (NULL, ops_w, doc_w, params_w, GUI_SDATA (current_dir), - (INTEGERP (show_flag) - ? XINT (show_flag) : SW_SHOWDEFAULT)); + (FIXNUMP (show_flag) + ? XFIXNUM (show_flag) : SW_SHOWDEFAULT)); if (result > 32) return Qt; @@ -8363,7 +8209,7 @@ a ShowWindow flag: if (c_isalpha (*p) && p[1] == ':' && IS_DIRECTORY_SEP (p[2])) document = Fsubstring_no_properties (document, - make_number (file_url_len), Qnil); + make_fixnum (file_url_len), Qnil); } /* We have a situation here. If DOCUMENT is a relative file name, but its name includes leading directories, i.e. it lives not in @@ -8373,7 +8219,7 @@ a ShowWindow flag: URL, for example. So we make it absolute only if it is an existing file; if it is a file that does not exist, tough. */ absdoc = Fexpand_file_name (document, Qnil); - /* Don't call file handlers for file-exists-p, since they might + /* Don't call file name handlers for file-exists-p, since they might attempt to access the file, which could fail or produce undesired consequences, see bug#16558 for an example. */ handler = Ffind_file_name_handler (absdoc, Qfile_exists_p); @@ -8455,7 +8301,7 @@ a ShowWindow flag: shexinfo_w.lpParameters = params_w; shexinfo_w.lpDirectory = current_dir_w; shexinfo_w.nShow = - (INTEGERP (show_flag) ? XINT (show_flag) : SW_SHOWDEFAULT); + (FIXNUMP (show_flag) ? XFIXNUM (show_flag) : SW_SHOWDEFAULT); success = ShellExecuteExW (&shexinfo_w); xfree (doc_w); } @@ -8490,7 +8336,7 @@ a ShowWindow flag: shexinfo_a.lpParameters = params_a; shexinfo_a.lpDirectory = current_dir_a; shexinfo_a.nShow = - (INTEGERP (show_flag) ? XINT (show_flag) : SW_SHOWDEFAULT); + (FIXNUMP (show_flag) ? XFIXNUM (show_flag) : SW_SHOWDEFAULT); success = ShellExecuteExA (&shexinfo_a); xfree (doc_w); xfree (doc_a); @@ -8566,14 +8412,14 @@ w32_parse_and_hook_hot_key (Lisp_Object key, int hook) if (CONSP (c) && lucid_event_type_list_p (c)) c = Fevent_convert_list (c); - if (! INTEGERP (c) && ! SYMBOLP (c)) + if (! FIXNUMP (c) && ! SYMBOLP (c)) error ("Key definition is invalid"); /* Work out the base key and the modifiers. */ if (SYMBOLP (c)) { c = parse_modifiers (c); - lisp_modifiers = XINT (Fcar (Fcdr (c))); + lisp_modifiers = XFIXNUM (Fcar (Fcdr (c))); c = Fcar (c); if (!SYMBOLP (c)) emacs_abort (); @@ -8584,11 +8430,11 @@ w32_parse_and_hook_hot_key (Lisp_Object key, int hook) else vk_code = lookup_vk_code (vkname); } - else if (INTEGERP (c)) + else if (FIXNUMP (c)) { - lisp_modifiers = XINT (c) & ~CHARACTERBITS; + lisp_modifiers = XFIXNUM (c) & ~CHARACTERBITS; /* Many ascii characters are their own virtual key code. */ - vk_code = XINT (c) & CHARACTERBITS; + vk_code = XFIXNUM (c) & CHARACTERBITS; } if (vk_code < 0 || vk_code > 255) @@ -8688,7 +8534,7 @@ any key combinations, otherwise nil. */) /* Notify input thread about new hot-key definition, so that it takes effect without needing to switch focus. */ PostThreadMessage (dwWindowsThreadId, WM_EMACS_REGISTER_HOT_KEY, - (WPARAM) XINT (key), 0); + (WPARAM) XFIXNUM (key), 0); } return key; @@ -8701,7 +8547,7 @@ DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, { Lisp_Object item; - if (!INTEGERP (key)) + if (!FIXNUMP (key)) key = w32_parse_and_hook_hot_key (key, 0); if (w32_kbdhook_active) @@ -8716,12 +8562,12 @@ DEFUN ("w32-unregister-hot-key", Fw32_unregister_hot_key, eassert (CONSP (item)); /* Pass the tail of the list as a pointer to a Lisp_Cons cell, so that it works in a --with-wide-int build as well. */ - lparam = (LPARAM) XUNTAG (item, Lisp_Cons); + lparam = (LPARAM) XUNTAG (item, Lisp_Cons, struct Lisp_Cons); /* Notify input thread about hot-key definition being removed, so that it takes effect without needing focus switch. */ if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY, - (WPARAM) XINT (XCAR (item)), lparam)) + (WPARAM) XFIXNUM (XCAR (item)), lparam)) { MSG msg; GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE); @@ -8748,7 +8594,7 @@ usage: (w32-reconstruct-hot-key ID) */) int vk_code, w32_modifiers; Lisp_Object key; - CHECK_NUMBER (hotkeyid); + CHECK_FIXNUM (hotkeyid); vk_code = HOTKEY_VK_CODE (hotkeyid); w32_modifiers = HOTKEY_MODIFIERS (hotkeyid); @@ -8756,7 +8602,7 @@ usage: (w32-reconstruct-hot-key ID) */) if (vk_code < 256 && lispy_function_keys[vk_code]) key = intern (lispy_function_keys[vk_code]); else - key = make_number (vk_code); + key = make_fixnum (vk_code); key = Fcons (key, Qnil); if (w32_modifiers & MOD_SHIFT) @@ -8796,18 +8642,18 @@ to change the state. */) return Qnil; if (!dwWindowsThreadId) - return make_number (w32_console_toggle_lock_key (vk_code, new_state)); + return make_fixnum (w32_console_toggle_lock_key (vk_code, new_state)); if (NILP (new_state)) lparam = -1; else - lparam = (XUINT (new_state)) & 1; + lparam = (XUFIXNUM (new_state)) & 1; if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY, (WPARAM) vk_code, lparam)) { MSG msg; GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE); - return make_number (msg.wParam); + return make_fixnum (msg.wParam); } return Qnil; } @@ -8941,32 +8787,32 @@ and width values are in pixels. return listn (CONSTYPE_HEAP, 10, Fcons (Qouter_position, - Fcons (make_number (left), make_number (top))), + Fcons (make_fixnum (left), make_fixnum (top))), Fcons (Qouter_size, - Fcons (make_number (right - left), - make_number (bottom - top))), + Fcons (make_fixnum (right - left), + make_fixnum (bottom - top))), Fcons (Qexternal_border_size, - Fcons (make_number (external_border_width), - make_number (external_border_height))), + Fcons (make_fixnum (external_border_width), + make_fixnum (external_border_height))), Fcons (Qtitle_bar_size, - Fcons (make_number (title_bar_width), - make_number (title_bar_height))), + Fcons (make_fixnum (title_bar_width), + make_fixnum (title_bar_height))), Fcons (Qmenu_bar_external, Qt), Fcons (Qmenu_bar_size, - Fcons (make_number + Fcons (make_fixnum (menu_bar.rcBar.right - menu_bar.rcBar.left), - make_number (menu_bar_height))), + make_fixnum (menu_bar_height))), Fcons (Qtool_bar_external, Qnil), Fcons (Qtool_bar_position, tool_bar_height ? Qtop : Qnil), Fcons (Qtool_bar_size, - Fcons (make_number + Fcons (make_fixnum (tool_bar_height ? (right - left - 2 * external_border_width - 2 * internal_border_width) : 0), - make_number (tool_bar_height))), + make_fixnum (tool_bar_height))), Fcons (Qinternal_border_width, - make_number (internal_border_width))); + make_fixnum (internal_border_width))); } DEFUN ("w32-frame-edges", Fw32_frame_edges, Sw32_frame_edges, 0, 2, 0, @@ -9003,10 +8849,10 @@ menu bar or tool bar of FRAME. */) unblock_input (); if (success) - return list4 (make_number (rectangle.left), - make_number (rectangle.top), - make_number (rectangle.right), - make_number (rectangle.bottom)); + return list4 (make_fixnum (rectangle.left), + make_fixnum (rectangle.top), + make_fixnum (rectangle.right), + make_fixnum (rectangle.bottom)); else return Qnil; } @@ -9045,16 +8891,16 @@ menu bar or tool bar of FRAME. */) { int internal_border_width = FRAME_INTERNAL_BORDER_WIDTH (f); - return list4 (make_number (left + internal_border_width), - make_number (top + return list4 (make_fixnum (left + internal_border_width), + make_fixnum (top + FRAME_TOOL_BAR_HEIGHT (f) + internal_border_width), - make_number (right - internal_border_width), - make_number (bottom - internal_border_width)); + make_fixnum (right - internal_border_width), + make_fixnum (bottom - internal_border_width)); } else - return list4 (make_number (left), make_number (top), - make_number (right), make_number (bottom)); + return list4 (make_fixnum (left), make_fixnum (top), + make_fixnum (right), make_fixnum (bottom)); } } @@ -9202,7 +9048,7 @@ selected frame's display. */) GetCursorPos (&pt); unblock_input (); - return Fcons (make_number (pt.x), make_number (pt.y)); + return Fcons (make_fixnum (pt.x), make_fixnum (pt.y)); } DEFUN ("w32-set-mouse-absolute-pixel-position", Fw32_set_mouse_absolute_pixel_position, @@ -9225,7 +9071,7 @@ The coordinates X and Y are interpreted in pixels relative to a position if (os_subtype == OS_NT && w32_major_version + w32_minor_version >= 6) ret = SystemParametersInfo (SPI_GETMOUSETRAILS, 0, &trail_num, 0); - SetCursorPos (XINT (x), XINT (y)); + SetCursorPos (XFIXNUM (x), XFIXNUM (y)); if (ret) SystemParametersInfo (SPI_SETMOUSETRAILS, trail_num, NULL, 0); unblock_input (); @@ -9233,115 +9079,6 @@ The coordinates X and Y are interpreted in pixels relative to a position return Qnil; } -DEFUN ("w32-battery-status", Fw32_battery_status, Sw32_battery_status, 0, 0, 0, - doc: /* Get power status information from Windows system. - -The following %-sequences are provided: -%L AC line status (verbose) -%B Battery status (verbose) -%b Battery status, empty means high, `-' means low, - `!' means critical, and `+' means charging -%p Battery load percentage -%s Remaining time (to charge or discharge) in seconds -%m Remaining time (to charge or discharge) in minutes -%h Remaining time (to charge or discharge) in hours -%t Remaining time (to charge or discharge) in the form `h:min' */) - (void) -{ - Lisp_Object status = Qnil; - - SYSTEM_POWER_STATUS system_status; - if (GetSystemPowerStatus (&system_status)) - { - Lisp_Object line_status, battery_status, battery_status_symbol; - Lisp_Object load_percentage, seconds, minutes, hours, remain; - - long seconds_left = (long) system_status.BatteryLifeTime; - - if (system_status.ACLineStatus == 0) - line_status = build_string ("off-line"); - else if (system_status.ACLineStatus == 1) - line_status = build_string ("on-line"); - else - line_status = build_string ("N/A"); - - if (system_status.BatteryFlag & 128) - { - battery_status = build_string ("N/A"); - battery_status_symbol = empty_unibyte_string; - } - else if (system_status.BatteryFlag & 8) - { - battery_status = build_string ("charging"); - battery_status_symbol = build_string ("+"); - if (system_status.BatteryFullLifeTime != -1L) - seconds_left = system_status.BatteryFullLifeTime - seconds_left; - } - else if (system_status.BatteryFlag & 4) - { - battery_status = build_string ("critical"); - battery_status_symbol = build_string ("!"); - } - else if (system_status.BatteryFlag & 2) - { - battery_status = build_string ("low"); - battery_status_symbol = build_string ("-"); - } - else if (system_status.BatteryFlag & 1) - { - battery_status = build_string ("high"); - battery_status_symbol = empty_unibyte_string; - } - else - { - battery_status = build_string ("medium"); - battery_status_symbol = empty_unibyte_string; - } - - if (system_status.BatteryLifePercent > 100) - load_percentage = build_string ("N/A"); - else - { - char buffer[16]; - snprintf (buffer, 16, "%d", system_status.BatteryLifePercent); - load_percentage = build_string (buffer); - } - - if (seconds_left < 0) - seconds = minutes = hours = remain = build_string ("N/A"); - else - { - long m; - double h; - char buffer[16]; - snprintf (buffer, 16, "%ld", seconds_left); - seconds = build_string (buffer); - - m = seconds_left / 60; - snprintf (buffer, 16, "%ld", m); - minutes = build_string (buffer); - - h = seconds_left / 3600.0; - snprintf (buffer, 16, "%3.1f", h); - hours = build_string (buffer); - - snprintf (buffer, 16, "%ld:%02ld", m / 60, m % 60); - remain = build_string (buffer); - } - - status = listn (CONSTYPE_HEAP, 8, - Fcons (make_number ('L'), line_status), - Fcons (make_number ('B'), battery_status), - Fcons (make_number ('b'), battery_status_symbol), - Fcons (make_number ('p'), load_percentage), - Fcons (make_number ('s'), seconds), - Fcons (make_number ('m'), minutes), - Fcons (make_number ('h'), hours), - Fcons (make_number ('t'), remain)); - } - return status; -} - #ifdef WINDOWSNT typedef BOOL (WINAPI *GetDiskFreeSpaceExW_Proc) @@ -9350,11 +9087,7 @@ typedef BOOL (WINAPI *GetDiskFreeSpaceExA_Proc) (LPCSTR, PULARGE_INTEGER, PULARGE_INTEGER, PULARGE_INTEGER); DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0, - doc: /* Return storage information about the file system FILENAME is on. -Value is a list of floats (TOTAL FREE AVAIL), where TOTAL is the total -storage of the file system, FREE is the free storage, and AVAIL is the -storage available to a non-superuser. All 3 numbers are in bytes. -If the underlying system call fails, value is nil. */) + doc: /* SKIP: Real doc in fileio.c. */) (Lisp_Object filename) { Lisp_Object encoded, value; @@ -9363,6 +9096,17 @@ If the underlying system call fails, value is nil. */) filename = Fexpand_file_name (filename, Qnil); encoded = ENCODE_FILE (filename); + /* If the file name has special constructs in it, + call the corresponding file name handler. */ + Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info); + if (!NILP (handler)) + { + value = call2 (handler, Qfile_system_info, encoded); + if (CONSP (value) || NILP (value)) + return value; + error ("Invalid handler in `file-name-handler-alist'"); + } + value = Qnil; /* Determining the required information on Windows turns out, sadly, @@ -9373,9 +9117,9 @@ If the underlying system call fails, value is nil. */) { HMODULE hKernel = GetModuleHandle ("kernel32"); GetDiskFreeSpaceExW_Proc pfn_GetDiskFreeSpaceExW = - (GetDiskFreeSpaceExW_Proc) GetProcAddress (hKernel, "GetDiskFreeSpaceExW"); + (GetDiskFreeSpaceExW_Proc) get_proc_addr (hKernel, "GetDiskFreeSpaceExW"); GetDiskFreeSpaceExA_Proc pfn_GetDiskFreeSpaceExA = - (GetDiskFreeSpaceExA_Proc) GetProcAddress (hKernel, "GetDiskFreeSpaceExA"); + (GetDiskFreeSpaceExA_Proc) get_proc_addr (hKernel, "GetDiskFreeSpaceExA"); bool have_pfn_GetDiskFreeSpaceEx = ((w32_unicode_filenames && pfn_GetDiskFreeSpaceExW) || (!w32_unicode_filenames && pfn_GetDiskFreeSpaceExA)); @@ -9687,8 +9431,8 @@ w32_console_toggle_lock_key (int vk_code, Lisp_Object new_state) int cur_state = (GetKeyState (vk_code) & 1); if (NILP (new_state) - || (NUMBERP (new_state) - && ((XUINT (new_state)) & 1) != cur_state)) + || (FIXNUMP (new_state) + && ((XUFIXNUM (new_state)) & 1) != cur_state)) { #ifdef WINDOWSNT faked_key = vk_code; @@ -9950,8 +9694,8 @@ get_dll_version (const char *dll_name) if (hdll) { - DLLGETVERSIONPROC pDllGetVersion - = (DLLGETVERSIONPROC) GetProcAddress (hdll, "DllGetVersion"); + DLLGETVERSIONPROC pDllGetVersion = (DLLGETVERSIONPROC) + get_proc_addr (hdll, "DllGetVersion"); if (pDllGetVersion) { @@ -10315,7 +10059,7 @@ usage: (w32-notification-notify &rest PARAMS) */) /* Do it! */ retval = add_tray_notification (f, icon, tip, severity, timeout, title, msg); - return (retval < 0 ? Qnil : make_number (retval)); + return (retval < 0 ? Qnil : make_fixnum (retval)); } DEFUN ("w32-notification-close", @@ -10326,8 +10070,8 @@ DEFUN ("w32-notification-close", { struct frame *f = SELECTED_FRAME (); - if (INTEGERP (id)) - delete_tray_notification (f, XINT (id)); + if (FIXNUMP (id)) + delete_tray_notification (f, XFIXNUM (id)); return Qnil; } @@ -10335,6 +10079,72 @@ DEFUN ("w32-notification-close", #endif /* WINDOWSNT && !HAVE_DBUS */ +#ifdef WINDOWSNT +/*********************************************************************** + Reading Registry + ***********************************************************************/ +DEFUN ("w32-read-registry", + Fw32_read_registry, Sw32_read_registry, + 3, 3, 0, + doc: /* Return the value stored in MS-Windows Registry under ROOT/KEY/NAME. + +ROOT is a symbol, one of `HKCR', `HKCU', `HKLM', `HKU', or `HKCC'. +It can also be nil, which means try `HKCU', and if that fails, try `HKLM'. + +KEY and NAME must be strings, and NAME must not include slashes. +KEY can use either forward- or back-slashes. + +If the the named KEY or its subkey called NAME don't exist, or cannot +be accessed by the current user, the function returns nil. Otherwise, +the return value depends on the type of the data stored in Registry: + + If the data type is REG_NONE, the function returns t. + If the data type is REG_DWORD or REG_QWORD, the function returns + its integer value. If the value is too large for a fixnum, + the function returns a bignum. + If the data type is REG_BINARY, the function returns a vector whose + elements are individual bytes of the value. + If the data type is REG_SZ, the function returns a string. + If the data type is REG_EXPAND_SZ, the function returns a string + with all the %..% references to environment variables replaced + by the values of those variables. If the expansion fails, or + some variables are not defined in the environment, some or all + of the environment variables will remain unexpanded. + If the data type is REG_MULTI_SZ, the function returns a list whose + elements are the individual strings. + +Note that this function doesn't know whether a string value is a file +name, so file names will be returned with backslashes, which may need +to be converted to forward slashes by the caller. */) + (Lisp_Object root, Lisp_Object key, Lisp_Object name) +{ + CHECK_SYMBOL (root); + CHECK_STRING (key); + CHECK_STRING (name); + + HKEY rootkey = HKEY_CURRENT_USER; + if (EQ (root, QHKCR)) + rootkey = HKEY_CLASSES_ROOT; + else if (EQ (root, QHKCU)) + rootkey = HKEY_CURRENT_USER; + else if (EQ (root, QHKLM)) + rootkey = HKEY_LOCAL_MACHINE; + else if (EQ (root, QHKU)) + rootkey = HKEY_USERS; + else if (EQ (root, QHKCC)) + rootkey = HKEY_CURRENT_CONFIG; + else if (!NILP (root)) + error ("unknown root key: %s", SDATA (SYMBOL_NAME (root))); + + Lisp_Object val = w32_read_registry (rootkey, key, name); + if (NILP (val) && NILP (root)) + val = w32_read_registry (HKEY_LOCAL_MACHINE, key, name); + + return val; +} + +#endif /* WINDOWSNT */ + /*********************************************************************** Initialization ***********************************************************************/ @@ -10427,12 +10237,21 @@ syms_of_w32fns (void) DEFSYM (QCbody, ":body"); #endif +#ifdef WINDOWSNT + DEFSYM (QHKCR, "HKCR"); + DEFSYM (QHKCU, "HKCU"); + DEFSYM (QHKLM, "HKLM"); + DEFSYM (QHKU, "HKU"); + DEFSYM (QHKCC, "HKCC"); +#endif + /* Symbols used elsewhere, but only in MS-Windows-specific code. */ DEFSYM (Qgnutls, "gnutls"); DEFSYM (Qlibxml2, "libxml2"); DEFSYM (Qserif, "serif"); DEFSYM (Qzlib, "zlib"); DEFSYM (Qlcms2, "lcms2"); + DEFSYM (Qjson, "json"); Fput (Qundefined_color, Qerror_conditions, listn (CONSTYPE_PURE, 2, Qundefined_color, Qerror)); @@ -10625,9 +10444,7 @@ bass-down, bass-boost, bass-up, treble-down, treble-up */); #if 0 /* TODO: Mouse cursor customization. */ DEFVAR_LISP ("x-pointer-shape", Vx_pointer_shape, - doc: /* The shape of the pointer when over text. -Changing the value does not affect existing frames -unless you set the mouse color. */); + doc: /* SKIP: real doc in xfns.c. */); Vx_pointer_shape = Qnil; Vx_nontext_pointer_shape = Qnil; @@ -10635,58 +10452,42 @@ unless you set the mouse color. */); Vx_mode_pointer_shape = Qnil; DEFVAR_LISP ("x-hourglass-pointer-shape", Vx_hourglass_pointer_shape, - doc: /* The shape of the pointer when Emacs is busy. -This variable takes effect when you create a new frame -or when you set the mouse color. */); + doc: /* SKIP: real doc in xfns.c. */); Vx_hourglass_pointer_shape = Qnil; DEFVAR_LISP ("x-sensitive-text-pointer-shape", Vx_sensitive_text_pointer_shape, - doc: /* The shape of the pointer when over mouse-sensitive text. -This variable takes effect when you create a new frame -or when you set the mouse color. */); + doc: /* SKIP: real doc in xfns.c. */); Vx_sensitive_text_pointer_shape = Qnil; DEFVAR_LISP ("x-window-horizontal-drag-cursor", Vx_window_horizontal_drag_shape, - doc: /* Pointer shape to use for indicating a window can be dragged horizontally. -This variable takes effect when you create a new frame -or when you set the mouse color. */); + doc: /* SKIP: real doc in xfns.c. */); Vx_window_horizontal_drag_shape = Qnil; DEFVAR_LISP ("x-window-vertical-drag-cursor", Vx_window_vertical_drag_shape, - doc: /* Pointer shape to use for indicating a window can be dragged vertically. -This variable takes effect when you create a new frame -or when you set the mouse color. */); + doc: /* SKIP: real doc in xfns.c. */); Vx_window_vertical_drag_shape = Qnil; #endif DEFVAR_LISP ("x-cursor-fore-pixel", Vx_cursor_fore_pixel, - doc: /* A string indicating the foreground color of the cursor box. */); + doc: /* SKIP: real doc in xfns.c. */); Vx_cursor_fore_pixel = Qnil; DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size, - doc: /* Maximum size for tooltips. -Value is a pair (COLUMNS . ROWS). Text larger than this is clipped. */); - Vx_max_tooltip_size = Fcons (make_number (80), make_number (40)); + doc: /* SKIP: real doc in xfns.c. */); + Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40)); DEFVAR_LISP ("x-no-window-manager", Vx_no_window_manager, - doc: /* Non-nil if no window manager is in use. -Emacs doesn't try to figure this out; this is always nil -unless you set it to something else. */); + doc: /* SKIP: real doc in xfns.c. */); /* We don't have any way to find this out, so set it to nil and maybe the user would like to set it to t. */ Vx_no_window_manager = Qnil; DEFVAR_LISP ("x-pixel-size-width-font-regexp", Vx_pixel_size_width_font_regexp, - doc: /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. - -Since Emacs gets width of a font matching with this regexp from -PIXEL_SIZE field of the name, font finding mechanism gets faster for -such a font. This is especially effective for such large fonts as -Chinese, Japanese, and Korean. */); + doc: /* SKIP: real doc in xfns.c. */); Vx_pixel_size_width_font_regexp = Qnil; DEFVAR_LISP ("w32-bdf-filename-alist", @@ -10794,7 +10595,6 @@ tip frame. */); defsubr (&Sw32_reconstruct_hot_key); defsubr (&Sw32_toggle_lock_key); defsubr (&Sw32_window_exists_p); - defsubr (&Sw32_battery_status); defsubr (&Sw32__menu_bar_in_use); #if defined WINDOWSNT && !defined HAVE_DBUS defsubr (&Sw32_notification_notify); @@ -10802,6 +10602,7 @@ tip frame. */); #endif #ifdef WINDOWSNT + defsubr (&Sw32_read_registry); defsubr (&Sfile_system_info); defsubr (&Sdefault_printer_name); #endif @@ -10813,9 +10614,12 @@ tip frame. */); staticpro (&tip_timer); tip_frame = Qnil; staticpro (&tip_frame); - - last_show_tip_args = Qnil; - staticpro (&last_show_tip_args); + tip_last_frame = Qnil; + staticpro (&tip_last_frame); + tip_last_string = Qnil; + staticpro (&tip_last_string); + tip_last_parms = Qnil; + staticpro (&tip_last_parms); defsubr (&Sx_file_dialog); #ifdef WINDOWSNT @@ -10852,9 +10656,8 @@ void w32_reset_stack_overflow_guard (void) { if (resetstkoflw == NULL) - resetstkoflw = - (_resetstkoflw_proc)GetProcAddress (GetModuleHandle ("msvcrt.dll"), - "_resetstkoflw"); + resetstkoflw = (_resetstkoflw_proc) + get_proc_addr (GetModuleHandle ("msvcrt.dll"), "_resetstkoflw"); /* We ignore the return value. If _resetstkoflw fails, the next stack overflow will crash the program. */ if (resetstkoflw != NULL) @@ -10928,9 +10731,8 @@ w32_backtrace (void **buffer, int limit) if (!s_pfn_CaptureStackBackTrace) { hm_kernel32 = LoadLibrary ("Kernel32.dll"); - s_pfn_CaptureStackBackTrace = - (CaptureStackBackTrace_proc) GetProcAddress (hm_kernel32, - "RtlCaptureStackBackTrace"); + s_pfn_CaptureStackBackTrace = (CaptureStackBackTrace_proc) + get_proc_addr (hm_kernel32, "RtlCaptureStackBackTrace"); } if (s_pfn_CaptureStackBackTrace) return s_pfn_CaptureStackBackTrace (0, min (BACKTRACE_LIMIT_MAX, limit), @@ -11063,29 +10865,29 @@ globals_of_w32fns (void) it dynamically. Do it once, here, instead of every time it is used. */ track_mouse_event_fn = (TrackMouseEvent_Proc) - GetProcAddress (user32_lib, "TrackMouseEvent"); + get_proc_addr (user32_lib, "TrackMouseEvent"); monitor_from_point_fn = (MonitorFromPoint_Proc) - GetProcAddress (user32_lib, "MonitorFromPoint"); + get_proc_addr (user32_lib, "MonitorFromPoint"); get_monitor_info_fn = (GetMonitorInfo_Proc) - GetProcAddress (user32_lib, "GetMonitorInfoA"); + get_proc_addr (user32_lib, "GetMonitorInfoA"); monitor_from_window_fn = (MonitorFromWindow_Proc) - GetProcAddress (user32_lib, "MonitorFromWindow"); + get_proc_addr (user32_lib, "MonitorFromWindow"); enum_display_monitors_fn = (EnumDisplayMonitors_Proc) - GetProcAddress (user32_lib, "EnumDisplayMonitors"); + get_proc_addr (user32_lib, "EnumDisplayMonitors"); get_title_bar_info_fn = (GetTitleBarInfo_Proc) - GetProcAddress (user32_lib, "GetTitleBarInfo"); + get_proc_addr (user32_lib, "GetTitleBarInfo"); { HMODULE imm32_lib = GetModuleHandle ("imm32.dll"); get_composition_string_fn = (ImmGetCompositionString_Proc) - GetProcAddress (imm32_lib, "ImmGetCompositionStringW"); + get_proc_addr (imm32_lib, "ImmGetCompositionStringW"); get_ime_context_fn = (ImmGetContext_Proc) - GetProcAddress (imm32_lib, "ImmGetContext"); + get_proc_addr (imm32_lib, "ImmGetContext"); release_ime_context_fn = (ImmReleaseContext_Proc) - GetProcAddress (imm32_lib, "ImmReleaseContext"); + get_proc_addr (imm32_lib, "ImmReleaseContext"); set_ime_composition_window_fn = (ImmSetCompositionWindow_Proc) - GetProcAddress (imm32_lib, "ImmSetCompositionWindow"); + get_proc_addr (imm32_lib, "ImmSetCompositionWindow"); } except_code = 0; diff --git a/src/w32font.c b/src/w32font.c index 0570d2acba3..84d5a876774 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "coding.h" /* for ENCODE_SYSTEM, DECODE_SYSTEM */ #include "w32font.h" #ifdef WINDOWSNT +#include "w32common.h" #include "w32.h" #endif @@ -153,7 +154,7 @@ get_outline_metrics_w(HDC hdc, UINT cbData, LPOUTLINETEXTMETRICW lpotmw) hm_unicows = w32_load_unicows_or_gdi32 (); if (hm_unicows) s_pfn_Get_Outline_Text_MetricsW = (GetOutlineTextMetricsW_Proc) - GetProcAddress (hm_unicows, "GetOutlineTextMetricsW"); + get_proc_addr (hm_unicows, "GetOutlineTextMetricsW"); } eassert (s_pfn_Get_Outline_Text_MetricsW != NULL); return s_pfn_Get_Outline_Text_MetricsW (hdc, cbData, lpotmw); @@ -170,7 +171,7 @@ get_text_metrics_w(HDC hdc, LPTEXTMETRICW lptmw) hm_unicows = w32_load_unicows_or_gdi32 (); if (hm_unicows) s_pfn_Get_Text_MetricsW = (GetTextMetricsW_Proc) - GetProcAddress (hm_unicows, "GetTextMetricsW"); + get_proc_addr (hm_unicows, "GetTextMetricsW"); } eassert (s_pfn_Get_Text_MetricsW != NULL); return s_pfn_Get_Text_MetricsW (hdc, lptmw); @@ -188,7 +189,7 @@ get_glyph_outline_w (HDC hdc, UINT uChar, UINT uFormat, LPGLYPHMETRICS lpgm, hm_unicows = w32_load_unicows_or_gdi32 (); if (hm_unicows) s_pfn_Get_Glyph_OutlineW = (GetGlyphOutlineW_Proc) - GetProcAddress (hm_unicows, "GetGlyphOutlineW"); + get_proc_addr (hm_unicows, "GetGlyphOutlineW"); } eassert (s_pfn_Get_Glyph_OutlineW != NULL); return s_pfn_Get_Glyph_OutlineW (hdc, uChar, uFormat, lpgm, cbBuffer, @@ -206,7 +207,7 @@ get_char_width_32_w (HDC hdc, UINT uFirstChar, UINT uLastChar, LPINT lpBuffer) hm_unicows = w32_load_unicows_or_gdi32 (); if (hm_unicows) s_pfn_Get_Char_Width_32W = (GetCharWidth32W_Proc) - GetProcAddress (hm_unicows, "GetCharWidth32W"); + get_proc_addr (hm_unicows, "GetCharWidth32W"); } eassert (s_pfn_Get_Char_Width_32W != NULL); return s_pfn_Get_Char_Width_32W (hdc, uFirstChar, uLastChar, lpBuffer); @@ -718,7 +719,7 @@ w32font_draw (struct glyph_string *s, int from, int to, } /* w32 implementation of free_entity for font backend. - Optional (if FONT_EXTRA_INDEX is not Lisp_Save_Value). + Optional. Free FONT_EXTRA_INDEX field of FONT_ENTITY. static void w32font_free_entity (Lisp_Object entity); @@ -920,7 +921,7 @@ w32font_open_internal (struct frame *f, Lisp_Object font_entity, if (!EQ (val, Qraster)) logfont.lfOutPrecision = OUT_TT_PRECIS; - size = XINT (AREF (font_entity, FONT_SIZE_INDEX)); + size = XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX)); if (!size) size = pixel_size; @@ -1096,9 +1097,9 @@ w32_enumfont_pattern_entity (Lisp_Object frame, ASET (entity, FONT_ADSTYLE_INDEX, tem); if (physical_font->ntmTm.tmPitchAndFamily & 0x01) - ASET (entity, FONT_SPACING_INDEX, make_number (FONT_SPACING_PROPORTIONAL)); + ASET (entity, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_PROPORTIONAL)); else - ASET (entity, FONT_SPACING_INDEX, make_number (FONT_SPACING_CHARCELL)); + ASET (entity, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_CHARCELL)); if (requested_font->lfQuality != DEFAULT_QUALITY) { @@ -1109,19 +1110,19 @@ w32_enumfont_pattern_entity (Lisp_Object frame, intern_font_name (lf->lfFaceName)); FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, - make_number (w32_decode_weight (lf->lfWeight))); + make_fixnum (w32_decode_weight (lf->lfWeight))); FONT_SET_STYLE (entity, FONT_SLANT_INDEX, - make_number (lf->lfItalic ? 200 : 100)); + make_fixnum (lf->lfItalic ? 200 : 100)); /* TODO: PANOSE struct has this info, but need to call GetOutlineTextMetrics to get it. */ - FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_number (100)); + FONT_SET_STYLE (entity, FONT_WIDTH_INDEX, make_fixnum (100)); if (font_type & RASTER_FONTTYPE) ASET (entity, FONT_SIZE_INDEX, - make_number (physical_font->ntmTm.tmHeight + make_fixnum (physical_font->ntmTm.tmHeight + physical_font->ntmTm.tmExternalLeading)); else - ASET (entity, FONT_SIZE_INDEX, make_number (0)); + ASET (entity, FONT_SIZE_INDEX, make_fixnum (0)); /* Cache Unicode codepoints covered by this font, as there is no other way of getting this information easily. */ @@ -1229,9 +1230,9 @@ font_matches_spec (DWORD type, NEWTEXTMETRICEX *font, /* Check spacing */ val = AREF (spec, FONT_SPACING_INDEX); - if (INTEGERP (val)) + if (FIXNUMP (val)) { - int spacing = XINT (val); + int spacing = XFIXNUM (val); int proportional = (spacing < FONT_SPACING_MONO); if ((proportional && !(font->ntmTm.tmPitchAndFamily & 0x01)) @@ -1822,8 +1823,8 @@ w32_to_x_charset (int fncharset, char *matching) /* Look for Same charset and a valid codepage (or non-int which means ignore). */ if (EQ (w32_charset, charset_type) - && (!INTEGERP (codepage) || XINT (codepage) == CP_DEFAULT - || IsValidCodePage (XINT (codepage)))) + && (!FIXNUMP (codepage) || XFIXNUM (codepage) == CP_DEFAULT + || IsValidCodePage (XFIXNUM (codepage)))) { /* If we don't have a match already, then this is the best. */ @@ -1955,9 +1956,9 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec) int dpi = FRAME_RES_Y (f); tmp = AREF (font_spec, FONT_DPI_INDEX); - if (INTEGERP (tmp)) + if (FIXNUMP (tmp)) { - dpi = XINT (tmp); + dpi = XFIXNUM (tmp); } else if (FLOATP (tmp)) { @@ -1966,8 +1967,8 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec) /* Height */ tmp = AREF (font_spec, FONT_SIZE_INDEX); - if (INTEGERP (tmp)) - logfont->lfHeight = -1 * XINT (tmp); + if (FIXNUMP (tmp)) + logfont->lfHeight = -1 * XFIXNUM (tmp); else if (FLOATP (tmp)) logfont->lfHeight = (int) (-1.0 * dpi * XFLOAT_DATA (tmp) / 72.27 + 0.5); @@ -1977,12 +1978,12 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec) /* Weight */ tmp = AREF (font_spec, FONT_WEIGHT_INDEX); - if (INTEGERP (tmp)) + if (FIXNUMP (tmp)) logfont->lfWeight = w32_encode_weight (FONT_WEIGHT_NUMERIC (font_spec)); /* Italic */ tmp = AREF (font_spec, FONT_SLANT_INDEX); - if (INTEGERP (tmp)) + if (FIXNUMP (tmp)) { int slant = FONT_SLANT_NUMERIC (font_spec); logfont->lfItalic = slant > 150 ? 1 : 0; @@ -2036,9 +2037,9 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec) /* Set pitch based on the spacing property. */ tmp = AREF (font_spec, FONT_SPACING_INDEX); - if (INTEGERP (tmp)) + if (FIXNUMP (tmp)) { - int spacing = XINT (tmp); + int spacing = XFIXNUM (tmp); if (spacing < FONT_SPACING_MONO) logfont->lfPitchAndFamily = (logfont->lfPitchAndFamily & 0xF0) | VARIABLE_PITCH; diff --git a/src/w32heap.c b/src/w32heap.c index 69cd3a69336..d96e4e2823a 100644 --- a/src/w32heap.c +++ b/src/w32heap.c @@ -250,7 +250,9 @@ init_heap (void) #ifndef MINGW_W64 /* Set the low-fragmentation heap for OS before Vista. */ HMODULE hm_kernel32dll = LoadLibrary ("kernel32.dll"); - HeapSetInformation_Proc s_pfn_Heap_Set_Information = (HeapSetInformation_Proc) GetProcAddress (hm_kernel32dll, "HeapSetInformation"); + HeapSetInformation_Proc s_pfn_Heap_Set_Information = + (HeapSetInformation_Proc) get_proc_addr (hm_kernel32dll, + "HeapSetInformation"); if (s_pfn_Heap_Set_Information != NULL) { if (s_pfn_Heap_Set_Information ((PVOID) heap, @@ -281,7 +283,7 @@ init_heap (void) in ntdll.dll since XP. */ HMODULE hm_ntdll = LoadLibrary ("ntdll.dll"); RtlCreateHeap_Proc s_pfn_Rtl_Create_Heap - = (RtlCreateHeap_Proc) GetProcAddress (hm_ntdll, "RtlCreateHeap"); + = (RtlCreateHeap_Proc) get_proc_addr (hm_ntdll, "RtlCreateHeap"); /* Specific parameters for the private heap. */ RTL_HEAP_PARAMETERS params; ZeroMemory (¶ms, sizeof(params)); diff --git a/src/w32inevt.c b/src/w32inevt.c index 155a8f56526..ab71c560d69 100644 --- a/src/w32inevt.c +++ b/src/w32inevt.c @@ -181,8 +181,8 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead) Space which we will ignore. */ if ((mod_key_state & LEFT_WIN_PRESSED) == 0) { - if (NUMBERP (Vw32_phantom_key_code)) - faked_key = XUINT (Vw32_phantom_key_code) & 255; + if (FIXNUMP (Vw32_phantom_key_code)) + faked_key = XUFIXNUM (Vw32_phantom_key_code) & 255; else faked_key = VK_SPACE; keybd_event (faked_key, (BYTE) MapVirtualKey (faked_key, 0), 0, 0); @@ -198,8 +198,8 @@ key_event (KEY_EVENT_RECORD *event, struct input_event *emacs_ev, int *isdead) { if ((mod_key_state & RIGHT_WIN_PRESSED) == 0) { - if (NUMBERP (Vw32_phantom_key_code)) - faked_key = XUINT (Vw32_phantom_key_code) & 255; + if (FIXNUMP (Vw32_phantom_key_code)) + faked_key = XUFIXNUM (Vw32_phantom_key_code) & 255; else faked_key = VK_SPACE; keybd_event (faked_key, (BYTE) MapVirtualKey (faked_key, 0), 0, 0); diff --git a/src/w32menu.c b/src/w32menu.c index 853dc971c57..7d91005f22d 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -1407,7 +1407,8 @@ add_menu_item (HMENU menu, widget_value *wv, HMENU item) Windows alike. MSVC headers get it right; hopefully, MinGW headers will, too. */ eassert (STRINGP (wv->help)); - info.dwItemData = (ULONG_PTR) XUNTAG (wv->help, Lisp_String); + info.dwItemData = (ULONG_PTR) XUNTAG (wv->help, Lisp_String, + struct Lisp_String); } if (wv->button_type == BUTTON_TYPE_RADIO) { @@ -1571,7 +1572,7 @@ w32_free_menu_strings (HWND hwnd) /* The following is used by delayed window autoselection. */ DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0, - doc: /* Return t if a menu or popup dialog is active on selected frame. */) + doc: /* SKIP: real doc in xmenu.c. */) (void) { struct frame *f; @@ -1606,9 +1607,13 @@ globals_of_w32menu (void) #ifndef NTGUI_UNICODE /* See if Get/SetMenuItemInfo functions are available. */ HMODULE user32 = GetModuleHandle ("user32.dll"); - get_menu_item_info = (GetMenuItemInfoA_Proc) GetProcAddress (user32, "GetMenuItemInfoA"); - set_menu_item_info = (SetMenuItemInfoA_Proc) GetProcAddress (user32, "SetMenuItemInfoA"); - unicode_append_menu = (AppendMenuW_Proc) GetProcAddress (user32, "AppendMenuW"); - unicode_message_box = (MessageBoxW_Proc) GetProcAddress (user32, "MessageBoxW"); + get_menu_item_info = (GetMenuItemInfoA_Proc) + get_proc_addr (user32, "GetMenuItemInfoA"); + set_menu_item_info = (SetMenuItemInfoA_Proc) + get_proc_addr (user32, "SetMenuItemInfoA"); + unicode_append_menu = (AppendMenuW_Proc) + get_proc_addr (user32, "AppendMenuW"); + unicode_message_box = (MessageBoxW_Proc) + get_proc_addr (user32, "MessageBoxW"); #endif /* !NTGUI_UNICODE */ } diff --git a/src/w32notify.c b/src/w32notify.c index e03650f0fd3..53787fd45db 100644 --- a/src/w32notify.c +++ b/src/w32notify.c @@ -1,5 +1,8 @@ /* Filesystem notifications support for GNU Emacs on the Microsoft Windows API. - Copyright (C) 2012-2019 Free Software Foundation, Inc. + +Copyright (C) 2012-2019 Free Software Foundation, Inc. + +Author: Eli Zaretskii <eliz@gnu.org> This file is part of GNU Emacs. @@ -16,9 +19,7 @@ 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 <https://www.gnu.org/licenses/>. */ -/* Written by Eli Zaretskii <eliz@gnu.org>. - - Design overview: +/* Design overview: For each watch request, we launch a separate worker thread. The worker thread runs the watch_worker function, which issues an @@ -621,7 +622,7 @@ generate notifications correctly, though. */) report_file_notify_error ("Cannot watch file", Fcons (file, Qnil)); } /* Store watch object in watch list. */ - watch_descriptor = make_pointer_integer (dirwatch); + watch_descriptor = make_mint_ptr (dirwatch); watch_object = Fcons (watch_descriptor, callback); watch_list = Fcons (watch_object, watch_list); @@ -646,7 +647,7 @@ WATCH-DESCRIPTOR should be an object returned by `w32notify-add-watch'. */) if (!NILP (watch_object)) { watch_list = Fdelete (watch_object, watch_list); - dirwatch = (struct notification *)XINTPTR (watch_descriptor); + dirwatch = (struct notification *)xmint_pointer (watch_descriptor); if (w32_valid_pointer_p (dirwatch, sizeof(struct notification))) status = remove_watch (dirwatch); } @@ -661,7 +662,7 @@ WATCH-DESCRIPTOR should be an object returned by `w32notify-add-watch'. */) Lisp_Object w32_get_watch_object (void *desc) { - Lisp_Object descriptor = make_pointer_integer (desc); + Lisp_Object descriptor = make_mint_ptr (desc); /* This is called from the input queue handling code, inside a critical section, so we cannot possibly quit if watch_list is not @@ -684,7 +685,7 @@ watch by calling `w32notify-rm-watch' also makes it invalid. */) if (!NILP (watch_object)) { struct notification *dirwatch = - (struct notification *)XINTPTR (watch_descriptor); + (struct notification *)xmint_pointer (watch_descriptor); if (w32_valid_pointer_p (dirwatch, sizeof(struct notification)) && dirwatch->dir != NULL) return Qt; diff --git a/src/w32proc.c b/src/w32proc.c index f591a80e7b2..ec60a9cabcc 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -548,9 +548,8 @@ init_timers (void) through a pointer. */ s_pfn_Get_Thread_Times = NULL; /* in case dumped Emacs comes with a value */ if (os_subtype != OS_9X) - s_pfn_Get_Thread_Times = - (GetThreadTimes_Proc)GetProcAddress (GetModuleHandle ("kernel32.dll"), - "GetThreadTimes"); + s_pfn_Get_Thread_Times = (GetThreadTimes_Proc) + get_proc_addr (GetModuleHandle ("kernel32.dll"), "GetThreadTimes"); /* Make sure we start with zeroed out itimer structures, since dumping may have left there traces of threads long dead. */ @@ -1766,7 +1765,7 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp) { program = build_string (cmdname); full = Qnil; - openp (Vexec_path, program, Vexec_suffixes, &full, make_number (X_OK), 0); + openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK), 0); if (NILP (full)) { errno = EINVAL; @@ -1889,8 +1888,8 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp) do_quoting = 1; /* Override escape char by binding w32-quote-process-args to desired character, or use t for auto-selection. */ - if (INTEGERP (Vw32_quote_process_args)) - escape_char = XINT (Vw32_quote_process_args); + if (FIXNUMP (Vw32_quote_process_args)) + escape_char = XFIXNUM (Vw32_quote_process_args); else escape_char = (is_cygnus_app || is_msys_app) ? '"' : '\\'; } @@ -2691,8 +2690,8 @@ sys_kill (pid_t pid, int sig) { g_b_init_debug_break_process = 1; s_pfn_Debug_Break_Process = (DebugBreakProcess_Proc) - GetProcAddress (GetModuleHandle ("kernel32.dll"), - "DebugBreakProcess"); + get_proc_addr (GetModuleHandle ("kernel32.dll"), + "DebugBreakProcess"); } if (s_pfn_Debug_Break_Process == NULL) @@ -3017,13 +3016,13 @@ If successful, the return value is t, otherwise nil. */) DWORD pid; child_process *cp; - CHECK_NUMBER (process); + CHECK_FIXNUM (process); /* Allow pid to be an internally generated one, or one obtained externally. This is necessary because real pids on Windows 95 are negative. */ - pid = XINT (process); + pid = XFIXNUM (process); cp = find_child_pid (pid); if (cp != NULL) pid = cp->procinfo.dwProcessId; @@ -3186,14 +3185,14 @@ If LCID (a 16-bit number) is not a valid locale, the result is nil. */) char abbrev_name[32] = { 0 }; char full_name[256] = { 0 }; - CHECK_NUMBER (lcid); + CHECK_FIXNUM (lcid); - if (!IsValidLocale (XINT (lcid), LCID_SUPPORTED)) + if (!IsValidLocale (XFIXNUM (lcid), LCID_SUPPORTED)) return Qnil; if (NILP (longform)) { - got_abbrev = GetLocaleInfo (XINT (lcid), + got_abbrev = GetLocaleInfo (XFIXNUM (lcid), LOCALE_SABBREVLANGNAME | LOCALE_USE_CP_ACP, abbrev_name, sizeof (abbrev_name)); if (got_abbrev) @@ -3201,16 +3200,16 @@ If LCID (a 16-bit number) is not a valid locale, the result is nil. */) } else if (EQ (longform, Qt)) { - got_full = GetLocaleInfo (XINT (lcid), + got_full = GetLocaleInfo (XFIXNUM (lcid), LOCALE_SLANGUAGE | LOCALE_USE_CP_ACP, full_name, sizeof (full_name)); if (got_full) return DECODE_SYSTEM (build_string (full_name)); } - else if (NUMBERP (longform)) + else if (FIXNUMP (longform)) { - got_full = GetLocaleInfo (XINT (lcid), - XINT (longform), + got_full = GetLocaleInfo (XFIXNUM (lcid), + XFIXNUM (longform), full_name, sizeof (full_name)); /* GetLocaleInfo's return value includes the terminating null character, when the returned information is a string, whereas @@ -3231,7 +3230,7 @@ This is a numerical value; use `w32-get-locale-info' to convert to a human-readable form. */) (void) { - return make_number (GetThreadLocale ()); + return make_fixnum (GetThreadLocale ()); } static DWORD @@ -3260,7 +3259,7 @@ static BOOL CALLBACK ALIGN_STACK enum_locale_fn (LPTSTR localeNum) { DWORD id = int_from_hex (localeNum); - Vw32_valid_locale_ids = Fcons (make_number (id), Vw32_valid_locale_ids); + Vw32_valid_locale_ids = Fcons (make_fixnum (id), Vw32_valid_locale_ids); return TRUE; } @@ -3289,8 +3288,8 @@ human-readable form. */) (Lisp_Object userp) { if (NILP (userp)) - return make_number (GetSystemDefaultLCID ()); - return make_number (GetUserDefaultLCID ()); + return make_fixnum (GetSystemDefaultLCID ()); + return make_fixnum (GetUserDefaultLCID ()); } @@ -3299,20 +3298,20 @@ DEFUN ("w32-set-current-locale", Fw32_set_current_locale, Sw32_set_current_local If successful, the new locale id is returned, otherwise nil. */) (Lisp_Object lcid) { - CHECK_NUMBER (lcid); + CHECK_FIXNUM (lcid); - if (!IsValidLocale (XINT (lcid), LCID_SUPPORTED)) + if (!IsValidLocale (XFIXNUM (lcid), LCID_SUPPORTED)) return Qnil; - if (!SetThreadLocale (XINT (lcid))) + if (!SetThreadLocale (XFIXNUM (lcid))) return Qnil; /* Need to set input thread locale if present. */ if (dwWindowsThreadId) /* Reply is not needed. */ - PostThreadMessage (dwWindowsThreadId, WM_EMACS_SETLOCALE, XINT (lcid), 0); + PostThreadMessage (dwWindowsThreadId, WM_EMACS_SETLOCALE, XFIXNUM (lcid), 0); - return make_number (GetThreadLocale ()); + return make_fixnum (GetThreadLocale ()); } @@ -3324,7 +3323,7 @@ static BOOL CALLBACK ALIGN_STACK enum_codepage_fn (LPTSTR codepageNum) { DWORD id = atoi (codepageNum); - Vw32_valid_codepages = Fcons (make_number (id), Vw32_valid_codepages); + Vw32_valid_codepages = Fcons (make_fixnum (id), Vw32_valid_codepages); return TRUE; } @@ -3347,7 +3346,7 @@ DEFUN ("w32-get-console-codepage", Fw32_get_console_codepage, doc: /* Return current Windows codepage for console input. */) (void) { - return make_number (GetConsoleCP ()); + return make_fixnum (GetConsoleCP ()); } @@ -3358,15 +3357,15 @@ This codepage setting affects keyboard input in tty mode. If successful, the new CP is returned, otherwise nil. */) (Lisp_Object cp) { - CHECK_NUMBER (cp); + CHECK_FIXNUM (cp); - if (!IsValidCodePage (XINT (cp))) + if (!IsValidCodePage (XFIXNUM (cp))) return Qnil; - if (!SetConsoleCP (XINT (cp))) + if (!SetConsoleCP (XFIXNUM (cp))) return Qnil; - return make_number (GetConsoleCP ()); + return make_fixnum (GetConsoleCP ()); } @@ -3375,7 +3374,7 @@ DEFUN ("w32-get-console-output-codepage", Fw32_get_console_output_codepage, doc: /* Return current Windows codepage for console output. */) (void) { - return make_number (GetConsoleOutputCP ()); + return make_fixnum (GetConsoleOutputCP ()); } @@ -3386,15 +3385,15 @@ This codepage setting affects display in tty mode. If successful, the new CP is returned, otherwise nil. */) (Lisp_Object cp) { - CHECK_NUMBER (cp); + CHECK_FIXNUM (cp); - if (!IsValidCodePage (XINT (cp))) + if (!IsValidCodePage (XFIXNUM (cp))) return Qnil; - if (!SetConsoleOutputCP (XINT (cp))) + if (!SetConsoleOutputCP (XFIXNUM (cp))) return Qnil; - return make_number (GetConsoleOutputCP ()); + return make_fixnum (GetConsoleOutputCP ()); } @@ -3412,17 +3411,17 @@ yield nil. */) CHARSETINFO info; DWORD_PTR dwcp; - CHECK_NUMBER (cp); + CHECK_FIXNUM (cp); - if (!IsValidCodePage (XINT (cp))) + if (!IsValidCodePage (XFIXNUM (cp))) return Qnil; /* Going through a temporary DWORD_PTR variable avoids compiler warning about cast to pointer from integer of different size, when building --with-wide-int or building for 64bit. */ - dwcp = XINT (cp); + dwcp = XFIXNUM (cp); if (TranslateCharsetInfo ((DWORD *) dwcp, &info, TCI_SRCCODEPAGE)) - return make_number (info.ciCharset); + return make_fixnum (info.ciCharset); return Qnil; } @@ -3444,8 +3443,8 @@ The return value is a list of pairs of language id and layout id. */) { HKL kl = layouts[num_layouts]; - obj = Fcons (Fcons (make_number (LOWORD (kl)), - make_number (HIWORD (kl))), + obj = Fcons (Fcons (make_fixnum (LOWORD (kl)), + make_fixnum (HIWORD (kl))), obj); } } @@ -3462,8 +3461,8 @@ The return value is the cons of the language id and the layout id. */) { HKL kl = GetKeyboardLayout (dwWindowsThreadId); - return Fcons (make_number (LOWORD (kl)), - make_number (HIWORD (kl))); + return Fcons (make_fixnum (LOWORD (kl)), + make_fixnum (HIWORD (kl))); } @@ -3477,11 +3476,11 @@ If successful, the new layout id is returned, otherwise nil. */) HKL kl; CHECK_CONS (layout); - CHECK_NUMBER_CAR (layout); - CHECK_NUMBER_CDR (layout); + CHECK_FIXNUM (XCAR (layout)); + CHECK_FIXNUM (XCDR (layout)); - kl = (HKL) (UINT_PTR) ((XINT (XCAR (layout)) & 0xffff) - | (XINT (XCDR (layout)) << 16)); + kl = (HKL) (UINT_PTR) ((XFIXNUM (XCAR (layout)) & 0xffff) + | (XFIXNUM (XCDR (layout)) << 16)); /* Synchronize layout with input thread. */ if (dwWindowsThreadId) @@ -3608,9 +3607,9 @@ w32_compare_strings (const char *s1, const char *s2, char *locname, { if (os_subtype == OS_9X) { - pCompareStringW = - (CompareStringW_Proc) GetProcAddress (LoadLibrary ("Unicows.dll"), - "CompareStringW"); + pCompareStringW = (CompareStringW_Proc) + get_proc_addr (LoadLibrary ("Unicows.dll"), + "CompareStringW"); if (!pCompareStringW) { errno = EINVAL; @@ -3763,14 +3762,17 @@ them blocking when trying to access unmounted drives etc. */); DEFVAR_INT ("w32-pipe-read-delay", w32_pipe_read_delay, doc: /* Forced delay before reading subprocess output. -This is done to improve the buffering of subprocess output, by -avoiding the inefficiency of frequently reading small amounts of data. +This may need to be done to improve the buffering of subprocess output, +by avoiding the inefficiency of frequently reading small amounts of data. +Typically needed only with DOS programs on Windows 9X; set to 50 if +throughput with such programs is slow. If positive, the value is the number of milliseconds to sleep before -reading the subprocess output. If negative, the magnitude is the number -of time slices to wait (effectively boosting the priority of the child -process temporarily). A value of zero disables waiting entirely. */); - w32_pipe_read_delay = 50; +signaling that output from a subprocess is ready to be read. +If negative, the value is the number of time slices to wait (effectively +boosting the priority of the child process temporarily). +A value of zero disables waiting entirely. */); + w32_pipe_read_delay = 0; DEFVAR_INT ("w32-pipe-buffer-size", w32_pipe_buffer_size, doc: /* Size of buffer for pipes created to communicate with subprocesses. diff --git a/src/w32reg.c b/src/w32reg.c index e2aebbb1b76..aff131dd37d 100644 --- a/src/w32reg.c +++ b/src/w32reg.c @@ -1,6 +1,8 @@ /* Emulate the X Resource Manager through the registry. - Copyright (C) 1990, 1993-1994, 2001-2019 Free Software Foundation, - Inc. + +Copyright (C) 1990, 1993-1994, 2001-2019 Free Software Foundation, Inc. + +Author: Kevin Gallo This file is part of GNU Emacs. @@ -17,8 +19,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 <https://www.gnu.org/licenses/>. */ -/* Written by Kevin Gallo */ - #include <config.h> #include "lisp.h" #include "w32term.h" /* for XrmDatabase, xrdb */ diff --git a/src/w32select.c b/src/w32select.c index 6c7808d9813..1c84cb47eb1 100644 --- a/src/w32select.c +++ b/src/w32select.c @@ -2,6 +2,9 @@ Copyright (C) 1993-1994, 2001-2019 Free Software Foundation, Inc. +Author: Kevin Gallo + Benjamin Riefenstahl + This file is part of GNU Emacs. GNU Emacs is free software: you can redistribute it and/or modify @@ -17,9 +20,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 <https://www.gnu.org/licenses/>. */ -/* Written by Kevin Gallo, Benjamin Riefenstahl */ - - /* * Notes on usage of selection-coding-system and * next-selection-coding-system on MS Windows: @@ -241,7 +241,7 @@ static Lisp_Object render (Lisp_Object oformat) { HGLOBAL htext = NULL; - UINT format = XFASTINT (oformat); + UINT format = XFIXNAT (oformat); ONTRACE (fprintf (stderr, "render\n")); @@ -371,8 +371,8 @@ render_all (Lisp_Object ignore) render_locale (); if (current_clipboard_type == CF_UNICODETEXT) - render (make_number (CF_TEXT)); - render (make_number (current_clipboard_type)); + render (make_fixnum (CF_TEXT)); + render (make_fixnum (current_clipboard_type)); CloseClipboard (); @@ -419,7 +419,7 @@ owner_callback (HWND win, UINT msg, WPARAM wp, LPARAM lp) { case WM_RENDERFORMAT: ONTRACE (fprintf (stderr, "WM_RENDERFORMAT\n")); - run_protected (render, make_number (wp)); + run_protected (render, make_fixnum (wp)); return 0; case WM_RENDERALLFORMATS: @@ -631,7 +631,7 @@ validate_coding_system (Lisp_Object coding_system) eol_type = Fcoding_system_eol_type (coding_system); /* Already a DOS coding system? */ - if (EQ (eol_type, make_number (1))) + if (EQ (eol_type, make_fixnum (1))) return coding_system; /* Get EOL_TYPE vector of the base of CODING_SYSTEM. */ @@ -742,7 +742,7 @@ DEFUN ("w32-set-clipboard-data", Fw32_set_clipboard_data, /* If for some reason we don't have a clipboard_owner, we just set the text format as chosen by the configuration and than forget about the whole thing. */ - ok = !NILP (render (make_number (current_clipboard_type))); + ok = !NILP (render (make_fixnum (current_clipboard_type))); current_text = Qnil; current_coding_system = Qnil; } @@ -1123,7 +1123,7 @@ representing a data format that is currently available in the clipboard. */) /* We generate a vector because that's what xselect.c does in this case. */ - val = Fmake_vector (make_number (fmtcount), Qnil); + val = Fmake_vector (make_fixnum (fmtcount), Qnil); /* Note: when stepping with GDB through this code, the loop below terminates immediately because EnumClipboardFormats for some reason returns with @@ -1170,45 +1170,13 @@ syms_of_w32select (void) defsubr (&Sw32_selection_targets); DEFVAR_LISP ("selection-coding-system", Vselection_coding_system, - doc: /* Coding system for communicating with other programs. - -For MS-Windows and MS-DOS: -When sending or receiving text via selection and clipboard, the text -is encoded or decoded by this coding system. The default value is -the current system default encoding on 9x/Me, `utf-16le-dos' -\(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS. - -For X Windows: -When sending text via selection and clipboard, if the target -data-type matches with the type of this coding system, it is used -for encoding the text. Otherwise (including the case that this -variable is nil), a proper coding system is used as below: - -data-type coding system ---------- ------------- -UTF8_STRING utf-8 -COMPOUND_TEXT compound-text-with-extensions -STRING iso-latin-1 -C_STRING no-conversion - -When receiving text, if this coding system is non-nil, it is used -for decoding regardless of the data-type. If this is nil, a -proper coding system is used according to the data-type as above. - -See also the documentation of the variable `x-select-request-type' how -to control which data-type to request for receiving text. - -The default value is nil. */); + doc: /* SKIP: real doc in select.el. */); /* The actual value is set dynamically in the dumped Emacs, see below. */ Vselection_coding_system = Qnil; DEFVAR_LISP ("next-selection-coding-system", Vnext_selection_coding_system, - doc: /* Coding system for the next communication with other programs. -Usually, `selection-coding-system' is used for communicating with -other programs (X Windows clients or MS Windows programs). But, if this -variable is set, it is used for the next communication only. -After the communication, this variable is set to nil. */); + doc: /* SKIP: real doc in select.el. */); Vnext_selection_coding_system = Qnil; DEFSYM (QCLIPBOARD, "CLIPBOARD"); diff --git a/src/w32term.c b/src/w32term.c index a9b5793a3ec..d13763d7db3 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -478,8 +478,8 @@ x_set_frame_alpha (struct frame *f) if (FLOATP (Vframe_alpha_lower_limit)) alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit); - else if (INTEGERP (Vframe_alpha_lower_limit)) - alpha_min = (XINT (Vframe_alpha_lower_limit)) / 100.0; + else if (FIXNUMP (Vframe_alpha_lower_limit)) + alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0; if (alpha < 0.0) return; @@ -1476,7 +1476,7 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) { sprintf ((char *) buf, "%0*X", glyph->u.glyphless.ch < 0x10000 ? 4 : 6, - (unsigned int) glyph->u.glyphless.ch); + (unsigned int) glyph->u.glyphless.ch & 0xffffff); str = buf; } @@ -1979,14 +1979,14 @@ x_draw_image_relief (struct glyph_string *s) if (s->face->id == TOOL_BAR_FACE_ID) { if (CONSP (Vtool_bar_button_margin) - && INTEGERP (XCAR (Vtool_bar_button_margin)) - && INTEGERP (XCDR (Vtool_bar_button_margin))) + && FIXNUMP (XCAR (Vtool_bar_button_margin)) + && FIXNUMP (XCDR (Vtool_bar_button_margin))) { - extra_x = XINT (XCAR (Vtool_bar_button_margin)); - extra_y = XINT (XCDR (Vtool_bar_button_margin)); + extra_x = XFIXNUM (XCAR (Vtool_bar_button_margin)); + extra_y = XFIXNUM (XCDR (Vtool_bar_button_margin)); } - else if (INTEGERP (Vtool_bar_button_margin)) - extra_x = extra_y = XINT (Vtool_bar_button_margin); + else if (FIXNUMP (Vtool_bar_button_margin)) + extra_x = extra_y = XFIXNUM (Vtool_bar_button_margin); } top_p = bot_p = left_p = right_p = 0; @@ -2475,31 +2475,52 @@ x_draw_glyph_string (struct glyph_string *s) else { struct font *font = font_for_underline_metrics (s); + unsigned long minimum_offset; + BOOL underline_at_descent_line; + BOOL use_underline_position_properties; + Lisp_Object val + = buffer_local_value (Qunderline_minimum_offset, + s->w->contents); + if (FIXNUMP (val)) + minimum_offset = XFIXNAT (val); + else + minimum_offset = 1; + val = buffer_local_value (Qx_underline_at_descent_line, + s->w->contents); + underline_at_descent_line + = !(NILP (val) || EQ (val, Qunbound)); + val + = buffer_local_value (Qx_use_underline_position_properties, + s->w->contents); + use_underline_position_properties + = !(NILP (val) || EQ (val, Qunbound)); /* Get the underline thickness. Default is 1 pixel. */ if (font && font->underline_thickness > 0) thickness = font->underline_thickness; else thickness = 1; - if (x_underline_at_descent_line || !font) + if (underline_at_descent_line + || !font) position = (s->height - thickness) - (s->ybase - s->y); else { - /* Get the underline position. This is the recommended - vertical offset in pixels from the baseline to the top of - the underline. This is a signed value according to the + /* Get the underline position. This is the + recommended vertical offset in pixels from + the baseline to the top of the underline. + This is a signed value according to the specs, and its default is ROUND ((maximum_descent) / 2), with ROUND (x) = floor (x + 0.5) */ - if (x_use_underline_position_properties + if (use_underline_position_properties && font->underline_position >= 0) position = font->underline_position; else position = (font->descent + 1) / 2; } - position = max (position, underline_minimum_offset); + position = max (position, minimum_offset); } /* Check the sanity of thickness and position. We should avoid drawing underline out of the current line area. */ @@ -2865,20 +2886,6 @@ x_focus_changed (int type, int state, struct w32_display_info *dpyinfo, { x_new_focus_frame (dpyinfo, frame); dpyinfo->w32_focus_event_frame = frame; - - /* Don't stop displaying the initial startup message - for a switch-frame event we don't need. */ - if (NILP (Vterminal_frame) - && CONSP (Vframe_list) - && !NILP (XCDR (Vframe_list))) - { - bufp->arg = Qt; - } - else - { - bufp->arg = Qnil; - } - bufp->kind = FOCUS_IN_EVENT; XSETFRAME (bufp->frame_or_window, frame); } @@ -3566,8 +3573,8 @@ w32_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, static void w32_handle_tool_bar_click (struct frame *f, struct input_event *button_event) { - int x = XFASTINT (button_event->x); - int y = XFASTINT (button_event->y); + int x = XFIXNAT (button_event->x); + int y = XFIXNAT (button_event->y); if (button_event->modifiers & down_modifier) handle_tool_bar_click (f, x, y, 1, 0); @@ -4762,7 +4769,7 @@ w32_read_socket (struct terminal *terminal, if (f && !FRAME_ICONIFIED_P (f)) { - if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight) + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) && !EQ (f->tool_bar_window, hlinfo->mouse_face_window)) { clear_mouse_face (hlinfo); @@ -4787,7 +4794,7 @@ w32_read_socket (struct terminal *terminal, if (f && !FRAME_ICONIFIED_P (f)) { - if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight) + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) && !EQ (f->tool_bar_window, hlinfo->mouse_face_window)) { clear_mouse_face (hlinfo); @@ -4865,7 +4872,7 @@ w32_read_socket (struct terminal *terminal, if (f && !FRAME_ICONIFIED_P (f)) { - if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight) + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) && !EQ (f->tool_bar_window, hlinfo->mouse_face_window)) { clear_mouse_face (hlinfo); @@ -4989,8 +4996,8 @@ w32_read_socket (struct terminal *terminal, && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window))) { Lisp_Object window; - int x = XFASTINT (inev.x); - int y = XFASTINT (inev.y); + int x = XFIXNAT (inev.x); + int y = XFIXNAT (inev.y); window = window_from_coordinates (f, x, y, 0, 1); @@ -5569,7 +5576,7 @@ w32_read_socket (struct terminal *terminal, struct frame *f = XFRAME (frame); /* The tooltip has been drawn already. Avoid the SET_FRAME_GARBAGED below. */ - if (EQ (frame, tip_frame)) + if (FRAME_TOOLTIP_P (f)) continue; /* Check "visible" frames and mark each as obscured or not. @@ -6046,7 +6053,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset) /* Don't change the size of a tip frame; there's no point in doing it because it's done in Fx_show_tip, and it leads to problems because the tip frame has no widget. */ - if (NILP (tip_frame) || XFRAME (tip_frame) != f) + if (!FRAME_TOOLTIP_P (f)) adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3, false, Qfont); @@ -6135,11 +6142,11 @@ x_calc_absolute_position (struct frame *f) geometry = Fassoc (Qgeometry, attributes, Qnil); if (!NILP (geometry)) { - monitor_left = Fnth (make_number (1), geometry); - monitor_top = Fnth (make_number (2), geometry); + monitor_left = Fnth (make_fixnum (1), geometry); + monitor_top = Fnth (make_fixnum (2), geometry); - display_left = min (display_left, XINT (monitor_left)); - display_top = min (display_top, XINT (monitor_top)); + display_left = min (display_left, XFIXNUM (monitor_left)); + display_top = min (display_top, XFIXNUM (monitor_top)); } } } @@ -6425,10 +6432,10 @@ x_set_window_size (struct frame *f, bool change_gravity, { frame_size_history_add (f, Qx_set_window_size_1, width, height, - list2 (Fcons (make_number (pixelwidth), - make_number (pixelheight)), - Fcons (make_number (rect.right - rect.left), - make_number (rect.bottom - rect.top)))); + list2 (Fcons (make_fixnum (pixelwidth), + make_fixnum (pixelheight)), + Fcons (make_fixnum (rect.right - rect.left), + make_fixnum (rect.bottom - rect.top)))); if (!FRAME_PARENT_FRAME (f)) my_set_window_pos (FRAME_W32_WINDOW (f), NULL, @@ -7258,7 +7265,7 @@ w32_initialize (void) /* Initialize input mode: interrupt_input off, no flow control, allow 8 bit character input, standard quit char. */ - Fset_input_mode (Qnil, Qnil, make_number (2), Qnil); + Fset_input_mode (Qnil, Qnil, make_fixnum (2), Qnil); { LCID input_locale_id = LOWORD (GetKeyboardLayout (0)); @@ -7329,14 +7336,7 @@ syms_of_w32term (void) DEFSYM (Qrenamed_to, "renamed-to"); DEFVAR_LISP ("x-wait-for-event-timeout", Vx_wait_for_event_timeout, - doc: /* How long to wait for X events. - -Emacs will wait up to this many seconds to receive X events after -making changes which affect the state of the graphical interface. -Under some window managers this can take an indefinite amount of time, -so it is important to limit the wait. - -If set to a non-float value, there will be no wait at all. */); + doc: /* SKIP: real doc in xterm.c. */); Vx_wait_for_event_timeout = make_float (0.1); DEFVAR_INT ("w32-num-mouse-buttons", @@ -7390,30 +7390,19 @@ the cursor have no effect. */); from cus-start.el and other places, like "M-x set-variable". */ DEFVAR_BOOL ("x-use-underline-position-properties", x_use_underline_position_properties, - doc: /* Non-nil means make use of UNDERLINE_POSITION font properties. -A value of nil means ignore them. If you encounter fonts with bogus -UNDERLINE_POSITION font properties, for example 7x13 on XFree prior -to 4.1, set this to nil. You can also use `underline-minimum-offset' -to override the font's UNDERLINE_POSITION for small font display -sizes. */); + doc: /* SKIP: real doc in xterm.c. */); x_use_underline_position_properties = 0; + DEFSYM (Qx_use_underline_position_properties, + "x-use-underline-position-properties"); DEFVAR_BOOL ("x-underline-at-descent-line", x_underline_at_descent_line, - doc: /* Non-nil means to draw the underline at the same place as the descent line. -(If `line-spacing' is in effect, that moves the underline lower by -that many pixels.) -A value of nil means to draw the underline according to the value of the -variable `x-use-underline-position-properties', which is usually at the -baseline level. The default value is nil. */); + doc: /* SKIP: real doc in xterm.c. */); x_underline_at_descent_line = 0; + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars, - doc: /* Which toolkit scroll bars Emacs uses, if any. -A value of nil means Emacs doesn't use toolkit scroll bars. -With the X Window system, the value is a symbol describing the -X toolkit. Possible values are: gtk, motif, xaw, or xaw3d. -With MS Windows or Nextstep, the value is t. */); + doc: /* SKIP: real doc in xterm.c. */); Vx_toolkit_scroll_bars = Qt; DEFVAR_BOOL ("w32-unicode-filenames", diff --git a/src/w32term.h b/src/w32term.h index 9a6c358982a..4c496e97e4a 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -478,7 +478,7 @@ struct scroll_bar { #ifdef _WIN64 /* Building a 64-bit C integer from two 32-bit lisp integers. */ -#define SCROLL_BAR_PACK(low, high) (XINT (high) << 32 | XINT (low)) +#define SCROLL_BAR_PACK(low, high) (XFIXNUM (high) << 32 | XFIXNUM (low)) /* Setting two lisp integers to the low and high words of a 64-bit C int. */ #define SCROLL_BAR_UNPACK(low, high, int64) \ @@ -486,7 +486,7 @@ struct scroll_bar { XSETINT ((high), ((DWORDLONG)(int64) >> 32) & 0xffffffff)) #else /* not _WIN64 */ /* Building a 32-bit C unsigned integer from two 16-bit lisp integers. */ -#define SCROLL_BAR_PACK(low, high) ((UINT_PTR)(XINT (high) << 16 | XINT (low))) +#define SCROLL_BAR_PACK(low, high) ((UINT_PTR)(XFIXNUM (high) << 16 | XFIXNUM (low))) /* Setting two lisp integers to the low and high words of a 32-bit C int. */ #define SCROLL_BAR_UNPACK(low, high, int32) \ @@ -817,6 +817,8 @@ extern struct window *w32_system_caret_window; extern int w32_system_caret_hdr_height; extern int w32_system_caret_mode_height; +extern Window tip_window; + #ifdef _MSC_VER #ifndef EnumSystemLocales /* MSVC headers define these only for _WIN32_WINNT >= 0x0500. */ diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c index 33959cd05c8..bec988041ad 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -36,6 +36,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "composite.h" #include "font.h" #include "w32font.h" +#include "w32common.h" struct uniscribe_font_info { @@ -460,21 +461,21 @@ uniscribe_shape (Lisp_Object lgstring) the direction, the Hebrew point HOLAM is drawn above the right edge of the base consonant, instead of above the left edge. */ - ASET (vec, 0, make_number (-offsets[j].du + ASET (vec, 0, make_fixnum (-offsets[j].du + adj_offset)); /* Update the adjustment value for the width advance of the glyph we just emitted. */ adj_offset -= 2 * advances[j]; } else - ASET (vec, 0, make_number (offsets[j].du + adj_offset)); + ASET (vec, 0, make_fixnum (offsets[j].du + adj_offset)); /* In the font definition coordinate system, the Y coordinate points up, while in our screen coordinates Y grows downwards. So we need to reverse the sign of Y-OFFSET here. */ - ASET (vec, 1, make_number (-offsets[j].dv)); + ASET (vec, 1, make_fixnum (-offsets[j].dv)); /* Based on what ftfont.c does... */ - ASET (vec, 2, make_number (advances[j])); + ASET (vec, 2, make_fixnum (advances[j])); LGLYPH_SET_ADJUSTMENT (lglyph, vec); } else @@ -502,7 +503,7 @@ uniscribe_shape (Lisp_Object lgstring) if (NILP (lgstring)) return Qnil; else - return make_number (done_glyphs); + return make_fixnum (done_glyphs); } /* Uniscribe implementation of encode_char for font backend. @@ -879,7 +880,7 @@ uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec) int i, retval = 0; /* Check the spec is in the right format. */ - if (!CONSP (otf_spec) || XINT (Flength (otf_spec)) < 3) + if (!CONSP (otf_spec) || XFIXNUM (Flength (otf_spec)) < 3) return 0; /* Break otf_spec into its components. */ @@ -1194,11 +1195,11 @@ syms_of_w32uniscribe (void) register_font_driver (&uniscribe_font_driver, NULL); script_get_font_scripts_fn = (ScriptGetFontScriptTags_Proc) - GetProcAddress (uniscribe, "ScriptGetFontScriptTags"); + get_proc_addr (uniscribe, "ScriptGetFontScriptTags"); script_get_font_languages_fn = (ScriptGetFontLanguageTags_Proc) - GetProcAddress (uniscribe, "ScriptGetFontLanguageTags"); + get_proc_addr (uniscribe, "ScriptGetFontLanguageTags"); script_get_font_features_fn = (ScriptGetFontFeatureTags_Proc) - GetProcAddress (uniscribe, "ScriptGetFontFeatureTags"); + get_proc_addr (uniscribe, "ScriptGetFontFeatureTags"); if (script_get_font_scripts_fn && script_get_font_languages_fn && script_get_font_features_fn) diff --git a/src/widget.c b/src/widget.c index 5abb3c229b4..9db33168a2a 100644 --- a/src/widget.c +++ b/src/widget.c @@ -282,7 +282,7 @@ set_frame_size (EmacsFrame ew) frame_size_history_add (f, Qset_frame_size, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), - list2 (make_number (ew->core.width), make_number (ew->core.height))); + list2 (make_fixnum (ew->core.width), make_fixnum (ew->core.height))); } static void @@ -421,10 +421,10 @@ EmacsFrameResize (Widget widget) frame_size_history_add (f, QEmacsFrameResize, width, height, - list5 (make_number (ew->core.width), make_number (ew->core.height), - make_number (FRAME_TOP_MARGIN_HEIGHT (f)), - make_number (FRAME_SCROLL_BAR_AREA_HEIGHT (f)), - make_number (2 * FRAME_INTERNAL_BORDER_WIDTH (f)))); + list5 (make_fixnum (ew->core.width), make_fixnum (ew->core.height), + make_fixnum (FRAME_TOP_MARGIN_HEIGHT (f)), + make_fixnum (FRAME_SCROLL_BAR_AREA_HEIGHT (f)), + make_fixnum (2 * FRAME_INTERNAL_BORDER_WIDTH (f)))); change_frame_size (f, width, height, 0, 1, 0, 1); diff --git a/src/window.c b/src/window.c index 148200d5f53..cad36c840ae 100644 --- a/src/window.c +++ b/src/window.c @@ -695,7 +695,7 @@ one. The window with the lowest use time is the least recently selected one. */) (Lisp_Object window) { - return make_number (decode_live_window (window)->use_time); + return make_fixnum (decode_live_window (window)->use_time); } DEFUN ("window-pixel-width", Fwindow_pixel_width, Swindow_pixel_width, 0, 1, 0, @@ -708,7 +708,7 @@ an internal window, its pixel width is the width of the screen areas spanned by its children. */) (Lisp_Object window) { - return make_number (decode_valid_window (window)->pixel_width); + return make_fixnum (decode_valid_window (window)->pixel_width); } DEFUN ("window-pixel-height", Fwindow_pixel_height, Swindow_pixel_height, 0, 1, 0, @@ -720,7 +720,7 @@ divider, if any. If WINDOW is an internal window, its pixel height is the height of the screen areas spanned by its children. */) (Lisp_Object window) { - return make_number (decode_valid_window (window)->pixel_height); + return make_fixnum (decode_valid_window (window)->pixel_height); } DEFUN ("window-pixel-width-before-size-change", @@ -734,7 +734,7 @@ The return value is the pixel width of WINDOW at the last time after that. */) (Lisp_Object window) { - return (make_number + return (make_fixnum (decode_valid_window (window)->pixel_width_before_size_change)); } @@ -749,7 +749,7 @@ The return value is the pixel height of WINDOW at the last time after that. */) (Lisp_Object window) { - return (make_number + return (make_fixnum (decode_valid_window (window)->pixel_height_before_size_change)); } @@ -778,12 +778,12 @@ total height of WINDOW. */) struct window *w = decode_valid_window (window); if (! EQ (round, Qfloor) && ! EQ (round, Qceiling)) - return make_number (w->total_lines); + return make_fixnum (w->total_lines); else { int unit = FRAME_LINE_HEIGHT (WINDOW_XFRAME (w)); - return make_number (EQ (round, Qceiling) + return make_fixnum (EQ (round, Qceiling) ? ((w->pixel_height + unit - 1) /unit) : (w->pixel_height / unit)); } @@ -815,12 +815,12 @@ total width of WINDOW. */) struct window *w = decode_valid_window (window); if (! EQ (round, Qfloor) && ! EQ (round, Qceiling)) - return make_number (w->total_cols); + return make_fixnum (w->total_cols); else { int unit = FRAME_COLUMN_WIDTH (WINDOW_XFRAME (w)); - return make_number (EQ (round, Qceiling) + return make_fixnum (EQ (round, Qceiling) ? ((w->pixel_width + unit - 1) /unit) : (w->pixel_width / unit)); } @@ -898,7 +898,7 @@ DEFUN ("window-pixel-left", Fwindow_pixel_left, Swindow_pixel_left, 0, 1, 0, WINDOW must be a valid window and defaults to the selected one. */) (Lisp_Object window) { - return make_number (decode_valid_window (window)->pixel_left); + return make_fixnum (decode_valid_window (window)->pixel_left); } DEFUN ("window-pixel-top", Fwindow_pixel_top, Swindow_pixel_top, 0, 1, 0, @@ -906,7 +906,7 @@ DEFUN ("window-pixel-top", Fwindow_pixel_top, Swindow_pixel_top, 0, 1, 0, WINDOW must be a valid window and defaults to the selected one. */) (Lisp_Object window) { - return make_number (decode_valid_window (window)->pixel_top); + return make_fixnum (decode_valid_window (window)->pixel_top); } DEFUN ("window-left-column", Fwindow_left_column, Swindow_left_column, 0, 1, 0, @@ -918,7 +918,7 @@ value is 0 if there is no window to the left of WINDOW. WINDOW must be a valid window and defaults to the selected one. */) (Lisp_Object window) { - return make_number (decode_valid_window (window)->left_col); + return make_fixnum (decode_valid_window (window)->left_col); } DEFUN ("window-top-line", Fwindow_top_line, Swindow_top_line, 0, 1, 0, @@ -930,7 +930,7 @@ there is no window above WINDOW. WINDOW must be a valid window and defaults to the selected one. */) (Lisp_Object window) { - return make_number (decode_valid_window (window)->top_line); + return make_fixnum (decode_valid_window (window)->top_line); } /* Return the number of lines/pixels of W's body. Don't count any mode @@ -997,7 +997,7 @@ means that if a line at the bottom of the text area is only partially visible, that line is not counted. */) (Lisp_Object window, Lisp_Object pixelwise) { - return make_number (window_body_height (decode_live_window (window), + return make_fixnum (window_body_height (decode_live_window (window), !NILP (pixelwise))); } @@ -1017,7 +1017,7 @@ Note that the returned value includes the column reserved for the continuation glyph. */) (Lisp_Object window, Lisp_Object pixelwise) { - return make_number (window_body_width (decode_live_window (window), + return make_fixnum (window_body_width (decode_live_window (window), !NILP (pixelwise))); } @@ -1027,7 +1027,7 @@ DEFUN ("window-mode-line-height", Fwindow_mode_line_height, WINDOW must be a live window and defaults to the selected one. */) (Lisp_Object window) { - return (make_number (WINDOW_MODE_LINE_HEIGHT (decode_live_window (window)))); + return (make_fixnum (WINDOW_MODE_LINE_HEIGHT (decode_live_window (window)))); } DEFUN ("window-header-line-height", Fwindow_header_line_height, @@ -1036,7 +1036,7 @@ DEFUN ("window-header-line-height", Fwindow_header_line_height, WINDOW must be a live window and defaults to the selected one. */) (Lisp_Object window) { - return (make_number (WINDOW_HEADER_LINE_HEIGHT (decode_live_window (window)))); + return (make_fixnum (WINDOW_HEADER_LINE_HEIGHT (decode_live_window (window)))); } DEFUN ("window-right-divider-width", Fwindow_right_divider_width, @@ -1045,7 +1045,7 @@ DEFUN ("window-right-divider-width", Fwindow_right_divider_width, WINDOW must be a live window and defaults to the selected one. */) (Lisp_Object window) { - return (make_number (WINDOW_RIGHT_DIVIDER_WIDTH (decode_live_window (window)))); + return (make_fixnum (WINDOW_RIGHT_DIVIDER_WIDTH (decode_live_window (window)))); } DEFUN ("window-bottom-divider-width", Fwindow_bottom_divider_width, @@ -1054,7 +1054,7 @@ DEFUN ("window-bottom-divider-width", Fwindow_bottom_divider_width, WINDOW must be a live window and defaults to the selected one. */) (Lisp_Object window) { - return (make_number (WINDOW_BOTTOM_DIVIDER_WIDTH (decode_live_window (window)))); + return (make_fixnum (WINDOW_BOTTOM_DIVIDER_WIDTH (decode_live_window (window)))); } DEFUN ("window-scroll-bar-width", Fwindow_scroll_bar_width, @@ -1063,7 +1063,7 @@ DEFUN ("window-scroll-bar-width", Fwindow_scroll_bar_width, WINDOW must be a live window and defaults to the selected one. */) (Lisp_Object window) { - return (make_number (WINDOW_SCROLL_BAR_AREA_WIDTH (decode_live_window (window)))); + return (make_fixnum (WINDOW_SCROLL_BAR_AREA_WIDTH (decode_live_window (window)))); } DEFUN ("window-scroll-bar-height", Fwindow_scroll_bar_height, @@ -1072,7 +1072,7 @@ DEFUN ("window-scroll-bar-height", Fwindow_scroll_bar_height, WINDOW must be a live window and defaults to the selected one. */) (Lisp_Object window) { - return (make_number (WINDOW_SCROLL_BAR_AREA_HEIGHT (decode_live_window (window)))); + return (make_fixnum (WINDOW_SCROLL_BAR_AREA_HEIGHT (decode_live_window (window)))); } DEFUN ("window-hscroll", Fwindow_hscroll, Swindow_hscroll, 0, 1, 0, @@ -1080,7 +1080,7 @@ DEFUN ("window-hscroll", Fwindow_hscroll, Swindow_hscroll, 0, 1, 0, WINDOW must be a live window and defaults to the selected one. */) (Lisp_Object window) { - return make_number (decode_live_window (window)->hscroll); + return make_fixnum (decode_live_window (window)->hscroll); } /* Set W's horizontal scroll amount to HSCROLL clipped to a reasonable @@ -1104,7 +1104,7 @@ set_window_hscroll (struct window *w, EMACS_INT hscroll) w->hscroll = new_hscroll; w->suspend_auto_hscroll = true; - return make_number (new_hscroll); + return make_fixnum (new_hscroll); } DEFUN ("set-window-hscroll", Fset_window_hscroll, Sset_window_hscroll, 2, 2, 0, @@ -1117,8 +1117,8 @@ Note that if `automatic-hscrolling' is non-nil, you cannot scroll the window so that the location of point moves off-window. */) (Lisp_Object window, Lisp_Object ncol) { - CHECK_NUMBER (ncol); - return set_window_hscroll (decode_live_window (window), XINT (ncol)); + CHECK_FIXNUM (ncol); + return set_window_hscroll (decode_live_window (window), XFIXNUM (ncol)); } DEFUN ("window-redisplay-end-trigger", Fwindow_redisplay_end_trigger, @@ -1383,8 +1383,8 @@ If they are in the windows's left or right marginal areas, `left-margin'\n\ CHECK_CONS (coordinates); lx = Fcar (coordinates); ly = Fcdr (coordinates); - CHECK_NUMBER_OR_FLOAT (lx); - CHECK_NUMBER_OR_FLOAT (ly); + CHECK_NUMBER (lx); + CHECK_NUMBER (ly); x = FRAME_PIXEL_X_FROM_CANON_X (f, lx) + FRAME_INTERNAL_BORDER_WIDTH (f); y = FRAME_PIXEL_Y_FROM_CANON_Y (f, ly) + FRAME_INTERNAL_BORDER_WIDTH (f); @@ -1533,9 +1533,8 @@ column 0. */) { struct frame *f = decode_live_frame (frame); - /* Check that arguments are integers or floats. */ - CHECK_NUMBER_OR_FLOAT (x); - CHECK_NUMBER_OR_FLOAT (y); + CHECK_NUMBER (x); + CHECK_NUMBER (y); return window_from_coordinates (f, (FRAME_PIXEL_X_FROM_CANON_X (f, x) @@ -1561,7 +1560,7 @@ correct to return the top-level value of `point', outside of any register struct window *w = decode_live_window (window); if (w == XWINDOW (selected_window)) - return make_number (BUF_PT (XBUFFER (w->contents))); + return make_fixnum (BUF_PT (XBUFFER (w->contents))); else return Fmarker_position (w->pointm); } @@ -1652,7 +1651,7 @@ if it isn't already recorded. */) move_it_vertically (&it, window_box_height (w)); if (it.current_y < it.last_visible_y) move_it_past_eol (&it); - value = make_number (IT_CHARPOS (it)); + value = make_fixnum (IT_CHARPOS (it)); bidi_unshelve_cache (itdata, false); if (old_buffer) @@ -1683,7 +1682,7 @@ Return POS. */) struct buffer *old_buffer = current_buffer; /* ... but here we want to catch type error before buffer change. */ - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); set_buffer_internal (XBUFFER (w->contents)); Fgoto_char (pos); set_buffer_internal (old_buffer); @@ -1763,8 +1762,8 @@ POS, ROWH is the visible height of that row, and VPOS is the row number posint = -1; else if (!NILP (pos)) { - CHECK_NUMBER_COERCE_MARKER (pos); - posint = XINT (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); + posint = XFIXNUM (pos); } else if (w == XWINDOW (selected_window)) posint = PT; @@ -1789,8 +1788,8 @@ POS, ROWH is the visible height of that row, and VPOS is the row number Lisp_Object part = Qnil; if (!fully_p) part = list4i (rtop, rbot, rowh, vpos); - in_window = Fcons (make_number (x), - Fcons (make_number (y), part)); + in_window = Fcons (make_fixnum (x), + Fcons (make_fixnum (y), part)); } return in_window; @@ -1869,8 +1868,8 @@ Return nil if window display is not up-to-date. In that case, use : Qnil); } - CHECK_NUMBER (line); - n = XINT (line); + CHECK_FIXNUM (line); + n = XFIXNUM (line); row = MATRIX_FIRST_TEXT_ROW (w->current_matrix); end_row = MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w); @@ -1972,10 +1971,10 @@ though when run from an idle timer with a delay of zero seconds. */) row = (NILP (body) ? MATRIX_ROW (w->current_matrix, 0) : MATRIX_FIRST_TEXT_ROW (w->current_matrix)); - else if (NUMBERP (first)) + else if (FIXNUMP (first)) { CHECK_RANGED_INTEGER (first, 0, w->current_matrix->nrows); - row = MATRIX_ROW (w->current_matrix, XINT (first)); + row = MATRIX_ROW (w->current_matrix, XFIXNUM (first)); } else error ("Invalid specification of first line"); @@ -1985,10 +1984,10 @@ though when run from an idle timer with a delay of zero seconds. */) end_row = (NILP (body) ? MATRIX_ROW (w->current_matrix, w->current_matrix->nrows) : MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w)); - else if (NUMBERP (last)) + else if (FIXNUMP (last)) { CHECK_RANGED_INTEGER (last, 0, w->current_matrix->nrows); - end_row = MATRIX_ROW (w->current_matrix, XINT (last)); + end_row = MATRIX_ROW (w->current_matrix, XFIXNUM (last)); } else error ("Invalid specification of last line"); @@ -2001,19 +2000,19 @@ though when run from an idle timer with a delay of zero seconds. */) { struct glyph *glyph = row->glyphs[TEXT_AREA]; - rows = Fcons (Fcons (make_number + rows = Fcons (Fcons (make_fixnum (invert ? glyph->pixel_width : window_width - glyph->pixel_width), - make_number (row->y + row->height - subtract)), + make_fixnum (row->y + row->height - subtract)), rows); } else - rows = Fcons (Fcons (make_number + rows = Fcons (Fcons (make_fixnum (invert ? window_width - row->pixel_width : row->pixel_width), - make_number (row->y + row->height - subtract)), + make_fixnum (row->y + row->height - subtract)), rows); row++; } @@ -2492,7 +2491,7 @@ candidate_window_p (Lisp_Object window, Lisp_Object owindow, == FRAME_TERMINAL (XFRAME (selected_frame))); } - else if (INTEGERP (all_frames) && XINT (all_frames) == 0) + else if (FIXNUMP (all_frames) && XFIXNUM (all_frames) == 0) { candidate_p = (FRAME_VISIBLE_P (f) || FRAME_ICONIFIED_P (f) #ifdef HAVE_X_WINDOWS @@ -2551,7 +2550,7 @@ decode_next_window_args (Lisp_Object *window, Lisp_Object *minibuf, Lisp_Object : Qnil); else if (EQ (*all_frames, Qvisible)) ; - else if (EQ (*all_frames, make_number (0))) + else if (EQ (*all_frames, make_fixnum (0))) ; else if (FRAMEP (*all_frames)) ; @@ -2834,7 +2833,7 @@ window_loop (enum window_loop type, Lisp_Object obj, bool mini, if (f) frame_arg = Qlambda; - else if (EQ (frames, make_number (0))) + else if (EQ (frames, make_fixnum (0))) frame_arg = frames; else if (EQ (frames, Qvisible)) frame_arg = frames; @@ -3443,7 +3442,11 @@ 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 (NILP (Vrun_hooks) + || !(f->can_x_set_window_size) + || !(f->after_make_frame)) + return; if (FRAME_WINDOW_CONFIGURATION_CHANGED (f) /* Here we implicitly exclude the possibility that the height of @@ -3451,11 +3454,44 @@ run_window_size_change_functions (Lisp_Object frame) of FRAME's root window alone. */ || window_size_changed (r)) { - while (CONSP (functions)) + Lisp_Object globals = Fdefault_value (Qwindow_size_change_functions); + Lisp_Object windows = Fwindow_list (frame, Qlambda, Qnil); + /* The buffers for which the local hook was already run. */ + Lisp_Object buffers = Qnil; + + for (; CONSP (windows); windows = XCDR (windows)) + { + Lisp_Object window = XCAR (windows); + Lisp_Object buffer = Fwindow_buffer (window); + + /* Run a buffer-local value only once for that buffer and + only if at least one window showing that buffer on FRAME + actually changed its size. Note that the function is run + with FRAME as its argument and as such oblivious to the + window checked below. */ + if (window_size_changed (XWINDOW (window)) + && !NILP (Flocal_variable_p (Qwindow_size_change_functions, buffer)) + && NILP (Fmemq (buffer, buffers))) + { + Lisp_Object locals + = Fbuffer_local_value (Qwindow_size_change_functions, buffer); + + while (CONSP (locals)) + { + if (!EQ (XCAR (locals), Qt)) + safe_call1 (XCAR (locals), frame); + locals = XCDR (locals); + } + + buffers = Fcons (buffer, buffers); + } + } + + while (CONSP (globals)) { - if (!EQ (XCAR (functions), Qt)) - safe_call1 (XCAR (functions), frame); - functions = XCDR (functions); + if (!EQ (XCAR (globals), Qt)) + safe_call1 (XCAR (globals), frame); + globals = XCDR (globals); } window_set_before_size_change_sizes (r); @@ -3494,8 +3530,8 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, b->display_error_modiff = 0; /* Update time stamps of buffer display. */ - if (INTEGERP (BVAR (b, display_count))) - bset_display_count (b, make_number (XINT (BVAR (b, display_count)) + 1)); + if (FIXNUMP (BVAR (b, display_count))) + bset_display_count (b, make_fixnum (XFIXNUM (BVAR (b, display_count)) + 1)); bset_display_time (b, Fcurrent_time ()); w->window_end_pos = 0; @@ -3513,7 +3549,7 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, set_marker_both (w->pointm, buffer, BUF_PT (b), BUF_PT_BYTE (b)); set_marker_both (w->old_pointm, buffer, BUF_PT (b), BUF_PT_BYTE (b)); set_marker_restricted (w->start, - make_number (b->last_window_start), + make_fixnum (b->last_window_start), buffer); w->start_at_line_beg = false; w->force_start = false; @@ -3769,9 +3805,9 @@ make_window (void) Lisp data to nil, so do it only for slots which should not be nil. */ wset_normal_lines (w, make_float (1.0)); wset_normal_cols (w, make_float (1.0)); - wset_new_total (w, make_number (0)); - wset_new_normal (w, make_number (0)); - wset_new_pixel (w, make_number (0)); + wset_new_total (w, make_fixnum (0)); + wset_new_normal (w, make_fixnum (0)); + wset_new_pixel (w, make_fixnum (0)); wset_start (w, Fmake_marker ()); wset_pointm (w, Fmake_marker ()); wset_old_pointm (w, Fmake_marker ()); @@ -3820,14 +3856,14 @@ Note: This function does not operate on any child windows of WINDOW. */) (Lisp_Object window, Lisp_Object size, Lisp_Object add) { struct window *w = decode_valid_window (window); - EMACS_INT size_min = NILP (add) ? 0 : - XINT (w->new_pixel); + EMACS_INT size_min = NILP (add) ? 0 : - XFIXNUM (w->new_pixel); EMACS_INT size_max = size_min + min (INT_MAX, MOST_POSITIVE_FIXNUM); CHECK_RANGED_INTEGER (size, size_min, size_max); if (NILP (add)) wset_new_pixel (w, size); else - wset_new_pixel (w, make_number (XINT (w->new_pixel) + XINT (size))); + wset_new_pixel (w, make_fixnum (XFIXNUM (w->new_pixel) + XFIXNUM (size))); return w->new_pixel; } @@ -3849,11 +3885,11 @@ Note: This function does not operate on any child windows of WINDOW. */) { struct window *w = decode_valid_window (window); - CHECK_NUMBER (size); + CHECK_FIXNUM (size); if (NILP (add)) wset_new_total (w, size); else - wset_new_total (w, make_number (XINT (w->new_total) + XINT (size))); + wset_new_total (w, make_fixnum (XFIXNUM (w->new_total) + XFIXNUM (size))); return w->new_total; } @@ -3895,7 +3931,7 @@ window_resize_check (struct window *w, bool horflag) { while (c) { - if (XINT (c->new_pixel) != XINT (w->new_pixel) + if (XFIXNUM (c->new_pixel) != XFIXNUM (w->new_pixel) || !window_resize_check (c, horflag)) return false; @@ -3908,14 +3944,14 @@ window_resize_check (struct window *w, bool horflag) /* The sum of the heights of the child windows of W must equal W's height. */ { - int remaining_pixels = XINT (w->new_pixel); + int remaining_pixels = XFIXNUM (w->new_pixel); while (c) { if (!window_resize_check (c, horflag)) return false; - remaining_pixels -= XINT (c->new_pixel); + remaining_pixels -= XFIXNUM (c->new_pixel); if (remaining_pixels < 0) return false; c = NILP (c->next) ? 0 : XWINDOW (c->next); @@ -3932,14 +3968,14 @@ window_resize_check (struct window *w, bool horflag) /* The sum of the widths of the child windows of W must equal W's width. */ { - int remaining_pixels = XINT (w->new_pixel); + int remaining_pixels = XFIXNUM (w->new_pixel); while (c) { if (!window_resize_check (c, horflag)) return false; - remaining_pixels -= XINT (c->new_pixel); + remaining_pixels -= XFIXNUM (c->new_pixel); if (remaining_pixels < 0) return false; c = NILP (c->next) ? 0 : XWINDOW (c->next); @@ -3952,7 +3988,7 @@ window_resize_check (struct window *w, bool horflag) { while (c) { - if (XINT (c->new_pixel) != XINT (w->new_pixel) + if (XFIXNUM (c->new_pixel) != XFIXNUM (w->new_pixel) || !window_resize_check (c, horflag)) return false; @@ -3966,7 +4002,7 @@ window_resize_check (struct window *w, bool horflag) /* A leaf window. Make sure it's not too small. The following hardcodes the values of `window-safe-min-width' (2) and `window-safe-min-height' (1) which are defined in window.el. */ - return (XINT (w->new_pixel) >= (horflag + return (XFIXNUM (w->new_pixel) >= (horflag ? (2 * FRAME_COLUMN_WIDTH (f)) : FRAME_LINE_HEIGHT (f))); } @@ -3992,7 +4028,7 @@ window_resize_apply (struct window *w, bool horflag) parent window has been set *before*. */ if (horflag) { - w->pixel_width = XFASTINT (w->new_pixel); + w->pixel_width = XFIXNAT (w->new_pixel); w->total_cols = w->pixel_width / unit; if (NUMBERP (w->new_normal)) wset_normal_cols (w, w->new_normal); @@ -4001,7 +4037,7 @@ window_resize_apply (struct window *w, bool horflag) } else { - w->pixel_height = XFASTINT (w->new_pixel); + w->pixel_height = XFIXNAT (w->new_pixel); w->total_lines = w->pixel_height / unit; if (NUMBERP (w->new_normal)) wset_normal_lines (w, w->new_normal); @@ -4076,12 +4112,12 @@ window_resize_apply_total (struct window *w, bool horflag) parent window has been set *before*. */ if (horflag) { - w->total_cols = XFASTINT (w->new_total); + w->total_cols = XFIXNAT (w->new_total); edge = w->left_col; } else { - w->total_lines = XFASTINT (w->new_total); + w->total_lines = XFIXNAT (w->new_total); edge = w->top_line; } @@ -4149,7 +4185,7 @@ be applied on the Elisp level. */) bool horflag = !NILP (horizontal); if (!window_resize_check (r, horflag) - || (XINT (r->new_pixel) + || (XFIXNUM (r->new_pixel) != (horflag ? r->pixel_width : r->pixel_height))) return Qnil; @@ -4193,10 +4229,10 @@ values. */) if (NILP (horizontal)) { m->top_line = r->top_line + r->total_lines; - m->total_lines = XFASTINT (m->new_total); + m->total_lines = XFIXNAT (m->new_total); } else - m->total_cols = XFASTINT (m->new_total); + m->total_cols = XFIXNAT (m->new_total); } unblock_input (); @@ -4286,7 +4322,7 @@ resize_frame_windows (struct frame *f, int size, bool horflag, bool pixelwise) resize_root_window (root, delta, horflag ? Qt : Qnil, Qnil, pixelwise ? Qt : Qnil); if (window_resize_check (r, horflag) - && new_pixel_size == XINT (r->new_pixel)) + && new_pixel_size == XFIXNUM (r->new_pixel)) { window_resize_apply (r, horflag); window_pixel_to_total (r->frame, horflag ? Qt : Qnil); @@ -4297,7 +4333,7 @@ resize_frame_windows (struct frame *f, int size, bool horflag, bool pixelwise) resize_root_window (root, delta, horflag ? Qt : Qnil, Qt, pixelwise ? Qt : Qnil); if (window_resize_check (r, horflag) - && new_pixel_size == XINT (r->new_pixel)) + && new_pixel_size == XFIXNUM (r->new_pixel)) { window_resize_apply (r, horflag); window_pixel_to_total (r->frame, horflag ? Qt : Qnil); @@ -4369,9 +4405,9 @@ set correctly. See the code of `split-window' for how this is done. */) frame = WINDOW_FRAME (o); f = XFRAME (frame); - CHECK_NUMBER (pixel_size); + CHECK_FIXNUM (pixel_size); EMACS_INT total_size - = XINT (pixel_size) / (horflag + = XFIXNUM (pixel_size) / (horflag ? FRAME_COLUMN_WIDTH (f) : FRAME_LINE_HEIGHT (f)); @@ -4406,19 +4442,19 @@ set correctly. See the code of `split-window' for how this is done. */) p = XWINDOW (o->parent); /* Temporarily pretend we split the parent window. */ wset_new_pixel - (p, make_number ((horflag ? p->pixel_width : p->pixel_height) - - XINT (pixel_size))); + (p, make_fixnum ((horflag ? p->pixel_width : p->pixel_height) + - XFIXNUM (pixel_size))); if (!window_resize_check (p, horflag)) error ("Window sizes don't fit"); else /* Undo the temporary pretension. */ - wset_new_pixel (p, make_number (horflag ? p->pixel_width : p->pixel_height)); + wset_new_pixel (p, make_fixnum (horflag ? p->pixel_width : p->pixel_height)); } else { if (!window_resize_check (o, horflag)) error ("Resizing old window failed"); - else if (XINT (pixel_size) + XINT (o->new_pixel) + else if (XFIXNUM (pixel_size) + XFIXNUM (o->new_pixel) != (horflag ? o->pixel_width : o->pixel_height)) error ("Sum of sizes of old and new window don't fit"); } @@ -4440,9 +4476,9 @@ set correctly. See the code of `split-window' for how this is done. */) wset_combination_limit (p, Qt); /* These get applied below. */ wset_new_pixel - (p, make_number (horflag ? o->pixel_width : o->pixel_height)); + (p, make_fixnum (horflag ? o->pixel_width : o->pixel_height)); wset_new_total - (p, make_number (horflag ? o->total_cols : o->total_lines)); + (p, make_fixnum (horflag ? o->total_cols : o->total_lines)); wset_new_normal (p, new_normal); } else @@ -4511,10 +4547,10 @@ set correctly. See the code of `split-window' for how this is done. */) while (c) { if (c != n) - sum = sum + XINT (c->new_total); + sum = sum + XFIXNUM (c->new_total); c = NILP (c->next) ? 0 : XWINDOW (c->next); } - wset_new_total (n, make_number ((horflag + wset_new_total (n, make_fixnum ((horflag ? p->total_cols : p->total_lines) - sum)); @@ -4596,7 +4632,7 @@ Signal an error when WINDOW is the only window on its frame. */) } if (window_resize_check (r, horflag) - && (XINT (r->new_pixel) + && (XFIXNUM (r->new_pixel) == (horflag ? r->pixel_width : r->pixel_height))) /* We can delete WINDOW now. */ { @@ -4727,20 +4763,20 @@ 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, - root, make_number (- delta), pixelwise ? Qt : Qnil); - if (INTEGERP (height) && window_resize_check (r, false)) + root, make_fixnum (- delta), pixelwise ? Qt : Qnil); + if (FIXNUMP (height) && window_resize_check (r, false)) { block_input (); window_resize_apply (r, false); if (pixelwise) { - pixel_height = min (-XINT (height), INT_MAX - w->pixel_height); + pixel_height = min (-XFIXNUM (height), INT_MAX - w->pixel_height); line_height = pixel_height / FRAME_LINE_HEIGHT (f); } else { - line_height = min (-XINT (height), + line_height = min (-XFIXNUM (height), ((INT_MAX - w->pixel_height) / FRAME_LINE_HEIGHT (f))); pixel_height = line_height * FRAME_LINE_HEIGHT (f); @@ -4784,9 +4820,9 @@ shrink_mini_window (struct window *w, bool pixelwise) root = FRAME_ROOT_WINDOW (f); r = XWINDOW (root); delta = call3 (Qwindow__resize_root_window_vertically, - root, make_number (height - unit), + root, make_fixnum (height - unit), pixelwise ? Qt : Qnil); - if (INTEGERP (delta) && window_resize_check (r, false)) + if (FIXNUMP (delta) && window_resize_check (r, false)) { block_input (); window_resize_apply (r, false); @@ -4831,13 +4867,13 @@ DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal, Sresize_mini r = XWINDOW (FRAME_ROOT_WINDOW (f)); height = r->pixel_height + w->pixel_height; if (window_resize_check (r, false) - && XINT (w->new_pixel) > 0 - && height == XINT (r->new_pixel) + XINT (w->new_pixel)) + && XFIXNUM (w->new_pixel) > 0 + && height == XFIXNUM (r->new_pixel) + XFIXNUM (w->new_pixel)) { block_input (); window_resize_apply (r, false); - w->pixel_height = XFASTINT (w->new_pixel); + w->pixel_height = XFIXNAT (w->new_pixel); w->total_lines = w->pixel_height / FRAME_LINE_HEIGHT (f); w->pixel_top = r->pixel_top + r->pixel_height; w->top_line = r->top_line + r->total_lines; @@ -5101,7 +5137,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) if (w->vscroll < 0 && rtop > 0) { px = max (0, -w->vscroll - min (rtop, -dy)); - Fset_window_vscroll (window, make_number (px), Qt); + Fset_window_vscroll (window, make_fixnum (px), Qt); return; } } @@ -5111,7 +5147,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) if (rbot > 0 && (w->vscroll < 0 || vpos == 0)) { px = max (0, -w->vscroll + min (rbot, dy)); - Fset_window_vscroll (window, make_number (px), Qt); + Fset_window_vscroll (window, make_fixnum (px), Qt); return; } @@ -5120,14 +5156,14 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) { ptrdiff_t spos; - Fset_window_vscroll (window, make_number (0), Qt); + Fset_window_vscroll (window, make_fixnum (0), Qt); /* If there are other text lines above the current row, move window start to current row. Else to next row. */ if (rbot > 0) - spos = XINT (Fline_beginning_position (Qnil)); + spos = XFIXNUM (Fline_beginning_position (Qnil)); else - spos = min (XINT (Fline_end_position (Qnil)) + 1, ZV); - set_marker_restricted (w->start, make_number (spos), + spos = min (XFIXNUM (Fline_end_position (Qnil)) + 1, ZV); + set_marker_restricted (w->start, make_fixnum (spos), w->contents); w->start_at_line_beg = true; wset_update_mode_line (w); @@ -5139,7 +5175,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) } } /* Cancel previous vscroll. */ - Fset_window_vscroll (window, make_number (0), Qt); + Fset_window_vscroll (window, make_fixnum (0), Qt); } itdata = bidi_shelve_cache (); @@ -5444,7 +5480,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) if (adjust_old_pointm) Fset_marker (w->old_pointm, ((w == XWINDOW (selected_window)) - ? make_number (BUF_PT (XBUFFER (w->contents))) + ? make_fixnum (BUF_PT (XBUFFER (w->contents))) : Fmarker_position (w->pointm)), w->contents); } @@ -5493,8 +5529,8 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) window_scroll_preserve_hpos = posit.hpos + w->hscroll; } - original_pos = Fcons (make_number (window_scroll_preserve_hpos), - make_number (window_scroll_preserve_vpos)); + original_pos = Fcons (make_fixnum (window_scroll_preserve_hpos), + make_fixnum (window_scroll_preserve_vpos)); } XSETFASTINT (tem, PT); @@ -5502,14 +5538,14 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) if (NILP (tem)) { - Fvertical_motion (make_number (- (ht / 2)), window, Qnil); + Fvertical_motion (make_fixnum (- (ht / 2)), window, Qnil); startpos = PT; startbyte = PT_BYTE; } SET_PT_BOTH (startpos, startbyte); lose = n < 0 && PT == BEGV; - Fvertical_motion (make_number (n), window, Qnil); + Fvertical_motion (make_fixnum (n), window, Qnil); pos = PT; pos_byte = PT_BYTE; bolp = Fbolp (); @@ -5551,7 +5587,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) if (this_scroll_margin > 0) { SET_PT_BOTH (pos, pos_byte); - Fvertical_motion (make_number (this_scroll_margin), window, Qnil); + Fvertical_motion (make_fixnum (this_scroll_margin), window, Qnil); top_margin = PT; } else @@ -5570,8 +5606,8 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) else if (window_scroll_preserve_vpos >= w->total_lines - this_scroll_margin) nlines = w->total_lines - this_scroll_margin - 1; - Fvertical_motion (Fcons (make_number (window_scroll_preserve_hpos), - make_number (nlines)), window, Qnil); + Fvertical_motion (Fcons (make_fixnum (window_scroll_preserve_hpos), + make_fixnum (nlines)), window, Qnil); } else SET_PT (top_margin); @@ -5583,9 +5619,9 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) /* If we scrolled backward, put point near the end of the window but not within the scroll margin. */ SET_PT_BOTH (pos, pos_byte); - tem = Fvertical_motion (make_number (ht - this_scroll_margin), window, + tem = Fvertical_motion (make_fixnum (ht - this_scroll_margin), window, Qnil); - if (XFASTINT (tem) == ht - this_scroll_margin) + if (XFIXNAT (tem) == ht - this_scroll_margin) bottom_margin = PT; else bottom_margin = PT + 1; @@ -5605,11 +5641,11 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) else if (window_scroll_preserve_vpos >= ht - this_scroll_margin) nlines = ht - this_scroll_margin - 1; - Fvertical_motion (Fcons (make_number (window_scroll_preserve_hpos), - make_number (nlines)), window, Qnil); + Fvertical_motion (Fcons (make_fixnum (window_scroll_preserve_hpos), + make_fixnum (nlines)), window, Qnil); } else - Fvertical_motion (make_number (-1), window, Qnil); + Fvertical_motion (make_fixnum (-1), window, Qnil); } } } @@ -5624,41 +5660,65 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) if (adjust_old_pointm) Fset_marker (w->old_pointm, ((w == XWINDOW (selected_window)) - ? make_number (BUF_PT (XBUFFER (w->contents))) + ? make_fixnum (BUF_PT (XBUFFER (w->contents))) : Fmarker_position (w->pointm)), w->contents); } -/* Scroll selected_window up or down. If N is nil, scroll a +/* Scroll WINDOW up or down. If N is nil, scroll upward by a screen-full which is defined as the height of the window minus - next_screen_context_lines. If N is the symbol `-', scroll. - DIRECTION may be 1 meaning to scroll down, or -1 meaning to scroll - up. This is the guts of Fscroll_up and Fscroll_down. */ + next_screen_context_lines. If N is the symbol `-', scroll downward + by a screen-full. DIRECTION may be 1 meaning to scroll down, or -1 + meaning to scroll up. */ static void -scroll_command (Lisp_Object n, int direction) +scroll_command (Lisp_Object window, Lisp_Object n, int direction) { + struct window *w; + bool other_window; ptrdiff_t count = SPECPDL_INDEX (); eassert (eabs (direction) == 1); - /* If selected window's buffer isn't current, make it current for - the moment. But don't screw up if window_scroll gets an error. */ - if (XBUFFER (XWINDOW (selected_window)->contents) != current_buffer) + w = XWINDOW (window); + other_window = ! EQ (window, selected_window); + + /* If given window's buffer isn't current, make it current for the + moment. If the window's buffer is the same, but it is not the + selected window, we need to save-excursion to avoid affecting + point in the selected window (which would cause the selected + window to scroll). Don't screw up if window_scroll gets an + error. */ + if (other_window || XBUFFER (w->contents) != current_buffer) { - record_unwind_protect (save_excursion_restore, save_excursion_save ()); - Fset_buffer (XWINDOW (selected_window)->contents); + record_unwind_protect_excursion (); + if (XBUFFER (w->contents) != current_buffer) + Fset_buffer (w->contents); + } + + if (other_window) + { + SET_PT_BOTH (marker_position (w->pointm), + marker_byte_position (w->pointm)); + SET_PT_BOTH (marker_position (w->old_pointm), + marker_byte_position (w->old_pointm)); } if (NILP (n)) - window_scroll (selected_window, direction, true, false); + window_scroll (window, direction, true, false); else if (EQ (n, Qminus)) - window_scroll (selected_window, -direction, true, false); + window_scroll (window, -direction, true, false); else { n = Fprefix_numeric_value (n); - window_scroll (selected_window, XINT (n) * direction, false, false); + window_scroll (window, XFIXNUM (n) * direction, false, false); + } + + if (other_window) + { + set_marker_both (w->pointm, Qnil, PT, PT_BYTE); + set_marker_both (w->old_pointm, Qnil, PT, PT_BYTE); } unbind_to (count, Qnil); @@ -5673,7 +5733,7 @@ If ARG is the atom `-', scroll downward by nearly full screen. When calling from a program, supply as argument a number, nil, or `-'. */) (Lisp_Object arg) { - scroll_command (arg, 1); + scroll_command (selected_window, arg, 1); return Qnil; } @@ -5686,17 +5746,18 @@ If ARG is the atom `-', scroll upward by nearly full screen. When calling from a program, supply as argument a number, nil, or `-'. */) (Lisp_Object arg) { - scroll_command (arg, -1); + scroll_command (selected_window, arg, -1); return Qnil; } DEFUN ("other-window-for-scrolling", Fother_window_for_scrolling, Sother_window_for_scrolling, 0, 0, 0, doc: /* Return the other window for \"other window scroll\" commands. -If `other-window-scroll-buffer' is non-nil, a window -showing that buffer is used. If in the minibuffer, `minibuffer-scroll-window' if non-nil -specifies the window. This takes precedence over -`other-window-scroll-buffer'. */) +specifies the window. +Otherwise, if `other-window-scroll-buffer' is non-nil, a window +showing that buffer is used, popping the buffer up if necessary. +Finally, look for a neighboring window on the selected frame, +followed by all visible frames on the current terminal. */) (void) { Lisp_Object window; @@ -5705,8 +5766,7 @@ specifies the window. This takes precedence over && !NILP (Vminibuf_scroll_window)) window = Vminibuf_scroll_window; /* If buffer is specified and live, scroll that buffer. */ - else if (!NILP (Vother_window_scroll_buffer) - && BUFFERP (Vother_window_scroll_buffer) + else if (BUFFERP (Vother_window_scroll_buffer) && BUFFER_LIVE_P (XBUFFER (Vother_window_scroll_buffer))) { window = Fget_buffer_window (Vother_window_scroll_buffer, Qnil); @@ -5721,11 +5781,8 @@ specifies the window. This takes precedence over if (EQ (window, selected_window)) /* That didn't get us anywhere; look for a window on another - visible frame. */ - do - window = Fnext_window (window, Qnil, Qt); - while (! FRAME_VISIBLE_P (XFRAME (WINDOW_FRAME (XWINDOW (window)))) - && ! EQ (window, selected_window)); + visible frame on the current terminal. */ + window = Fnext_window (window, Qnil, Qvisible); } CHECK_LIVE_WINDOW (window); @@ -5739,49 +5796,30 @@ specifies the window. This takes precedence over DEFUN ("scroll-other-window", Fscroll_other_window, Sscroll_other_window, 0, 1, "P", doc: /* Scroll next window upward ARG lines; or near full screen if no ARG. A near full screen is `next-screen-context-lines' less than a full screen. -The next window is the one below the current one; or the one at the top -if the current one is at the bottom. Negative ARG means scroll downward. -If ARG is the atom `-', scroll downward by nearly full screen. -When calling from a program, supply as argument a number, nil, or `-'. - -If `other-window-scroll-buffer' is non-nil, scroll the window -showing that buffer, popping the buffer up if necessary. -If in the minibuffer, `minibuffer-scroll-window' if non-nil -specifies the window to scroll. This takes precedence over -`other-window-scroll-buffer'. */) +Negative ARG means scroll downward. If ARG is the atom `-', scroll +downward by nearly full screen. When calling from a program, supply +as argument a number, nil, or `-'. + +The next window is usually the one below the current one; +or the one at the top if the current one is at the bottom. +It is determined by the function `other-window-for-scrolling', +which see. */) (Lisp_Object arg) { - Lisp_Object window; - struct window *w; ptrdiff_t count = SPECPDL_INDEX (); + scroll_command (Fother_window_for_scrolling (), arg, 1); + return unbind_to (count, Qnil); +} - window = Fother_window_for_scrolling (); - w = XWINDOW (window); - - /* Don't screw up if window_scroll gets an error. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); - - Fset_buffer (w->contents); - SET_PT_BOTH (marker_position (w->pointm), marker_byte_position (w->pointm)); - SET_PT_BOTH (marker_position (w->old_pointm), marker_byte_position (w->old_pointm)); - - if (NILP (arg)) - window_scroll (window, 1, true, true); - else if (EQ (arg, Qminus)) - window_scroll (window, -1, true, true); - else - { - if (CONSP (arg)) - arg = XCAR (arg); - CHECK_NUMBER (arg); - window_scroll (window, XINT (arg), false, true); - } - - set_marker_both (w->pointm, Qnil, PT, PT_BYTE); - set_marker_both (w->old_pointm, Qnil, PT, PT_BYTE); - unbind_to (count, Qnil); - - return Qnil; +DEFUN ("scroll-other-window-down", Fscroll_other_window_down, + Sscroll_other_window_down, 0, 1, "P", + doc: /* Scroll next window downward ARG lines; or near full screen if no ARG. +For more details, see the documentation for `scroll-other-window'. */) + (Lisp_Object arg) +{ + ptrdiff_t count = SPECPDL_INDEX (); + scroll_command (Fother_window_for_scrolling (), arg, -1); + return unbind_to (count, Qnil); } DEFUN ("scroll-left", Fscroll_left, Sscroll_left, 0, 2, "^P\np", @@ -5798,7 +5836,7 @@ by this function. This happens in an interactive call. */) struct window *w = XWINDOW (selected_window); EMACS_INT requested_arg = (NILP (arg) ? window_body_width (w, 0) - 2 - : XINT (Fprefix_numeric_value (arg))); + : XFIXNUM (Fprefix_numeric_value (arg))); Lisp_Object result = set_window_hscroll (w, w->hscroll + requested_arg); if (!NILP (set_minimum)) @@ -5823,7 +5861,7 @@ by this function. This happens in an interactive call. */) struct window *w = XWINDOW (selected_window); EMACS_INT requested_arg = (NILP (arg) ? window_body_width (w, 0) - 2 - : XINT (Fprefix_numeric_value (arg))); + : XFIXNUM (Fprefix_numeric_value (arg))); Lisp_Object result = set_window_hscroll (w, w->hscroll - requested_arg); if (!NILP (set_minimum)) @@ -5895,22 +5933,23 @@ displayed_window_lines (struct window *w) } -DEFUN ("recenter", Frecenter, Srecenter, 0, 1, "P", +DEFUN ("recenter", Frecenter, Srecenter, 0, 2, "P\np", doc: /* Center point in selected window and maybe redisplay frame. With a numeric prefix argument ARG, recenter putting point on screen line ARG relative to the selected window. If ARG is negative, it counts up from the bottom of the window. (ARG should be less than the height of the window.) -If ARG is omitted or nil, then recenter with point on the middle line of -the selected window; if the variable `recenter-redisplay' is non-nil, -also erase the entire frame and redraw it (when `auto-resize-tool-bars' -is set to `grow-only', this resets the tool-bar's height to the minimum -height needed); if `recenter-redisplay' has the special value `tty', -then only tty frames are redrawn. +If ARG is omitted or nil, then recenter with point on the middle line +of the selected window; if REDISPLAY & `recenter-redisplay' are +non-nil, also erase the entire frame and redraw it (when +`auto-resize-tool-bars' is set to `grow-only', this resets the +tool-bar's height to the minimum height needed); if +`recenter-redisplay' has the special value `tty', then only tty frames +are redrawn. Interactively, REDISPLAY is always non-nil. Just C-u as prefix means put point in the center of the window and redisplay normally--don't erase and redraw the frame. */) - (register Lisp_Object arg) + (Lisp_Object arg, Lisp_Object redisplay) { struct window *w = XWINDOW (selected_window); struct buffer *buf = XBUFFER (w->contents); @@ -5930,7 +5969,8 @@ and redisplay normally--don't erase and redraw the frame. */) if (NILP (arg)) { - if (!NILP (Vrecenter_redisplay) + if (!NILP (redisplay) + && !NILP (Vrecenter_redisplay) && (!EQ (Vrecenter_redisplay, Qtty) || !NILP (Ftty_type (selected_frame)))) { @@ -5953,8 +5993,8 @@ and redisplay normally--don't erase and redraw the frame. */) else { arg = Fprefix_numeric_value (arg); - CHECK_NUMBER (arg); - iarg = XINT (arg); + CHECK_FIXNUM (arg); + iarg = XFIXNUM (arg); } /* Do this after making BUF current @@ -6131,10 +6171,10 @@ pixels. */) struct window *w = decode_live_window (window); if (NILP (pixelwise)) - return make_number (window_box_width (w, TEXT_AREA) + return make_fixnum (window_box_width (w, TEXT_AREA) / FRAME_COLUMN_WIDTH (WINDOW_XFRAME (w))); else - return make_number (window_box_width (w, TEXT_AREA)); + return make_fixnum (window_box_width (w, TEXT_AREA)); } DEFUN ("window-text-height", Fwindow_text_height, Swindow_text_height, @@ -6152,10 +6192,10 @@ pixels. */) struct window *w = decode_live_window (window); if (NILP (pixelwise)) - return make_number (window_box_height (w) + return make_fixnum (window_box_height (w) / FRAME_LINE_HEIGHT (WINDOW_XFRAME (w))); else - return make_number (window_box_height (w)); + return make_fixnum (window_box_height (w)); } DEFUN ("move-to-window-line", Fmove_to_window_line, Smove_to_window_line, @@ -6188,7 +6228,7 @@ from the top of the window. */) if (start < BEGV || start > ZV) { int height = window_internal_height (w); - Fvertical_motion (make_number (- (height / 2)), window, Qnil); + Fvertical_motion (make_fixnum (- (height / 2)), window, Qnil); set_marker_both (w->start, w->contents, PT, PT_BYTE); w->start_at_line_beg = !NILP (Fbolp ()); w->force_start = true; @@ -6202,7 +6242,7 @@ from the top of the window. */) XSETFASTINT (arg, lines / 2); else { - EMACS_INT iarg = XINT (Fprefix_numeric_value (arg)); + EMACS_INT iarg = XFIXNUM (Fprefix_numeric_value (arg)); if (iarg < 0) iarg = iarg + lines; @@ -6220,12 +6260,12 @@ from the top of the window. */) iarg = min (iarg, lines - this_scroll_margin - 1); #endif - arg = make_number (iarg); + arg = make_fixnum (iarg); } /* Skip past a partially visible first line. */ if (w->vscroll) - XSETINT (arg, XINT (arg) + 1); + XSETINT (arg, XFIXNUM (arg) + 1); return Fvertical_motion (arg, window, Qnil); } @@ -6261,7 +6301,7 @@ struct save_window_data /* These are currently unused. We need them as soon as we convert to pixels. */ int frame_menu_bar_height, frame_tool_bar_height; - }; + } GCALIGNED_STRUCT; /* This is saved as a Lisp_Vector. */ struct saved_window @@ -6463,14 +6503,14 @@ the return value is nil. Otherwise the value is t. */) if (!NILP (p->parent)) wset_parent - (w, SAVED_WINDOW_N (saved_windows, XFASTINT (p->parent))->window); + (w, SAVED_WINDOW_N (saved_windows, XFIXNAT (p->parent))->window); else wset_parent (w, Qnil); if (!NILP (p->prev)) { wset_prev - (w, SAVED_WINDOW_N (saved_windows, XFASTINT (p->prev))->window); + (w, SAVED_WINDOW_N (saved_windows, XFIXNAT (p->prev))->window); wset_next (XWINDOW (w->prev), p->window); } else @@ -6478,7 +6518,7 @@ the return value is nil. Otherwise the value is t. */) wset_prev (w, Qnil); if (!NILP (w->parent)) wset_combination (XWINDOW (w->parent), - (XINT (p->total_cols) + (XFIXNUM (p->total_cols) != XWINDOW (w->parent)->total_cols), p->window); } @@ -6486,32 +6526,32 @@ the return value is nil. Otherwise the value is t. */) /* If we squirreled away the buffer, restore it now. */ if (BUFFERP (w->combination_limit)) wset_buffer (w, w->combination_limit); - w->pixel_left = XFASTINT (p->pixel_left); - w->pixel_top = XFASTINT (p->pixel_top); - w->pixel_width = XFASTINT (p->pixel_width); - w->pixel_height = XFASTINT (p->pixel_height); + w->pixel_left = XFIXNAT (p->pixel_left); + w->pixel_top = XFIXNAT (p->pixel_top); + w->pixel_width = XFIXNAT (p->pixel_width); + w->pixel_height = XFIXNAT (p->pixel_height); w->pixel_width_before_size_change - = XFASTINT (p->pixel_width_before_size_change); + = XFIXNAT (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); - w->total_lines = XFASTINT (p->total_lines); + = XFIXNAT (p->pixel_height_before_size_change); + w->left_col = XFIXNAT (p->left_col); + w->top_line = XFIXNAT (p->top_line); + w->total_cols = XFIXNAT (p->total_cols); + w->total_lines = XFIXNAT (p->total_lines); wset_normal_cols (w, p->normal_cols); wset_normal_lines (w, p->normal_lines); - w->hscroll = XFASTINT (p->hscroll); + w->hscroll = XFIXNAT (p->hscroll); w->suspend_auto_hscroll = !NILP (p->suspend_auto_hscroll); - w->min_hscroll = XFASTINT (p->min_hscroll); - w->hscroll_whole = XFASTINT (p->hscroll_whole); + w->min_hscroll = XFIXNAT (p->min_hscroll); + w->hscroll_whole = XFIXNAT (p->hscroll_whole); wset_display_table (w, p->display_table); - w->left_margin_cols = XINT (p->left_margin_cols); - w->right_margin_cols = XINT (p->right_margin_cols); - w->left_fringe_width = XINT (p->left_fringe_width); - w->right_fringe_width = XINT (p->right_fringe_width); + w->left_margin_cols = XFIXNUM (p->left_margin_cols); + w->right_margin_cols = XFIXNUM (p->right_margin_cols); + w->left_fringe_width = XFIXNUM (p->left_fringe_width); + w->right_fringe_width = XFIXNUM (p->right_fringe_width); w->fringes_outside_margins = !NILP (p->fringes_outside_margins); - w->scroll_bar_width = XINT (p->scroll_bar_width); - w->scroll_bar_height = XINT (p->scroll_bar_height); + w->scroll_bar_width = XFIXNUM (p->scroll_bar_width); + w->scroll_bar_height = XFIXNUM (p->scroll_bar_height); wset_vertical_scroll_bar_type (w, p->vertical_scroll_bar_type); wset_horizontal_scroll_bar_type (w, p->horizontal_scroll_bar_type); wset_dedicated (w, p->dedicated); @@ -6603,7 +6643,7 @@ the return value is nil. Otherwise the value is t. */) current when the window configuration was saved. */ if (EQ (XWINDOW (data->current_window)->contents, new_current_buffer)) set_marker_restricted (XWINDOW (data->current_window)->pointm, - make_number (old_point), + make_fixnum (old_point), XWINDOW (data->current_window)->contents); /* In the following call to select_window, prevent "swapping out @@ -6707,7 +6747,7 @@ the return value is nil. Otherwise the value is t. */) the "normal" frame's selected window and that window *does* show new_current_buffer. */ if (!EQ (XWINDOW (selected_window)->contents, new_current_buffer)) - Fgoto_char (make_number (old_point)); + Fgoto_char (make_fixnum (old_point)); } Vminibuf_scroll_window = data->minibuf_scroll_window; @@ -6842,21 +6882,21 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i) p = SAVED_WINDOW_N (vector, i); w = XWINDOW (window); - wset_temslot (w, make_number (i)); i++; + wset_temslot (w, make_fixnum (i)); i++; p->window = window; p->buffer = (WINDOW_LEAF_P (w) ? w->contents : Qnil); - p->pixel_left = make_number (w->pixel_left); - 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_left = make_fixnum (w->pixel_left); + p->pixel_top = make_fixnum (w->pixel_top); + p->pixel_width = make_fixnum (w->pixel_width); + p->pixel_height = make_fixnum (w->pixel_height); p->pixel_width_before_size_change - = make_number (w->pixel_width_before_size_change); + = make_fixnum (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); - p->total_lines = make_number (w->total_lines); + = make_fixnum (w->pixel_height_before_size_change); + p->left_col = make_fixnum (w->left_col); + p->top_line = make_fixnum (w->top_line); + p->total_cols = make_fixnum (w->total_cols); + p->total_lines = make_fixnum (w->total_lines); p->normal_cols = w->normal_cols; p->normal_lines = w->normal_lines; XSETFASTINT (p->hscroll, w->hscroll); @@ -6864,13 +6904,13 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i) XSETFASTINT (p->min_hscroll, w->min_hscroll); XSETFASTINT (p->hscroll_whole, w->hscroll_whole); p->display_table = w->display_table; - p->left_margin_cols = make_number (w->left_margin_cols); - p->right_margin_cols = make_number (w->right_margin_cols); - p->left_fringe_width = make_number (w->left_fringe_width); - p->right_fringe_width = make_number (w->right_fringe_width); + p->left_margin_cols = make_fixnum (w->left_margin_cols); + p->right_margin_cols = make_fixnum (w->right_margin_cols); + p->left_fringe_width = make_fixnum (w->left_fringe_width); + p->right_fringe_width = make_fixnum (w->right_fringe_width); p->fringes_outside_margins = w->fringes_outside_margins ? Qt : Qnil; - p->scroll_bar_width = make_number (w->scroll_bar_width); - p->scroll_bar_height = make_number (w->scroll_bar_height); + p->scroll_bar_width = make_fixnum (w->scroll_bar_width); + p->scroll_bar_height = make_fixnum (w->scroll_bar_height); p->vertical_scroll_bar_type = w->vertical_scroll_bar_type; p->horizontal_scroll_bar_type = w->horizontal_scroll_bar_type; p->dedicated = w->dedicated; @@ -6925,6 +6965,12 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i) if (BUFFERP (w->contents)) { + Lisp_Object buffer_local_window_point_insertion_type + = (buffer_local_value (Qwindow_point_insertion_type, w->contents)); + bool window_point_insertion_type + = (!NILP (buffer_local_window_point_insertion_type) + && !EQ (buffer_local_window_point_insertion_type, Qunbound)); + /* Save w's value of point in the window configuration. If w is the selected window, then get the value of point from the buffer; pointm is garbage in the selected window. */ @@ -6935,12 +6981,8 @@ save_window_save (Lisp_Object window, struct Lisp_Vector *vector, ptrdiff_t i) else p->pointm = Fcopy_marker (w->pointm, Qnil); p->old_pointm = Fcopy_marker (w->old_pointm, Qnil); - XMARKER (p->pointm)->insertion_type - = !NILP (buffer_local_value /* Don't signal error if void. */ - (Qwindow_point_insertion_type, w->contents)); - XMARKER (p->old_pointm)->insertion_type - = !NILP (buffer_local_value /* Don't signal error if void. */ - (Qwindow_point_insertion_type, w->contents)); + XMARKER (p->pointm)->insertion_type = window_point_insertion_type; + XMARKER (p->old_pointm)->insertion_type = window_point_insertion_type; p->start = Fcopy_marker (w->start, Qnil); p->start_at_line_beg = w->start_at_line_beg ? Qt : Qnil; @@ -7004,8 +7046,7 @@ saved by this function. */) tem = make_uninit_vector (n_windows); data->saved_windows = tem; for (i = 0; i < n_windows; i++) - ASET (tem, i, - Fmake_vector (make_number (VECSIZE (struct saved_window)), Qnil)); + ASET (tem, i, make_nil_vector (VECSIZE (struct saved_window))); save_window_save (FRAME_ROOT_WINDOW (f), XVECTOR (tem), 0); XSETWINDOW_CONFIGURATION (tem, data); return (tem); @@ -7034,7 +7075,7 @@ extract_dimension (Lisp_Object dimension) if (NILP (dimension)) return -1; CHECK_RANGED_INTEGER (dimension, 0, INT_MAX); - return XINT (dimension); + return XFIXNUM (dimension); } static struct window * @@ -7097,9 +7138,9 @@ as nil. */) { struct window *w = decode_live_window (window); return Fcons (w->left_margin_cols - ? make_number (w->left_margin_cols) : Qnil, + ? make_fixnum (w->left_margin_cols) : Qnil, w->right_margin_cols - ? make_number (w->right_margin_cols) : Qnil); + ? make_fixnum (w->right_margin_cols) : Qnil); } @@ -7183,8 +7224,8 @@ Value is a list of the form (LEFT-WIDTH RIGHT-WIDTH OUTSIDE-MARGINS). */) { struct window *w = decode_live_window (window); - return list3 (make_number (WINDOW_LEFT_FRINGE_WIDTH (w)), - make_number (WINDOW_RIGHT_FRINGE_WIDTH (w)), + return list3 (make_fixnum (WINDOW_LEFT_FRINGE_WIDTH (w)), + make_fixnum (WINDOW_RIGHT_FRINGE_WIDTH (w)), WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w) ? Qt : Qnil); } @@ -7312,14 +7353,14 @@ value. */) struct window *w = decode_live_window (window); return Fcons (((w->scroll_bar_width >= 0) - ? make_number (w->scroll_bar_width) + ? make_fixnum (w->scroll_bar_width) : Qnil), - list5 (make_number (WINDOW_SCROLL_BAR_COLS (w)), + list5 (make_fixnum (WINDOW_SCROLL_BAR_COLS (w)), w->vertical_scroll_bar_type, ((w->scroll_bar_height >= 0) - ? make_number (w->scroll_bar_height) + ? make_fixnum (w->scroll_bar_height) : Qnil), - make_number (WINDOW_SCROLL_BAR_LINES (w)), + make_fixnum (WINDOW_SCROLL_BAR_LINES (w)), w->horizontal_scroll_bar_type)); } @@ -7343,9 +7384,9 @@ optional second arg PIXELS-P means value is measured in pixels. */) if (FRAME_WINDOW_P (f)) result = (NILP (pixels_p) ? FRAME_CANON_Y_FROM_PIXEL_Y (f, -w->vscroll) - : make_number (-w->vscroll)); + : make_fixnum (-w->vscroll)); else - result = make_number (0); + result = make_fixnum (0); return result; } @@ -7367,7 +7408,7 @@ If PIXELS-P is non-nil, the return value is VSCROLL. */) struct window *w = decode_live_window (window); struct frame *f = XFRAME (w->frame); - CHECK_NUMBER_OR_FLOAT (vscroll); + CHECK_NUMBER (vscroll); if (FRAME_WINDOW_P (f)) { @@ -7564,6 +7605,7 @@ syms_of_window (void) Fput (Qscroll_down, Qscroll_command, Qt); DEFSYM (Qwindow_configuration_change_hook, "window-configuration-change-hook"); + DEFSYM (Qwindow_size_change_functions, "window-size-change-functions"); DEFSYM (Qwindowp, "windowp"); DEFSYM (Qwindow_configuration_p, "window-configuration-p"); DEFSYM (Qwindow_live_p, "window-live-p"); @@ -7860,6 +7902,7 @@ displayed after a scrolling operation to be somewhat inaccurate. */); defsubr (&Sscroll_right); defsubr (&Sother_window_for_scrolling); defsubr (&Sscroll_other_window); + defsubr (&Sscroll_other_window_down); defsubr (&Sminibuffer_selected_window); defsubr (&Srecenter); defsubr (&Swindow_text_width); diff --git a/src/window.h b/src/window.h index 72c58e7abfe..ee6ec3bb19a 100644 --- a/src/window.h +++ b/src/window.h @@ -204,6 +204,9 @@ struct window /* An alist with parameters. */ Lisp_Object window_parameters; + /* The help echo text for this window. Qnil if there's none. */ + Lisp_Object mode_line_help_echo; + /* No Lisp data may follow below this point without changing mark_object in alloc.c. The member current_matrix must be the first non-Lisp member. */ @@ -423,7 +426,7 @@ struct window /* Z_BYTE - buffer position of the last glyph in the current matrix of W. Should be nonnegative, and only valid if window_end_valid is true. */ ptrdiff_t window_end_bytepos; - }; + } GCALIGNED_STRUCT; INLINE bool WINDOWP (Lisp_Object a) @@ -441,7 +444,7 @@ INLINE struct window * XWINDOW (Lisp_Object a) { eassert (WINDOWP (a)); - return XUNTAG (a, Lisp_Vectorlike); + return XUNTAG (a, Lisp_Vectorlike, struct window); } /* Most code should use these functions to set Lisp fields in struct @@ -471,6 +474,12 @@ wset_redisplay_end_trigger (struct window *w, Lisp_Object val) } INLINE void +wset_mode_line_help_echo (struct window *w, Lisp_Object val) +{ + w->mode_line_help_echo = val; +} + +INLINE void wset_new_pixel (struct window *w, Lisp_Object val) { w->new_pixel = val; diff --git a/src/xdisp.c b/src/xdisp.c index 274ab8ddf51..f6f75f321c4 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -265,7 +265,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ character to be delivered is a composed character, the iteration calls composition_reseat_it and next_element_from_composition. If they succeed to compose the character with one or more of the - following characters, the whole sequence of characters that where + following characters, the whole sequence of characters that were composed is recorded in the `struct composition_it' object that is part of the buffer iterator. The composed sequence could produce one or more font glyphs (called "grapheme clusters") on the screen. @@ -440,10 +440,8 @@ static Lisp_Object default_invis_vector[3]; Lisp_Object echo_area_window; -/* List of pairs (MESSAGE . MULTIBYTE). The function save_message - pushes the current message and the value of - message_enable_multibyte on the stack, the function restore_message - pops the stack and displays MESSAGE again. */ +/* Stack of messages, which are pushed by push_message and popped and + displayed by restore_message. */ static Lisp_Object Vmessage_stack; @@ -469,12 +467,12 @@ static bool message_enable_multibyte; looking for those `redisplay' bits (actually, there might be some such bits set, but then only on objects which aren't displayed anyway). - OTOH if it's non-zero we wil have to loop through all windows and then check - the `redisplay' bit of the corresponding window, frame, and buffer, in order - to decide whether that window needs attention or not. Note that we can't - just look at the frame's redisplay bit to decide that the whole frame can be - skipped, since even if the frame's redisplay bit is unset, some of its - windows's redisplay bits may be set. + OTOH if it's non-zero we will have to loop through all windows and then + check the `redisplay' bit of the corresponding window, frame, and buffer, in + order to decide whether that window needs attention or not. Note that we + can't just look at the frame's redisplay bit to decide that the whole frame + can be skipped, since even if the frame's redisplay bit is unset, some of + its windows's redisplay bits may be set. Mostly for historical reasons, windows_or_buffers_changed can also take other non-zero values. In that case, the precise value doesn't matter (it @@ -485,7 +483,7 @@ static bool message_enable_multibyte; int windows_or_buffers_changed; /* Nonzero if we should redraw the mode lines on the next redisplay. - Similarly to `windows_or_buffers_changed', If it has value REDISPLAY_SOME, + Similarly to `windows_or_buffers_changed', if it has value REDISPLAY_SOME, then only redisplay the mode lines in those buffers/windows/frames where the `redisplay' bit has been set. For any other value, redisplay all mode lines (the number used is then only @@ -844,7 +842,7 @@ static Lisp_Object redisplay_window_1 (Lisp_Object); static bool set_cursor_from_row (struct window *, struct glyph_row *, struct glyph_matrix *, ptrdiff_t, ptrdiff_t, int, int); -static bool cursor_row_fully_visible_p (struct window *, bool, bool); +static bool cursor_row_fully_visible_p (struct window *, bool, bool, bool); static bool update_menu_bar (struct frame *, bool, bool); static bool try_window_reusing_current_matrix (struct window *); static int try_window_id (struct window *); @@ -1216,7 +1214,7 @@ Value is the height in pixels of the line at point. */) move_it_by_lines (&it, 0); it.vpos = it.current_y = 0; last_height = 0; - result = make_number (line_bottom_y (&it)); + result = make_fixnum (line_bottom_y (&it)); if (old_buffer) set_buffer_internal_1 (old_buffer); @@ -1252,8 +1250,8 @@ default_line_pixel_height (struct window *w) val = BVAR (&buffer_defaults, extra_line_spacing); if (!NILP (val)) { - if (RANGED_INTEGERP (0, val, INT_MAX)) - height += XFASTINT (val); + if (RANGED_FIXNUMP (0, val, INT_MAX)) + height += XFIXNAT (val); else if (FLOATP (val)) { int addon = XFLOAT_DATA (val) * height + 0.5; @@ -1509,7 +1507,7 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, } else if (IT_CHARPOS (it) != charpos) { - Lisp_Object cpos = make_number (charpos); + Lisp_Object cpos = make_fixnum (charpos); Lisp_Object spec = Fget_char_property (cpos, Qdisplay, Qnil); Lisp_Object string = string_from_display_spec (spec); struct text_pos tpos; @@ -1552,8 +1550,8 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, startpos = Fprevious_single_char_property_change (endpos, Qdisplay, Qnil, Qnil); - start = XFASTINT (startpos); - end = XFASTINT (endpos); + start = XFIXNAT (startpos); + end = XFIXNAT (endpos); /* Move to the last buffer position before the display property. */ start_display (&it3, w, top); @@ -2283,9 +2281,9 @@ get_phys_cursor_geometry (struct window *w, struct glyph_row *row, int x, y, wd, h, h0, y0, ascent; /* Compute the width of the rectangle to draw. If on a stretch - glyph, and `x-stretch-block-cursor' is nil, don't draw a - rectangle as wide as the glyph, but use a canonical character - width instead. */ + glyph, and `x-stretch-cursor' is nil, don't draw a rectangle + as wide as the glyph, but use a canonical character width + instead. */ wd = glyph->pixel_width; x = w->phys_cursor.x; @@ -2645,8 +2643,7 @@ safe__call (bool inhibit_quit, ptrdiff_t nargs, Lisp_Object func, va_list ap) so there is no possibility of wanting to redisplay. */ val = internal_condition_case_n (Ffuncall, nargs, args, Qt, safe_eval_handler); - SAFE_FREE (); - val = unbind_to (count, val); + val = SAFE_FREE_UNBIND_TO (count, val); } return val; @@ -2817,7 +2814,7 @@ init_iterator (struct it *it, struct window *w, /* Perhaps remap BASE_FACE_ID to a user-specified alternative. */ if (! NILP (Vface_remapping_alist)) remapped_base_face_id - = lookup_basic_face (XFRAME (w->frame), base_face_id); + = lookup_basic_face (w, XFRAME (w->frame), base_face_id); /* Use one of the mode line rows of W's desired matrix if appropriate. */ @@ -2851,8 +2848,8 @@ init_iterator (struct it *it, struct window *w, if (base_face_id == DEFAULT_FACE_ID && FRAME_WINDOW_P (it->f)) { - if (NATNUMP (BVAR (current_buffer, extra_line_spacing))) - it->extra_line_spacing = XFASTINT (BVAR (current_buffer, extra_line_spacing)); + if (FIXNATP (BVAR (current_buffer, extra_line_spacing))) + it->extra_line_spacing = XFIXNAT (BVAR (current_buffer, extra_line_spacing)); else if (FLOATP (BVAR (current_buffer, extra_line_spacing))) it->extra_line_spacing = (XFLOAT_DATA (BVAR (current_buffer, extra_line_spacing)) * FRAME_LINE_HEIGHT (it->f)); @@ -2877,9 +2874,9 @@ init_iterator (struct it *it, struct window *w, /* -1 means everything between a CR and the following line end is invisible. >0 means lines indented more than this value are invisible. */ - it->selective = (INTEGERP (BVAR (current_buffer, selective_display)) + it->selective = (FIXNUMP (BVAR (current_buffer, selective_display)) ? (clip_to_bounds - (-1, XINT (BVAR (current_buffer, selective_display)), + (-1, XFIXNUM (BVAR (current_buffer, selective_display)), PTRDIFF_MAX)) : (!NILP (BVAR (current_buffer, selective_display)) ? -1 : 0)); @@ -2898,9 +2895,9 @@ init_iterator (struct it *it, struct window *w, && XMARKER (w->redisplay_end_trigger)->buffer != 0) it->redisplay_end_trigger_charpos = marker_position (w->redisplay_end_trigger); - else if (INTEGERP (w->redisplay_end_trigger)) + else if (FIXNUMP (w->redisplay_end_trigger)) it->redisplay_end_trigger_charpos - = clip_to_bounds (PTRDIFF_MIN, XINT (w->redisplay_end_trigger), + = clip_to_bounds (PTRDIFF_MIN, XFIXNUM (w->redisplay_end_trigger), PTRDIFF_MAX); it->tab_width = SANE_TAB_WIDTH (current_buffer); @@ -2912,9 +2909,9 @@ init_iterator (struct it *it, struct window *w, && !it->w->hscroll && (WINDOW_FULL_WIDTH_P (it->w) || NILP (Vtruncate_partial_width_windows) - || (INTEGERP (Vtruncate_partial_width_windows) + || (FIXNUMP (Vtruncate_partial_width_windows) /* PXW: Shall we do something about this? */ - && (XINT (Vtruncate_partial_width_windows) + && (XFIXNUM (Vtruncate_partial_width_windows) <= WINDOW_TOTAL_COLS (it->w)))) && NILP (BVAR (current_buffer, truncate_lines))) it->line_wrap = NILP (BVAR (current_buffer, word_wrap)) @@ -3197,11 +3194,11 @@ in_ellipses_for_invisible_text_p (struct display_pos *pos, struct window *w) && CHARPOS (pos->string_pos) < 0 && charpos > BEGV && (XSETWINDOW (window, w), - prop = Fget_char_property (make_number (charpos), + prop = Fget_char_property (make_fixnum (charpos), Qinvisible, window), TEXT_PROP_MEANS_INVISIBLE (prop) == 0)) { - prop = Fget_char_property (make_number (charpos - 1), Qinvisible, + prop = Fget_char_property (make_fixnum (charpos - 1), Qinvisible, window); ellipses_p = 2 == TEXT_PROP_MEANS_INVISIBLE (prop); } @@ -3586,12 +3583,12 @@ compute_stop_pos (struct it *it) /* Set up variables for computing the stop position from text property changes. */ XSETBUFFER (object, current_buffer); - limit = make_number (IT_CHARPOS (*it) + TEXT_PROP_DISTANCE_LIMIT); + limit = make_fixnum (IT_CHARPOS (*it) + TEXT_PROP_DISTANCE_LIMIT); } /* Get the interval containing IT's position. Value is a null interval if there isn't such an interval. */ - position = make_number (charpos); + position = make_fixnum (charpos); iv = validate_interval_range (object, &position, &position, false); if (iv) { @@ -3608,7 +3605,7 @@ compute_stop_pos (struct it *it) for (next_iv = next_interval (iv); (next_iv && (NILP (limit) - || XFASTINT (limit) > next_iv->position)); + || XFIXNAT (limit) > next_iv->position)); next_iv = next_interval (next_iv)) { for (p = it_props; p->handler; ++p) @@ -3625,10 +3622,10 @@ compute_stop_pos (struct it *it) if (next_iv) { - if (INTEGERP (limit) - && next_iv->position >= XFASTINT (limit)) + if (FIXNUMP (limit) + && next_iv->position >= XFIXNAT (limit)) /* No text property change up to limit. */ - it->stop_charpos = min (XFASTINT (limit), it->stop_charpos); + it->stop_charpos = min (XFIXNAT (limit), it->stop_charpos); else /* Text properties change in next_iv. */ it->stop_charpos = min (it->stop_charpos, next_iv->position); @@ -3743,7 +3740,7 @@ compute_display_string_pos (struct text_pos *position, /* If the character at CHARPOS is where the display string begins, return CHARPOS. */ - pos = make_number (charpos); + pos = make_fixnum (charpos); if (STRINGP (object)) bufpos = string->bufpos; else @@ -3751,7 +3748,7 @@ compute_display_string_pos (struct text_pos *position, tpos = *position; if (!NILP (spec = Fget_char_property (pos, Qdisplay, object)) && (charpos <= begb - || !EQ (Fget_char_property (make_number (charpos - 1), Qdisplay, + || !EQ (Fget_char_property (make_fixnum (charpos - 1), Qdisplay, object), spec)) && (rv = handle_display_spec (NULL, spec, object, Qnil, &tpos, bufpos, @@ -3764,10 +3761,10 @@ compute_display_string_pos (struct text_pos *position, /* Look forward for the first character with a `display' property that will replace the underlying text when displayed. */ - limpos = make_number (lim); + limpos = make_fixnum (lim); do { pos = Fnext_single_char_property_change (pos, Qdisplay, object1, limpos); - CHARPOS (tpos) = XFASTINT (pos); + CHARPOS (tpos) = XFIXNAT (pos); if (CHARPOS (tpos) >= lim) { *disp_prop = 0; @@ -3800,7 +3797,7 @@ compute_display_string_end (ptrdiff_t charpos, struct bidi_string_data *string) /* OBJECT = nil means current buffer. */ Lisp_Object object = (string && STRINGP (string->lstring)) ? string->lstring : Qnil; - Lisp_Object pos = make_number (charpos); + Lisp_Object pos = make_fixnum (charpos); ptrdiff_t eob = (STRINGP (object) || (string && string->s)) ? string->schars : ZV; @@ -3828,7 +3825,7 @@ compute_display_string_end (ptrdiff_t charpos, struct bidi_string_data *string) changes. */ pos = Fnext_single_char_property_change (pos, Qdisplay, object, Qnil); - return XFASTINT (pos); + return XFIXNAT (pos); } @@ -3858,7 +3855,7 @@ handle_fontified_prop (struct it *it) && it->s == NULL && !NILP (Vfontification_functions) && !NILP (Vrun_hooks) - && (pos = make_number (IT_CHARPOS (*it)), + && (pos = make_fixnum (IT_CHARPOS (*it)), prop = Fget_char_property (pos, Qfontified, Qnil), /* Ignore the special cased nil value always present at EOB since no amount of fontifying will be able to change it. */ @@ -4068,7 +4065,7 @@ handle_face_prop (struct it *it) might be a big deal. */ base_face_id = it->string_from_prefix_prop_p ? (!NILP (Vface_remapping_alist) - ? lookup_basic_face (it->f, DEFAULT_FACE_ID) + ? lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID) : DEFAULT_FACE_ID) : underlying_face_id (it); } @@ -4358,7 +4355,7 @@ handle_invisible_prop (struct it *it) /* Get the value of the invisible text property at the current position. Value will be nil if there is no such property. */ - end_charpos = make_number (IT_STRING_CHARPOS (*it)); + end_charpos = make_fixnum (IT_STRING_CHARPOS (*it)); prop = Fget_text_property (end_charpos, Qinvisible, it->string); invis = TEXT_PROP_MEANS_INVISIBLE (prop); @@ -4382,10 +4379,10 @@ handle_invisible_prop (struct it *it) it->string, limit); /* Since LIMIT is always an integer, so should be the value returned by Fnext_single_property_change. */ - eassert (INTEGERP (end_charpos)); - if (INTEGERP (end_charpos)) + eassert (FIXNUMP (end_charpos)); + if (FIXNUMP (end_charpos)) { - endpos = XFASTINT (end_charpos); + endpos = XFIXNAT (end_charpos); prop = Fget_text_property (end_charpos, Qinvisible, it->string); invis = TEXT_PROP_MEANS_INVISIBLE (prop); if (invis == 2) @@ -4461,7 +4458,7 @@ handle_invisible_prop (struct it *it) /* First of all, is there invisible text at this position? */ tem = start_charpos = IT_CHARPOS (*it); - pos = make_number (tem); + pos = make_fixnum (tem); prop = get_char_property_and_overlay (pos, Qinvisible, it->window, &overlay); invis = TEXT_PROP_MEANS_INVISIBLE (prop); @@ -4499,7 +4496,7 @@ handle_invisible_prop (struct it *it) the char before the given position, i.e. if we get invis = 0, this means that the char at newpos is visible. */ - pos = make_number (newpos); + pos = make_fixnum (newpos); prop = Fget_char_property (pos, Qinvisible, it->window); invis = TEXT_PROP_MEANS_INVISIBLE (prop); } @@ -4754,7 +4751,7 @@ handle_display_prop (struct it *it) if (!it->string_from_display_prop_p) it->area = TEXT_AREA; - propval = get_char_property_and_overlay (make_number (position->charpos), + propval = get_char_property_and_overlay (make_fixnum (position->charpos), Qdisplay, object, &overlay); if (NILP (propval)) return HANDLED_NORMALLY; @@ -4870,13 +4867,13 @@ display_prop_end (struct it *it, Lisp_Object object, struct text_pos start_pos) Lisp_Object end; struct text_pos end_pos; - end = Fnext_single_char_property_change (make_number (CHARPOS (start_pos)), + end = Fnext_single_char_property_change (make_fixnum (CHARPOS (start_pos)), Qdisplay, object, Qnil); - CHARPOS (end_pos) = XFASTINT (end); + CHARPOS (end_pos) = XFIXNAT (end); if (STRINGP (object)) compute_string_pos (&end_pos, start_pos, it->string); else - BYTEPOS (end_pos) = CHAR_TO_BYTE (XFASTINT (end)); + BYTEPOS (end_pos) = CHAR_TO_BYTE (XFIXNAT (end)); return end_pos; } @@ -4943,10 +4940,10 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, if (NILP (object)) XSETBUFFER (object, current_buffer); specbind (Qobject, object); - specbind (Qposition, make_number (CHARPOS (*position))); - specbind (Qbuffer_position, make_number (bufpos)); + specbind (Qposition, make_fixnum (CHARPOS (*position))); + specbind (Qbuffer_position, make_fixnum (bufpos)); form = safe_eval (form); - unbind_to (count, Qnil); + form = unbind_to (count, form); } if (NILP (form)) @@ -4971,10 +4968,10 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, && (EQ (XCAR (it->font_height), Qplus) || EQ (XCAR (it->font_height), Qminus)) && CONSP (XCDR (it->font_height)) - && RANGED_INTEGERP (0, XCAR (XCDR (it->font_height)), INT_MAX)) + && RANGED_FIXNUMP (0, XCAR (XCDR (it->font_height)), INT_MAX)) { /* `(+ N)' or `(- N)' where N is an integer. */ - int steps = XINT (XCAR (XCDR (it->font_height))); + int steps = XFIXNUM (XCAR (XCDR (it->font_height))); if (EQ (XCAR (it->font_height), Qplus)) steps = - steps; it->face_id = smaller_face (it->f, it->face_id, steps); @@ -4996,9 +4993,9 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, struct face *f; f = FACE_FROM_ID (it->f, - lookup_basic_face (it->f, DEFAULT_FACE_ID)); + lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID)); new_height = (XFLOATINT (it->font_height) - * XINT (f->lface[LFACE_HEIGHT_INDEX])); + * XFIXNUM (f->lface[LFACE_HEIGHT_INDEX])); } else if (enable_eval_p) { @@ -5009,7 +5006,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, specbind (Qheight, face->lface[LFACE_HEIGHT_INDEX]); value = safe_eval (it->font_height); - unbind_to (count, Qnil); + value = unbind_to (count, value); if (NUMBERP (value)) new_height = XFLOATINT (value); @@ -5183,12 +5180,12 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, if (it) { - int face_id = lookup_basic_face (it->f, DEFAULT_FACE_ID); + int face_id = lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID); if (CONSP (XCDR (XCDR (spec)))) { Lisp_Object face_name = XCAR (XCDR (XCDR (spec))); - int face_id2 = lookup_derived_face (it->f, face_name, + int face_id2 = lookup_derived_face (it->w, it->f, face_name, FRINGE_FACE_ID, false); if (face_id2 >= 0) face_id = face_id2; @@ -5497,11 +5494,11 @@ string_buffer_position_lim (Lisp_Object string, Lisp_Object limit, prop, pos; bool found = false; - pos = make_number (max (from, BEGV)); + pos = make_fixnum (max (from, BEGV)); if (!back_p) /* looking forward */ { - limit = make_number (min (to, ZV)); + limit = make_fixnum (min (to, ZV)); while (!found && !EQ (pos, limit)) { prop = Fget_char_property (pos, Qdisplay, Qnil); @@ -5514,7 +5511,7 @@ string_buffer_position_lim (Lisp_Object string, } else /* looking back */ { - limit = make_number (max (to, BEGV)); + limit = make_fixnum (max (to, BEGV)); while (!found && !EQ (pos, limit)) { prop = Fget_char_property (pos, Qdisplay, Qnil); @@ -5526,7 +5523,7 @@ string_buffer_position_lim (Lisp_Object string, } } - return found ? XINT (pos) : 0; + return found ? XFIXNUM (pos) : 0; } /* Determine which buffer position in current buffer STRING comes from. @@ -5828,11 +5825,7 @@ compare_overlay_entries (const void *e1, const void *e2) static void load_overlay_strings (struct it *it, ptrdiff_t charpos) { - Lisp_Object overlay, window, str, invisible; - struct Lisp_Overlay *ov; - ptrdiff_t start, end; - ptrdiff_t n = 0, i, j; - int invis; + ptrdiff_t n = 0; struct overlay_entry entriesbuf[20]; ptrdiff_t size = ARRAYELTS (entriesbuf); struct overlay_entry *entries = entriesbuf; @@ -5861,19 +5854,20 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos) entries[n].string = (STRING); \ entries[n].overlay = (OVERLAY); \ priority = Foverlay_get ((OVERLAY), Qpriority); \ - entries[n].priority = INTEGERP (priority) ? XINT (priority) : 0; \ + entries[n].priority = FIXNUMP (priority) ? XFIXNUM (priority) : 0; \ entries[n].after_string_p = (AFTER_P); \ ++n; \ } \ while (false) /* Process overlay before the overlay center. */ - for (ov = current_buffer->overlays_before; ov; ov = ov->next) + for (struct Lisp_Overlay *ov = current_buffer->overlays_before; + ov; ov = ov->next) { - XSETMISC (overlay, ov); + Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - start = OVERLAY_POSITION (OVERLAY_START (overlay)); - end = OVERLAY_POSITION (OVERLAY_END (overlay)); + ptrdiff_t start = OVERLAY_POSITION (OVERLAY_START (overlay)); + ptrdiff_t end = OVERLAY_POSITION (OVERLAY_END (overlay)); if (end < charpos) break; @@ -5884,17 +5878,18 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos) continue; /* Skip this overlay if it doesn't apply to IT->w. */ - window = Foverlay_get (overlay, Qwindow); + Lisp_Object window = Foverlay_get (overlay, Qwindow); if (WINDOWP (window) && XWINDOW (window) != it->w) continue; /* If the text ``under'' the overlay is invisible, both before- and after-strings from this overlay are visible; start and end position are indistinguishable. */ - invisible = Foverlay_get (overlay, Qinvisible); - invis = TEXT_PROP_MEANS_INVISIBLE (invisible); + Lisp_Object invisible = Foverlay_get (overlay, Qinvisible); + int invis = TEXT_PROP_MEANS_INVISIBLE (invisible); /* If overlay has a non-empty before-string, record it. */ + Lisp_Object str; if ((start == charpos || (end == charpos && invis != 0)) && (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str)) && SCHARS (str)) @@ -5908,12 +5903,13 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos) } /* Process overlays after the overlay center. */ - for (ov = current_buffer->overlays_after; ov; ov = ov->next) + for (struct Lisp_Overlay *ov = current_buffer->overlays_after; + ov; ov = ov->next) { - XSETMISC (overlay, ov); + Lisp_Object overlay = make_lisp_ptr (ov, Lisp_Vectorlike); eassert (OVERLAYP (overlay)); - start = OVERLAY_POSITION (OVERLAY_START (overlay)); - end = OVERLAY_POSITION (OVERLAY_END (overlay)); + ptrdiff_t start = OVERLAY_POSITION (OVERLAY_START (overlay)); + ptrdiff_t end = OVERLAY_POSITION (OVERLAY_END (overlay)); if (start > charpos) break; @@ -5924,16 +5920,17 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos) continue; /* Skip this overlay if it doesn't apply to IT->w. */ - window = Foverlay_get (overlay, Qwindow); + Lisp_Object window = Foverlay_get (overlay, Qwindow); if (WINDOWP (window) && XWINDOW (window) != it->w) continue; /* If the text ``under'' the overlay is invisible, it has a zero dimension, and both before- and after-strings apply. */ - invisible = Foverlay_get (overlay, Qinvisible); - invis = TEXT_PROP_MEANS_INVISIBLE (invisible); + Lisp_Object invisible = Foverlay_get (overlay, Qinvisible); + int invis = TEXT_PROP_MEANS_INVISIBLE (invisible); /* If overlay has a non-empty before-string, record it. */ + Lisp_Object str; if ((start == charpos || (end == charpos && invis != 0)) && (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str)) && SCHARS (str)) @@ -5959,12 +5956,11 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos) /* IT->current.overlay_string_index is the number of overlay strings that have already been consumed by IT. Copy some of the remaining overlay strings to IT->overlay_strings. */ - i = 0; - j = it->current.overlay_string_index; - while (i < OVERLAY_STRING_CHUNK_SIZE && j < n) + ptrdiff_t j = it->current.overlay_string_index; + for (ptrdiff_t i = 0; i < OVERLAY_STRING_CHUNK_SIZE && j < n; i++, j++) { it->overlay_strings[i] = entries[j].string; - it->string_overlays[i++] = entries[j++].overlay; + it->string_overlays[i] = entries[j].overlay; } CHECK_IT (it); @@ -6394,9 +6390,9 @@ forward_to_next_line_start (struct it *it, bool *skipped_p, overlays, we can just use the position of the newline in buffer text. */ if (it->stop_charpos >= limit - || ((pos = Fnext_single_property_change (make_number (start), + || ((pos = Fnext_single_property_change (make_fixnum (start), Qdisplay, Qnil, - make_number (limit)), + make_fixnum (limit)), NILP (pos)) && next_overlay_change (start) == ZV)) { @@ -6472,7 +6468,7 @@ back_to_previous_visible_line_start (struct it *it) /* Check the newline before point for invisibility. */ { Lisp_Object prop; - prop = Fget_char_property (make_number (IT_CHARPOS (*it) - 1), + prop = Fget_char_property (make_fixnum (IT_CHARPOS (*it) - 1), Qinvisible, it->window); if (TEXT_PROP_MEANS_INVISIBLE (prop) != 0) continue; @@ -6505,7 +6501,7 @@ back_to_previous_visible_line_start (struct it *it) it2.from_disp_prop_p = false; if (handle_display_prop (&it2) == HANDLED_RETURN && !NILP (val = get_char_property_and_overlay - (make_number (pos), Qdisplay, Qnil, &overlay)) + (make_fixnum (pos), Qdisplay, Qnil, &overlay)) && (OVERLAYP (overlay) ? (beg = OVERLAY_POSITION (OVERLAY_START (overlay))) : get_property_and_range (pos, Qdisplay, &val, &beg, &end, Qnil))) @@ -6993,7 +6989,7 @@ merge_escape_glyph_face (struct it *it) else { /* Merge the `escape-glyph' face into the current face. */ - face_id = merge_faces (it->f, Qescape_glyph, 0, it->face_id); + face_id = merge_faces (it->w, Qescape_glyph, 0, it->face_id); last_escape_glyph_frame = it->f; last_escape_glyph_face_id = it->face_id; last_escape_glyph_merged_face_id = face_id; @@ -7018,7 +7014,7 @@ merge_glyphless_glyph_face (struct it *it) else { /* Merge the `glyphless-char' face into the current face. */ - face_id = merge_faces (it->f, Qglyphless_char, 0, it->face_id); + face_id = merge_faces (it->w, Qglyphless_char, 0, it->face_id); last_glyphless_glyph_frame = it->f; last_glyphless_glyph_face_id = it->face_id; last_glyphless_glyph_merged_face_id = face_id; @@ -7192,7 +7188,7 @@ get_next_display_element (struct it *it) } face_id = (lface_id - ? merge_faces (it->f, Qt, lface_id, it->face_id) + ? merge_faces (it->w, Qt, lface_id, it->face_id) : merge_escape_glyph_face (it)); XSETINT (it->ctl_chars[0], g); @@ -7207,7 +7203,7 @@ get_next_display_element (struct it *it) if (nonascii_space_p && EQ (Vnobreak_char_display, Qt)) { /* Merge `nobreak-space' into the current face. */ - face_id = merge_faces (it->f, Qnobreak_space, 0, + face_id = merge_faces (it->w, Qnobreak_space, 0, it->face_id); XSETINT (it->ctl_chars[0], ' '); ctl_len = 1; @@ -7220,7 +7216,7 @@ get_next_display_element (struct it *it) 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, + face_id = merge_faces (it->w, Qnobreak_hyphen, 0, it->face_id); XSETINT (it->ctl_chars[0], '-'); ctl_len = 1; @@ -7240,7 +7236,7 @@ get_next_display_element (struct it *it) } face_id = (lface_id - ? merge_faces (it->f, Qt, lface_id, it->face_id) + ? merge_faces (it->w, Qt, lface_id, it->face_id) : merge_escape_glyph_face (it)); /* Draw non-ASCII space/hyphen with escape glyph: */ @@ -7868,7 +7864,7 @@ next_element_from_display_vector (struct it *it) { int lface_id = GLYPH_CODE_FACE (gc); if (lface_id > 0) - it->face_id = merge_faces (it->f, Qt, lface_id, + it->face_id = merge_faces (it->w, Qt, lface_id, it->saved_face_id); } @@ -7897,7 +7893,7 @@ next_element_from_display_vector (struct it *it) GLYPH_CODE_FACE (it->dpvec[it->current.dpvec_index + 1]); if (lface_id > 0) - next_face_id = merge_faces (it->f, Qt, lface_id, + next_face_id = merge_faces (it->w, Qt, lface_id, it->saved_face_id); } } @@ -8197,7 +8193,7 @@ next_element_from_c_string (struct it *it) eassert (!it->bidi_p || it->s == it->bidi_it.string.s); it->what = IT_CHARACTER; BYTEPOS (it->position) = CHARPOS (it->position) = 0; - it->object = make_number (0); + it->object = make_fixnum (0); /* With bidi reordering, the character to display might not be the character at IT_CHARPOS. BIDI_IT.FIRST_ELT means that @@ -8393,7 +8389,7 @@ next_element_from_buffer (struct it *it) eassert (IT_CHARPOS (*it) >= BEGV); eassert (NILP (it->string) && !it->s); eassert (!it->bidi_p - || (EQ (it->bidi_it.string.lstring, Qnil) + || (NILP (it->bidi_it.string.lstring) && it->bidi_it.string.s == NULL)); /* With bidi reordering, the character to display might not be the @@ -8579,7 +8575,7 @@ run_redisplay_end_trigger_hook (struct it *it) them again, even if they get an error. */ wset_redisplay_end_trigger (it->w, Qnil); CALLN (Frun_hook_with_args, Qredisplay_end_trigger_functions, it->window, - make_number (charpos)); + make_fixnum (charpos)); /* Notice if it changed the face of the character we are on. */ handle_face_prop (it); @@ -10152,8 +10148,8 @@ include the height of both, if present, in the return value. */) } else { - CHECK_NUMBER_COERCE_MARKER (from); - start = min (max (XINT (from), BEGV), ZV); + CHECK_FIXNUM_COERCE_MARKER (from); + start = min (max (XFIXNUM (from), BEGV), ZV); } if (NILP (to)) @@ -10169,17 +10165,17 @@ include the height of both, if present, in the return value. */) } else { - CHECK_NUMBER_COERCE_MARKER (to); - end = max (start, min (XINT (to), ZV)); + CHECK_FIXNUM_COERCE_MARKER (to); + end = max (start, min (XFIXNUM (to), ZV)); } - if (!NILP (x_limit) && RANGED_INTEGERP (0, x_limit, INT_MAX)) - max_x = XINT (x_limit); + if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX)) + max_x = XFIXNUM (x_limit); if (NILP (y_limit)) max_y = INT_MAX; - else if (RANGED_INTEGERP (0, y_limit, INT_MAX)) - max_y = XINT (y_limit); + else if (RANGED_FIXNUMP (0, y_limit, INT_MAX)) + max_y = XFIXNUM (y_limit); itdata = bidi_shelve_cache (); SET_TEXT_POS (startp, start, CHAR_TO_BYTE (start)); @@ -10259,7 +10255,7 @@ include the height of both, if present, in the return value. */) if (old_b) set_buffer_internal (old_b); - return Fcons (make_number (x), make_number (y)); + return Fcons (make_fixnum (x), make_fixnum (y)); } /*********************************************************************** @@ -10427,6 +10423,13 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte) ptrdiff_t this_bol, this_bol_byte, prev_bol, prev_bol_byte; printmax_t dups; + /* Since we call del_range_both passing false for PREPARE, + we aren't prepared to run modification hooks (we could + end up calling modification hooks from another buffer and + only with AFTER=t, Bug#21824). */ + ptrdiff_t count = SPECPDL_INDEX (); + specbind (Qinhibit_modification_hooks, Qt); + insert_1_both ("\n", 1, 1, true, false, false); scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, -2, false); @@ -10466,12 +10469,14 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte) in the *Messages* buffer now, delete the oldest ones. This is safe because we don't have undo in this buffer. */ - if (NATNUMP (Vmessage_log_max)) + if (FIXNATP (Vmessage_log_max)) { scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, - -XFASTINT (Vmessage_log_max) - 1, false); + -XFIXNAT (Vmessage_log_max) - 1, false); del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, false); } + + unbind_to (count, Qnil); } BEGV = marker_position (oldbegv); BEGV_BYTE = marker_byte_position (oldbegv); @@ -10972,22 +10977,22 @@ with_echo_area_buffer_unwind_data (struct window *w) Vwith_echo_area_save_vector = Qnil; if (NILP (vector)) - vector = Fmake_vector (make_number (11), Qnil); + vector = make_nil_vector (11); XSETBUFFER (tmp, current_buffer); ASET (vector, i, tmp); ++i; ASET (vector, i, Vdeactivate_mark); ++i; - ASET (vector, i, make_number (windows_or_buffers_changed)); ++i; + ASET (vector, i, make_fixnum (windows_or_buffers_changed)); ++i; if (w) { XSETWINDOW (tmp, w); ASET (vector, i, tmp); ++i; ASET (vector, i, w->contents); ++i; - ASET (vector, i, make_number (marker_position (w->pointm))); ++i; - ASET (vector, i, make_number (marker_byte_position (w->pointm))); ++i; - ASET (vector, i, make_number (marker_position (w->old_pointm))); ++i; - ASET (vector, i, make_number (marker_byte_position (w->old_pointm))); ++i; - ASET (vector, i, make_number (marker_position (w->start))); ++i; - ASET (vector, i, make_number (marker_byte_position (w->start))); ++i; + ASET (vector, i, make_fixnum (marker_position (w->pointm))); ++i; + ASET (vector, i, make_fixnum (marker_byte_position (w->pointm))); ++i; + ASET (vector, i, make_fixnum (marker_position (w->old_pointm))); ++i; + ASET (vector, i, make_fixnum (marker_byte_position (w->old_pointm))); ++i; + ASET (vector, i, make_fixnum (marker_position (w->start))); ++i; + ASET (vector, i, make_fixnum (marker_byte_position (w->start))); ++i; } else { @@ -11009,7 +11014,7 @@ unwind_with_echo_area_buffer (Lisp_Object vector) { set_buffer_internal_1 (XBUFFER (AREF (vector, 0))); Vdeactivate_mark = AREF (vector, 1); - windows_or_buffers_changed = XFASTINT (AREF (vector, 2)); + windows_or_buffers_changed = XFIXNAT (AREF (vector, 2)); if (WINDOWP (AREF (vector, 3))) { @@ -11021,14 +11026,14 @@ unwind_with_echo_area_buffer (Lisp_Object vector) wset_buffer (w, buffer); set_marker_both (w->pointm, buffer, - XFASTINT (AREF (vector, 5)), - XFASTINT (AREF (vector, 6))); + XFIXNAT (AREF (vector, 5)), + XFIXNAT (AREF (vector, 6))); set_marker_both (w->old_pointm, buffer, - XFASTINT (AREF (vector, 7)), - XFASTINT (AREF (vector, 8))); + XFIXNAT (AREF (vector, 7)), + XFIXNAT (AREF (vector, 8))); set_marker_both (w->start, buffer, - XFASTINT (AREF (vector, 9)), - XFASTINT (AREF (vector, 10))); + XFIXNAT (AREF (vector, 9)), + XFIXNAT (AREF (vector, 10))); } Vwith_echo_area_save_vector = vector; @@ -11070,10 +11075,18 @@ setup_echo_area_for_printing (bool multibyte_p) } TEMP_SET_PT_BOTH (BEG, BEG_BYTE); - /* Set up the buffer for the multibyteness we need. */ - if (multibyte_p - != !NILP (BVAR (current_buffer, enable_multibyte_characters))) - Fset_buffer_multibyte (multibyte_p ? Qt : Qnil); + /* Set up the buffer for the multibyteness we need. We always + set it to be multibyte, except when + unibyte-display-via-language-environment is non-nil and the + buffer from which we are called is unibyte, because in that + case unibyte characters should not be displayed as octal + escapes. */ + if (unibyte_display_via_language_environment + && !multibyte_p + && !NILP (BVAR (current_buffer, enable_multibyte_characters))) + Fset_buffer_multibyte (Qnil); + else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) + Fset_buffer_multibyte (Qt); /* Raise the frame containing the echo area. */ if (minibuffer_auto_raise) @@ -11149,7 +11162,7 @@ display_echo_area (struct window *w) /* Helper for display_echo_area. Display the current buffer which contains the current echo area message in window W, a mini-window, - a pointer to which is passed in A1. A2..A4 are currently not used. + a pointer to which is passed in A1. A2 is currently not used. Change the height of W so that all of the message is displayed. Value is true if height of W was changed. */ @@ -11210,8 +11223,8 @@ resize_echo_area_exactly (void) /* Callback function for with_echo_area_buffer, when used from resize_echo_area_exactly. A1 contains a pointer to the window to resize, EXACTLY non-nil means resize the mini-window exactly to the - size of the text displayed. A3 and A4 are not used. Value is what - resize_mini_window returns. */ + size of the text displayed. Value is what resize_mini_window + returns. */ static bool resize_mini_window_1 (ptrdiff_t a1, Lisp_Object exactly) @@ -11280,8 +11293,8 @@ resize_mini_window (struct window *w, bool exact_p) /* Compute the max. number of lines specified by the user. */ if (FLOATP (Vmax_mini_window_height)) max_height = XFLOAT_DATA (Vmax_mini_window_height) * total_height; - else if (INTEGERP (Vmax_mini_window_height)) - max_height = XINT (Vmax_mini_window_height) * unit; + else if (FIXNUMP (Vmax_mini_window_height)) + max_height = XFIXNUM (Vmax_mini_window_height) * unit; else max_height = total_height / 4; @@ -11519,10 +11532,17 @@ set_message_1 (ptrdiff_t a1, Lisp_Object string) { eassert (STRINGP (string)); - /* Change multibyteness of the echo buffer appropriately. */ - if (message_enable_multibyte - != !NILP (BVAR (current_buffer, enable_multibyte_characters))) - Fset_buffer_multibyte (message_enable_multibyte ? Qt : Qnil); + /* Change multibyteness of the echo buffer appropriately. We always + set it to be multibyte, except when + unibyte-display-via-language-environment is non-nil and the + string to display is unibyte, because in that case unibyte + characters should not be displayed as octal escapes. */ + if (!message_enable_multibyte + && unibyte_display_via_language_environment + && !NILP (BVAR (current_buffer, enable_multibyte_characters))) + Fset_buffer_multibyte (Qnil); + else if (NILP (BVAR (current_buffer, enable_multibyte_characters))) + Fset_buffer_multibyte (Qt); bset_truncate_lines (current_buffer, message_truncate_lines ? Qt : Qnil); if (!NILP (BVAR (current_buffer, bidi_display_reordering))) @@ -11830,10 +11850,10 @@ format_mode_line_unwind_data (struct frame *target_frame, Vmode_line_unwind_vector = Qnil; if (NILP (vector)) - vector = Fmake_vector (make_number (10), Qnil); + vector = make_nil_vector (12); - ASET (vector, 0, make_number (mode_line_target)); - ASET (vector, 1, make_number (MODE_LINE_NOPROP_LEN (0))); + ASET (vector, 0, make_fixnum (mode_line_target)); + ASET (vector, 1, make_fixnum (MODE_LINE_NOPROP_LEN (0))); ASET (vector, 2, mode_line_string_list); ASET (vector, 3, save_proptrans ? mode_line_proptrans_alist : Qt); ASET (vector, 4, mode_line_string_face); @@ -11847,12 +11867,24 @@ format_mode_line_unwind_data (struct frame *target_frame, ASET (vector, 7, owin); if (target_frame) { + Lisp_Object buffer = XWINDOW (target_frame->selected_window)->contents; + struct buffer *b = XBUFFER (buffer); + struct buffer *cb = current_buffer; + /* Similarly to `with-selected-window', if the operation selects a window on another frame, we must restore that frame's selected window, and (for a tty) the top-frame. */ ASET (vector, 8, target_frame->selected_window); if (FRAME_TERMCAP_P (target_frame)) ASET (vector, 9, FRAME_TTY (target_frame)->top_frame); + + /* If we select a window on another frame, make sure that that + selection does not leave its buffer's point modified when + unwinding (Bug#32777). */ + ASET (vector, 10, buffer); + current_buffer = b; + ASET (vector, 11, build_marker (current_buffer, PT, PT_BYTE)); + current_buffer = cb; } return vector; @@ -11865,8 +11897,8 @@ unwind_format_mode_line (Lisp_Object vector) Lisp_Object target_frame_window = AREF (vector, 8); Lisp_Object old_top_frame = AREF (vector, 9); - mode_line_target = XINT (AREF (vector, 0)); - mode_line_noprop_ptr = mode_line_noprop_buf + XINT (AREF (vector, 1)); + mode_line_target = XFIXNUM (AREF (vector, 0)); + mode_line_noprop_ptr = mode_line_noprop_buf + XFIXNUM (AREF (vector, 1)); mode_line_string_list = AREF (vector, 2); if (! EQ (AREF (vector, 3), Qt)) mode_line_proptrans_alist = AREF (vector, 3); @@ -11892,6 +11924,24 @@ unwind_format_mode_line (Lisp_Object vector) } Fselect_window (old_window, Qt); + + /* Restore point of target_frame_window's buffer (Bug#32777). + But do this only after old_window has been reselected to + avoid that the window point of target_frame_window moves. */ + if (!NILP (target_frame_window)) + { + Lisp_Object buffer = AREF (vector, 10); + + if (BUFFER_LIVE_P (XBUFFER (buffer))) + { + struct buffer *cb = current_buffer; + + current_buffer = XBUFFER (buffer); + set_point_from_marker (AREF (vector, 11)); + ASET (vector, 11, Qnil); + current_buffer = cb; + } + } } if (!NILP (AREF (vector, 6))) @@ -11976,7 +12026,7 @@ x_consider_frame_title (Lisp_Object frame) if ((FRAME_WINDOW_P (f) || FRAME_MINIBUF_ONLY_P (f) || f->explicit_name) - && NILP (Fframe_parameter (frame, Qtooltip))) + && !FRAME_TOOLTIP_P (f)) { /* Do we have more than one visible frame on this X display? */ Lisp_Object tail, other_frame, fmt; @@ -11993,8 +12043,8 @@ x_consider_frame_title (Lisp_Object frame) if (tf != f && FRAME_KBOARD (tf) == FRAME_KBOARD (f) && !FRAME_MINIBUF_ONLY_P (tf) - && !EQ (other_frame, tip_frame) && !FRAME_PARENT_FRAME (tf) + && !FRAME_TOOLTIP_P (tf) && (FRAME_VISIBLE_P (tf) || FRAME_ICONIFIED_P (tf))) break; } @@ -12063,13 +12113,6 @@ prepare_menu_bars (void) { bool all_windows = windows_or_buffers_changed || update_mode_lines; bool some_windows = REDISPLAY_SOME_P (); - Lisp_Object tooltip_frame; - -#ifdef HAVE_WINDOW_SYSTEM - tooltip_frame = tip_frame; -#else - tooltip_frame = Qnil; -#endif if (FUNCTIONP (Vpre_redisplay_function)) { @@ -12110,7 +12153,7 @@ prepare_menu_bars (void) && !XBUFFER (w->contents)->text->redisplay) continue; - if (!EQ (frame, tooltip_frame) + if (!FRAME_TOOLTIP_P (f) && !FRAME_PARENT_FRAME (f) && (FRAME_ICONIFIED_P (f) || FRAME_VISIBLE_P (f) == 1 @@ -12148,7 +12191,7 @@ prepare_menu_bars (void) struct window *w = XWINDOW (FRAME_SELECTED_WINDOW (f)); /* Ignore tooltip frame. */ - if (EQ (frame, tooltip_frame)) + if (FRAME_TOOLTIP_P (f)) continue; if (some_windows @@ -12433,11 +12476,11 @@ build_desired_tool_bar_string (struct frame *f) /* Reuse f->desired_tool_bar_string, if possible. */ if (size < size_needed || NILP (f->desired_tool_bar_string)) fset_desired_tool_bar_string - (f, Fmake_string (make_number (size_needed), make_number (' '))); + (f, Fmake_string (make_fixnum (size_needed), make_fixnum (' '), Qnil)); else { AUTO_LIST4 (props, Qdisplay, Qnil, Qmenu_item, Qnil); - Fremove_text_properties (make_number (0), make_number (size), + Fremove_text_properties (make_fixnum (0), make_fixnum (size), props, f->desired_tool_bar_string); } @@ -12486,21 +12529,21 @@ build_desired_tool_bar_string (struct frame *f) : DEFAULT_TOOL_BAR_BUTTON_RELIEF); hmargin = vmargin = relief; - if (RANGED_INTEGERP (1, Vtool_bar_button_margin, + if (RANGED_FIXNUMP (1, Vtool_bar_button_margin, INT_MAX - max (hmargin, vmargin))) { - hmargin += XFASTINT (Vtool_bar_button_margin); - vmargin += XFASTINT (Vtool_bar_button_margin); + hmargin += XFIXNAT (Vtool_bar_button_margin); + vmargin += XFIXNAT (Vtool_bar_button_margin); } else if (CONSP (Vtool_bar_button_margin)) { - if (RANGED_INTEGERP (1, XCAR (Vtool_bar_button_margin), + if (RANGED_FIXNUMP (1, XCAR (Vtool_bar_button_margin), INT_MAX - hmargin)) - hmargin += XFASTINT (XCAR (Vtool_bar_button_margin)); + hmargin += XFIXNAT (XCAR (Vtool_bar_button_margin)); - if (RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), + if (RANGED_FIXNUMP (1, XCDR (Vtool_bar_button_margin), INT_MAX - vmargin)) - vmargin += XFASTINT (XCDR (Vtool_bar_button_margin)); + vmargin += XFIXNAT (XCDR (Vtool_bar_button_margin)); } if (auto_raise_tool_bar_buttons_p) @@ -12509,7 +12552,7 @@ build_desired_tool_bar_string (struct frame *f) selected. */ if (selected_p) { - plist = Fplist_put (plist, QCrelief, make_number (-relief)); + plist = Fplist_put (plist, QCrelief, make_fixnum (-relief)); hmargin -= relief; vmargin -= relief; } @@ -12521,8 +12564,8 @@ build_desired_tool_bar_string (struct frame *f) raised relief. */ plist = Fplist_put (plist, QCrelief, (selected_p - ? make_number (-relief) - : make_number (relief))); + ? make_fixnum (-relief) + : make_fixnum (relief))); hmargin -= relief; vmargin -= relief; } @@ -12531,11 +12574,11 @@ build_desired_tool_bar_string (struct frame *f) if (hmargin || vmargin) { if (hmargin == vmargin) - plist = Fplist_put (plist, QCmargin, make_number (hmargin)); + plist = Fplist_put (plist, QCmargin, make_fixnum (hmargin)); else plist = Fplist_put (plist, QCmargin, - Fcons (make_number (hmargin), - make_number (vmargin))); + Fcons (make_fixnum (hmargin), + make_fixnum (vmargin))); } /* If button is not enabled, and we don't have special images @@ -12550,7 +12593,7 @@ build_desired_tool_bar_string (struct frame *f) vector. */ image = Fcons (Qimage, plist); AUTO_LIST4 (props, Qdisplay, image, Qmenu_item, - make_number (i * TOOL_BAR_ITEM_NSLOTS)); + make_fixnum (i * TOOL_BAR_ITEM_NSLOTS)); /* Let the last image hide all remaining spaces in the tool bar string. The string can be longer than needed when we reuse a @@ -12559,7 +12602,7 @@ build_desired_tool_bar_string (struct frame *f) end = SCHARS (f->desired_tool_bar_string); else end = i + 1; - Fadd_text_properties (make_number (i), make_number (end), + Fadd_text_properties (make_fixnum (i), make_fixnum (end), props, f->desired_tool_bar_string); #undef PROP } @@ -12765,7 +12808,7 @@ PIXELWISE non-nil means return the height of the tool bar in pixels. */) } #endif - return make_number (height); + return make_fixnum (height); } @@ -12836,8 +12879,8 @@ redisplay_tool_bar (struct frame *f) { int border, rows, height, extra; - if (TYPE_RANGED_INTEGERP (int, Vtool_bar_border)) - border = XINT (Vtool_bar_border); + if (TYPE_RANGED_FIXNUMP (int, Vtool_bar_border)) + border = XFIXNUM (Vtool_bar_border); else if (EQ (Vtool_bar_border, Qinternal_border_width)) border = FRAME_INTERNAL_BORDER_WIDTH (f); else if (EQ (Vtool_bar_border, Qborder_width)) @@ -12955,11 +12998,11 @@ tool_bar_item_info (struct frame *f, struct glyph *glyph, int *prop_idx) /* Get the text property `menu-item' at pos. The value of that property is the start index of this item's properties in F->tool_bar_items. */ - prop = Fget_text_property (make_number (charpos), + prop = Fget_text_property (make_fixnum (charpos), Qmenu_item, f->current_tool_bar_string); - if (! INTEGERP (prop)) + if (! FIXNUMP (prop)) return false; - *prop_idx = XINT (prop); + *prop_idx = XFIXNUM (prop); return true; } @@ -13204,9 +13247,9 @@ hscroll_window_tree (Lisp_Object window) hscroll_step_abs = 0; } } - else if (TYPE_RANGED_INTEGERP (int, Vhscroll_step)) + else if (TYPE_RANGED_FIXNUMP (int, Vhscroll_step)) { - hscroll_step_abs = XINT (Vhscroll_step); + hscroll_step_abs = XFIXNUM (Vhscroll_step); if (hscroll_step_abs < 0) hscroll_step_abs = 0; } @@ -13305,7 +13348,7 @@ hscroll_window_tree (Lisp_Object window) /* Remember window point. */ Fset_marker (w->old_pointm, ((w == XWINDOW (selected_window)) - ? make_number (BUF_PT (XBUFFER (w->contents))) + ? make_fixnum (BUF_PT (XBUFFER (w->contents))) : Fmarker_position (w->pointm)), w->contents); @@ -13562,8 +13605,8 @@ text_outside_line_unchanged_p (struct window *w, /* If selective display, can't optimize if changes start at the beginning of the line. */ if (unchanged_p - && INTEGERP (BVAR (current_buffer, selective_display)) - && XINT (BVAR (current_buffer, selective_display)) > 0 + && FIXNUMP (BVAR (current_buffer, selective_display)) + && XFIXNUM (BVAR (current_buffer, selective_display)) > 0 && (BEG_UNCHANGED < start || GPT <= start)) unchanged_p = false; @@ -13765,10 +13808,10 @@ overlay_arrow_at_row (struct it *it, struct glyph_row *row) { int fringe_bitmap = lookup_fringe_bitmap (val); if (fringe_bitmap != 0) - return make_number (fringe_bitmap); + return make_fixnum (fringe_bitmap); } #endif - return make_number (-1); /* Use default arrow bitmap. */ + return make_fixnum (-1); /* Use default arrow bitmap. */ } return overlay_arrow_string_or_property (var); } @@ -13934,7 +13977,15 @@ redisplay_internal (void) #if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) if (popup_activated ()) - return; + { +#ifdef NS_IMPL_COCOA + /* On macOS we may have disabled screen updates due to window + resizing. We should re-enable them so the popup can be + displayed. */ + ns_enable_screen_updates (); +#endif + return; + } #endif /* I don't think this happens but let's be paranoid. */ @@ -14135,9 +14186,9 @@ redisplay_internal (void) #define AINC(a,i) \ { \ - Lisp_Object entry = Fgethash (make_number (i), a, make_number (0)); \ - if (INTEGERP (entry)) \ - Fputhash (make_number (i), make_number (1 + XINT (entry)), a); \ + Lisp_Object entry = Fgethash (make_fixnum (i), a, make_fixnum (0)); \ + if (FIXNUMP (entry)) \ + Fputhash (make_fixnum (i), make_fixnum (1 + XFIXNUM (entry)), a); \ } AINC (Vredisplay__all_windows_cause, windows_or_buffers_changed); @@ -14331,7 +14382,7 @@ redisplay_internal (void) eassert (this_line_vpos == it.vpos); eassert (this_line_y == it.current_y); set_cursor_from_row (w, row, w->current_matrix, 0, 0, 0, 0); - if (cursor_row_fully_visible_p (w, false, true)) + if (cursor_row_fully_visible_p (w, false, true, false)) { #ifdef GLYPH_DEBUG *w->desired_matrix->method = 0; @@ -14740,6 +14791,12 @@ unwind_redisplay (void) { redisplaying_p = false; unblock_buffer_flips (); +#ifdef NS_IMPL_COCOA + /* On macOS we may have disabled screen updates due to window + resizing. When redisplay completes we want to re-enable + them. */ + ns_enable_screen_updates (); +#endif } @@ -15100,7 +15157,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row, Lisp_Object chprop; ptrdiff_t glyph_pos = glyph->charpos; - chprop = Fget_char_property (make_number (glyph_pos), Qcursor, + chprop = Fget_char_property (make_fixnum (glyph_pos), Qcursor, glyph->object); if (!NILP (chprop)) { @@ -15121,9 +15178,9 @@ set_cursor_from_row (struct window *w, struct glyph_row *row, if (prop_pos >= pos_before) bpos_max = prop_pos; } - if (INTEGERP (chprop)) + if (FIXNUMP (chprop)) { - bpos_covered = bpos_max + XINT (chprop); + bpos_covered = bpos_max + XFIXNUM (chprop); /* If the `cursor' property covers buffer positions up to and including point, we should display cursor on this glyph. Note that, if a `cursor' property on one @@ -15184,7 +15241,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row, Lisp_Object chprop; ptrdiff_t glyph_pos = glyph->charpos; - chprop = Fget_char_property (make_number (glyph_pos), Qcursor, + chprop = Fget_char_property (make_fixnum (glyph_pos), Qcursor, glyph->object); if (!NILP (chprop)) { @@ -15195,9 +15252,9 @@ set_cursor_from_row (struct window *w, struct glyph_row *row, if (prop_pos >= pos_before) bpos_max = prop_pos; } - if (INTEGERP (chprop)) + if (FIXNUMP (chprop)) { - bpos_covered = bpos_max + XINT (chprop); + bpos_covered = bpos_max + XFIXNUM (chprop); /* If the `cursor' property covers buffer positions up to and including point, we should display cursor on this glyph. */ @@ -15371,7 +15428,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row, Lisp_Object cprop; ptrdiff_t gpos = glyph->charpos; - cprop = Fget_char_property (make_number (gpos), + cprop = Fget_char_property (make_fixnum (gpos), Qcursor, glyph->object); if (!NILP (cprop)) @@ -15502,7 +15559,7 @@ set_cursor_from_row (struct window *w, struct glyph_row *row, /* Previous candidate is a glyph from a string that has a non-nil `cursor' property. */ || (STRINGP (g1->object) - && (!NILP (Fget_char_property (make_number (g1->charpos), + && (!NILP (Fget_char_property (make_fixnum (g1->charpos), Qcursor, g1->object)) /* Previous candidate is from the same display string as this one, and the display string @@ -15585,7 +15642,7 @@ run_window_scroll_functions (Lisp_Object window, struct text_pos startp) if (!NILP (Vwindow_scroll_functions)) { run_hook_with_args_2 (Qwindow_scroll_functions, window, - make_number (CHARPOS (startp))); + make_fixnum (CHARPOS (startp))); SET_TEXT_POS_FROM_MARKER (startp, w->start); /* In case the hook functions switch buffers. */ set_buffer_internal (XBUFFER (w->contents)); @@ -15607,19 +15664,46 @@ run_window_scroll_functions (Lisp_Object window, struct text_pos startp) window's current glyph matrix; otherwise use the desired glyph matrix. + If JUST_TEST_USER_PREFERENCE_P, just test what the value of + make-cursor-row-fully-visible requires, don't test the actual + cursor position. The assumption is that in that case the caller + performs the necessary testing of the cursor position. + A value of false means the caller should do scrolling as if point had gone off the screen. */ static bool cursor_row_fully_visible_p (struct window *w, bool force_p, - bool current_matrix_p) + bool current_matrix_p, + bool just_test_user_preference_p) { struct glyph_matrix *matrix; struct glyph_row *row; int window_height; + Lisp_Object mclfv_p = + buffer_local_value (Qmake_cursor_line_fully_visible, w->contents); - if (!make_cursor_line_fully_visible_p) + /* If no local binding, use the global value. */ + if (EQ (mclfv_p, Qunbound)) + mclfv_p = Vmake_cursor_line_fully_visible; + /* Follow mode sets the variable to a Lisp function in buffers that + are under Follow mode. */ + if (FUNCTIONP (mclfv_p)) + { + Lisp_Object window; + XSETWINDOW (window, w); + /* Implementation note: if the function we call here signals an + error, we will NOT scroll when the cursor is partially-visible. */ + Lisp_Object val = safe_call1 (mclfv_p, window); + if (NILP (val)) + return true; + else if (just_test_user_preference_p) + return false; + } + else if (NILP (mclfv_p)) return true; + else if (just_test_user_preference_p) + return false; /* It's not always possible to find the cursor, e.g, when a window is full of overlay strings. Don't do anything in that case. */ @@ -15981,7 +16065,7 @@ try_scrolling (Lisp_Object window, bool just_this_one_p, /* If cursor ends up on a partially visible line, treat that as being off the bottom of the screen. */ if (! cursor_row_fully_visible_p (w, extra_scroll_margin_lines <= 1, - false) + false, false) /* It's possible that the cursor is on the first line of the buffer, which is partially obscured due to a vscroll (Bug#7537). In that case, avoid looping forever. */ @@ -16346,7 +16430,7 @@ try_cursor_movement (Lisp_Object window, struct text_pos startp, /* Make sure this isn't a header line by any chance, since then MATRIX_ROW_PARTIALLY_VISIBLE_P might yield true. */ && !row->mode_line_p - && make_cursor_line_fully_visible_p) + && !cursor_row_fully_visible_p (w, true, true, true)) { if (PT == MATRIX_ROW_END_CHARPOS (row) && !row->ends_at_zv_p @@ -16364,7 +16448,7 @@ try_cursor_movement (Lisp_Object window, struct text_pos startp, else { set_cursor_from_row (w, row, w->current_matrix, 0, 0, 0, 0); - if (!cursor_row_fully_visible_p (w, false, true)) + if (!cursor_row_fully_visible_p (w, false, true, false)) rc = CURSOR_MOVEMENT_MUST_SCROLL; else rc = CURSOR_MOVEMENT_SUCCESS; @@ -16920,18 +17004,18 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) position past that. */ struct glyph_row *r = NULL; Lisp_Object invprop = - get_char_property_and_overlay (make_number (PT), Qinvisible, + get_char_property_and_overlay (make_fixnum (PT), Qinvisible, Qnil, NULL); if (TEXT_PROP_MEANS_INVISIBLE (invprop) != 0) { ptrdiff_t alt_pt; Lisp_Object invprop_end = - Fnext_single_char_property_change (make_number (PT), Qinvisible, + Fnext_single_char_property_change (make_fixnum (PT), Qinvisible, Qnil, Qnil); - if (NATNUMP (invprop_end)) - alt_pt = XFASTINT (invprop_end); + if (FIXNATP (invprop_end)) + alt_pt = XFIXNAT (invprop_end); else alt_pt = ZV; r = row_containing_pos (w, alt_pt, w->desired_matrix->rows, @@ -16943,7 +17027,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) new_vpos = window_box_height (w) / 2; } - if (!cursor_row_fully_visible_p (w, false, false)) + if (!cursor_row_fully_visible_p (w, false, false, false)) { /* Point does appear, but on a line partly visible at end of window. Move it back to a fully-visible line. */ @@ -17038,7 +17122,8 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) goto need_larger_matrices; } } - if (w->cursor.vpos < 0 || !cursor_row_fully_visible_p (w, false, false)) + if (w->cursor.vpos < 0 + || !cursor_row_fully_visible_p (w, false, false, false)) { clear_glyph_matrix (w->desired_matrix); goto try_to_scroll; @@ -17185,7 +17270,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) /* Forget any recorded base line for line number display. */ w->base_line_number = 0; - if (!cursor_row_fully_visible_p (w, true, false)) + if (!cursor_row_fully_visible_p (w, true, false, false)) { clear_glyph_matrix (w->desired_matrix); last_line_misfit = true; @@ -17452,18 +17537,18 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) if (!row) { Lisp_Object val = - get_char_property_and_overlay (make_number (PT), Qinvisible, + get_char_property_and_overlay (make_fixnum (PT), Qinvisible, Qnil, NULL); if (TEXT_PROP_MEANS_INVISIBLE (val) != 0) { ptrdiff_t alt_pos; Lisp_Object invis_end = - Fnext_single_char_property_change (make_number (PT), Qinvisible, + Fnext_single_char_property_change (make_fixnum (PT), Qinvisible, Qnil, Qnil); - if (NATNUMP (invis_end)) - alt_pos = XFASTINT (invis_end); + if (FIXNATP (invis_end)) + alt_pos = XFIXNAT (invis_end); else alt_pos = ZV; row = row_containing_pos (w, alt_pos, matrix->rows, NULL, 0); @@ -17481,7 +17566,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) set_cursor_from_row (w, row, matrix, 0, 0, 0, 0); } - if (!cursor_row_fully_visible_p (w, false, false)) + if (!cursor_row_fully_visible_p (w, false, false, false)) { /* If vscroll is enabled, disable it and try again. */ if (w->vscroll) @@ -19047,9 +19132,10 @@ try_window_id (struct window *w) && CHARPOS (start) > BEGV) /* Old redisplay didn't take scroll margin into account at the bottom, but then global-hl-line-mode doesn't scroll. KFS 2004-06-14 */ - || (w->cursor.y + (make_cursor_line_fully_visible_p - ? cursor_height + this_scroll_margin - : 1)) > it.last_visible_y) + || (w->cursor.y + + (cursor_row_fully_visible_p (w, false, true, true) + ? 1 + : cursor_height + this_scroll_margin)) > it.last_visible_y) { w->cursor.vpos = -1; clear_glyph_matrix (w->desired_matrix); @@ -19572,7 +19658,7 @@ with numeric argument, its value is passed as the GLYPHS flag. */) w->cursor.x, w->cursor.y, w->cursor.hpos, w->cursor.vpos); fprintf (stderr, "=============================================\n"); dump_glyph_matrix (w->current_matrix, - TYPE_RANGED_INTEGERP (int, glyphs) ? XINT (glyphs) : 0); + TYPE_RANGED_FIXNUMP (int, glyphs) ? XFIXNUM (glyphs) : 0); return Qnil; } @@ -19616,14 +19702,14 @@ GLYPHS > 1 or omitted means dump glyphs in long form. */) } else { - CHECK_NUMBER (row); - vpos = XINT (row); + CHECK_FIXNUM (row); + vpos = XFIXNUM (row); } matrix = XWINDOW (selected_window)->current_matrix; if (vpos >= 0 && vpos < matrix->nrows) dump_glyph_row (MATRIX_ROW (matrix, vpos), vpos, - TYPE_RANGED_INTEGERP (int, glyphs) ? XINT (glyphs) : 2); + TYPE_RANGED_FIXNUMP (int, glyphs) ? XFIXNUM (glyphs) : 2); return Qnil; } @@ -19648,12 +19734,12 @@ do nothing. */) vpos = 0; else { - CHECK_NUMBER (row); - vpos = XINT (row); + CHECK_FIXNUM (row); + vpos = XFIXNUM (row); } if (vpos >= 0 && vpos < m->nrows) dump_glyph_row (MATRIX_ROW (m, vpos), vpos, - TYPE_RANGED_INTEGERP (int, glyphs) ? XINT (glyphs) : 2); + TYPE_RANGED_FIXNUMP (int, glyphs) ? XFIXNUM (glyphs) : 2); #endif return Qnil; } @@ -19669,7 +19755,7 @@ With ARG, turn tracing on if and only if ARG is positive. */) else { arg = Fprefix_numeric_value (arg); - trace_redisplay_p = XINT (arg) > 0; + trace_redisplay_p = XFIXNUM (arg) > 0; } return Qnil; @@ -19735,7 +19821,7 @@ get_overlay_arrow_glyph_row (struct window *w, Lisp_Object overlay_arrow_string) p += it.len; /* Get its face. */ - ilisp = make_number (p - arrow_string); + ilisp = make_fixnum (p - arrow_string); face = Fget_text_property (ilisp, Qface, overlay_arrow_string); it.face_id = compute_char_face (f, it.char_to_display, face); @@ -20071,7 +20157,7 @@ append_space_for_newline (struct it *it, bool default_face_p) /* If the default face was remapped, be sure to use the remapped face for the appended newline. */ if (default_face_p) - it->face_id = lookup_basic_face (it->f, DEFAULT_FACE_ID); + it->face_id = lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID); else if (it->face_before_selective_p) it->face_id = it->saved_face_id; face = FACE_FROM_ID (it->f, it->face_id); @@ -20135,8 +20221,8 @@ append_space_for_newline (struct it *it, bool default_face_p) it->phys_ascent = it->ascent; it->phys_descent = it->descent; if (!NILP (height) - && XINT (height) > it->ascent + it->descent) - it->ascent = XINT (height) - it->descent; + && XFIXNUM (height) > it->ascent + it->descent) + it->ascent = XFIXNUM (height) - it->descent; if (!NILP (total_height)) spacing = calc_line_height_property (it, total_height, font, @@ -20147,9 +20233,9 @@ append_space_for_newline (struct it *it, bool default_face_p) spacing = calc_line_height_property (it, spacing, font, boff, false); } - if (INTEGERP (spacing)) + if (FIXNUMP (spacing)) { - extra_line_spacing = XINT (spacing); + extra_line_spacing = XFIXNUM (spacing); if (!NILP (total_height)) extra_line_spacing -= (it->phys_ascent + it->phys_descent); } @@ -20218,8 +20304,8 @@ extend_face_to_end_of_line (struct it *it) return; /* The default face, possibly remapped. */ - default_face = FACE_FROM_ID_OR_NULL (f, - lookup_basic_face (f, DEFAULT_FACE_ID)); + default_face = + FACE_FROM_ID_OR_NULL (f, lookup_basic_face (it->w, 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 @@ -20231,7 +20317,7 @@ extend_face_to_end_of_line (struct it *it) if (FRAME_WINDOW_P (f) && MATRIX_ROW_DISPLAYS_TEXT_P (it->glyph_row) && face->box == FACE_NO_BOX - && face->background == FRAME_BACKGROUND_PIXEL (f) + && FACE_COLOR_TO_PIXEL (face->background, f) == FRAME_BACKGROUND_PIXEL (f) #ifdef HAVE_WINDOW_SYSTEM && !face->stipple #endif @@ -20376,7 +20462,7 @@ extend_face_to_end_of_line (struct it *it) && (it->glyph_row->used[LEFT_MARGIN_AREA] < WINDOW_LEFT_MARGIN_WIDTH (it->w)) && !it->glyph_row->mode_line_p - && default_face->background != FRAME_BACKGROUND_PIXEL (f)) + && FACE_COLOR_TO_PIXEL (face->background, f) != FRAME_BACKGROUND_PIXEL (f)) { struct glyph *g = it->glyph_row->glyphs[LEFT_MARGIN_AREA]; struct glyph *e = g + it->glyph_row->used[LEFT_MARGIN_AREA]; @@ -20417,7 +20503,7 @@ extend_face_to_end_of_line (struct it *it) && (it->glyph_row->used[RIGHT_MARGIN_AREA] < WINDOW_RIGHT_MARGIN_WIDTH (it->w)) && !it->glyph_row->mode_line_p - && default_face->background != FRAME_BACKGROUND_PIXEL (f)) + && FACE_COLOR_TO_PIXEL (face->background, f) != FRAME_BACKGROUND_PIXEL (f)) { struct glyph *g = it->glyph_row->glyphs[RIGHT_MARGIN_AREA]; struct glyph *e = g + it->glyph_row->used[RIGHT_MARGIN_AREA]; @@ -20473,11 +20559,12 @@ trailing_whitespace_p (ptrdiff_t charpos) } -/* Highlight trailing whitespace, if any, in ROW. */ +/* Highlight trailing whitespace, if any, in row at IT. */ static void -highlight_trailing_whitespace (struct frame *f, struct glyph_row *row) +highlight_trailing_whitespace (struct it *it) { + struct glyph_row *row = it->glyph_row; int used = row->used[TEXT_AREA]; if (used) @@ -20522,7 +20609,7 @@ highlight_trailing_whitespace (struct frame *f, struct glyph_row *row) && glyph->u.ch == ' ')) && trailing_whitespace_p (glyph->charpos)) { - int face_id = lookup_named_face (f, Qtrailing_whitespace, false); + int face_id = lookup_named_face (it->w, it->f, Qtrailing_whitespace, false); if (face_id < 0) return; @@ -20584,7 +20671,7 @@ row_for_charpos_p (struct glyph_row *row, ptrdiff_t charpos) if (STRINGP (glyph->object)) { Lisp_Object prop - = Fget_char_property (make_number (charpos), + = Fget_char_property (make_fixnum (charpos), Qdisplay, Qnil); result = (!NILP (prop) @@ -20600,7 +20687,7 @@ row_for_charpos_p (struct glyph_row *row, ptrdiff_t charpos) { ptrdiff_t gpos = glyph->charpos; - if (!NILP (Fget_char_property (make_number (gpos), + if (!NILP (Fget_char_property (make_fixnum (gpos), Qcursor, s))) { result = true; @@ -20739,10 +20826,10 @@ get_it_property (struct it *it, Lisp_Object prop) Lisp_Object position, object = it->object; if (STRINGP (object)) - position = make_number (IT_STRING_CHARPOS (*it)); + position = make_fixnum (IT_STRING_CHARPOS (*it)); else if (BUFFERP (object)) { - position = make_number (IT_CHARPOS (*it)); + position = make_fixnum (IT_CHARPOS (*it)); object = it->window; } else @@ -21094,9 +21181,9 @@ maybe_produce_line_number (struct it *it) char lnum_buf[INT_STRLEN_BOUND (ptrdiff_t) + 1]; bool beyond_zv = IT_BYTEPOS (*it) >= ZV_BYTE ? true : false; ptrdiff_t lnum_offset = -1; /* to produce 1-based line numbers */ - int lnum_face_id = merge_faces (it->f, Qline_number, 0, DEFAULT_FACE_ID); + int lnum_face_id = merge_faces (it->w, Qline_number, 0, DEFAULT_FACE_ID); int current_lnum_face_id - = merge_faces (it->f, Qline_number_current_line, 0, DEFAULT_FACE_ID); + = merge_faces (it->w, Qline_number_current_line, 0, DEFAULT_FACE_ID); /* Compute point's line number if needed. */ if ((EQ (Vdisplay_line_numbers, Qrelative) || EQ (Vdisplay_line_numbers, Qvisual) @@ -21115,8 +21202,8 @@ maybe_produce_line_number (struct it *it) /* Compute the required width if needed. */ if (!it->lnum_width) { - if (NATNUMP (Vdisplay_line_numbers_width)) - it->lnum_width = XFASTINT (Vdisplay_line_numbers_width); + if (FIXNATP (Vdisplay_line_numbers_width)) + it->lnum_width = XFIXNAT (Vdisplay_line_numbers_width); /* Max line number to be displayed cannot be more than the one corresponding to the last row of the desired matrix. */ @@ -21286,13 +21373,7 @@ should_produce_line_number (struct it *it) #ifdef HAVE_WINDOW_SYSTEM /* Don't display line number in tooltip frames. */ - if (FRAMEP (tip_frame) && EQ (WINDOW_FRAME (it->w), tip_frame) -#ifdef USE_GTK - /* GTK builds store in tip_frame the frame that shows the tip, - so we need an additional test. */ - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) + if (FRAME_TOOLTIP_P (XFRAME (WINDOW_FRAME (it->w)))) return false; #endif @@ -21300,7 +21381,7 @@ should_produce_line_number (struct it *it) property, disable line numbers for this row. This is for packages such as company-mode, which need this for their tricky layout, where line numbers get in the way. */ - Lisp_Object val = Fget_char_property (make_number (IT_CHARPOS (*it)), + Lisp_Object val = Fget_char_property (make_fixnum (IT_CHARPOS (*it)), Qdisplay_line_numbers_disable, it->window); /* For ZV, we need to also look in empty overlays at that point, @@ -21563,7 +21644,8 @@ display_line (struct it *it, int cursor_vpos) portions of the screen will clear with the default face's background color. */ if (row->reversed_p - || lookup_basic_face (it->f, DEFAULT_FACE_ID) != DEFAULT_FACE_ID) + || lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID) + != DEFAULT_FACE_ID) extend_face_to_end_of_line (it); break; } @@ -22188,15 +22270,15 @@ display_line (struct it *it, int cursor_vpos) } else { - eassert (INTEGERP (overlay_arrow_string)); - row->overlay_arrow_bitmap = XINT (overlay_arrow_string); + eassert (FIXNUMP (overlay_arrow_string)); + row->overlay_arrow_bitmap = XFIXNUM (overlay_arrow_string); } overlay_arrow_seen = true; } /* Highlight trailing whitespace. */ if (!NILP (Vshow_trailing_whitespace)) - highlight_trailing_whitespace (it->f, it->glyph_row); + highlight_trailing_whitespace (it); /* Compute pixel dimensions of this line. */ compute_line_metrics (it); @@ -22452,8 +22534,8 @@ the `bidi-class' property of a character. */) set_buffer_temp (buf); validate_region (&from, &to); - from_pos = XINT (from); - to_pos = XINT (to); + from_pos = XFIXNUM (from); + to_pos = XFIXNUM (to); if (from_pos >= ZV) return Qnil; @@ -22495,7 +22577,7 @@ the `bidi-class' property of a character. */) bidi_unshelve_cache (itb_data, false); set_buffer_temp (old); - return (from_pos <= found && found < to_pos) ? make_number (found) : Qnil; + return (from_pos <= found && found < to_pos) ? make_fixnum (found) : Qnil; } DEFUN ("move-point-visually", Fmove_point_visually, @@ -22521,8 +22603,8 @@ Value is the new character position of point. */) && (GLYPH)->charpos >= 0 \ && !(GLYPH)->avoid_cursor_p) - CHECK_NUMBER (direction); - dir = XINT (direction); + CHECK_FIXNUM (direction); + dir = XFIXNUM (direction); if (dir > 0) dir = 1; else @@ -22555,7 +22637,7 @@ Value is the new character position of point. */) { SET_PT (g->charpos); w->cursor.vpos = -1; - return make_number (PT); + return make_fixnum (PT); } else if (!NILP (g->object) && !EQ (g->object, gpt->object)) { @@ -22580,7 +22662,7 @@ Value is the new character position of point. */) break; SET_PT (new_pos); w->cursor.vpos = -1; - return make_number (PT); + return make_fixnum (PT); } else if (ROW_GLYPH_NEWLINE_P (row, g)) { @@ -22596,7 +22678,7 @@ Value is the new character position of point. */) else break; w->cursor.vpos = -1; - return make_number (PT); + return make_fixnum (PT); } } if (g == e || NILP (g->object)) @@ -22617,7 +22699,7 @@ Value is the new character position of point. */) { SET_PT (MATRIX_ROW_END_CHARPOS (row) - 1); w->cursor.vpos = -1; - return make_number (PT); + return make_fixnum (PT); } g = row->glyphs[TEXT_AREA]; e = g + row->used[TEXT_AREA]; @@ -22645,7 +22727,7 @@ Value is the new character position of point. */) else continue; w->cursor.vpos = -1; - return make_number (PT); + return make_fixnum (PT); } } } @@ -22655,7 +22737,7 @@ Value is the new character position of point. */) { SET_PT (MATRIX_ROW_END_CHARPOS (row) - 1); w->cursor.vpos = -1; - return make_number (PT); + return make_fixnum (PT); } e = row->glyphs[TEXT_AREA]; g = e + row->used[TEXT_AREA] - 1; @@ -22683,7 +22765,7 @@ Value is the new character position of point. */) else continue; w->cursor.vpos = -1; - return make_number (PT); + return make_fixnum (PT); } } } @@ -22943,7 +23025,7 @@ Value is the new character position of point. */) SET_PT_BOTH (IT_CHARPOS (it), IT_BYTEPOS (it)); } - return make_number (PT); + return make_fixnum (PT); #undef ROW_GLYPH_NEWLINE_P } @@ -22992,8 +23074,8 @@ Emacs UBA implementation, in particular with the test suite. */) } else { - CHECK_NUMBER_COERCE_MARKER (vpos); - nrow = XINT (vpos); + CHECK_FIXNUM (vpos); + nrow = XFIXNUM (vpos); } /* We require up-to-date glyph matrix for this window. */ @@ -23032,7 +23114,7 @@ Emacs UBA implementation, in particular with the test suite. */) /* Create and fill the array. */ levels = make_uninit_vector (nglyphs); for (i = 0; g1 < g; i++, g1++) - ASET (levels, i, make_number (g1->resolved_level)); + ASET (levels, i, make_fixnum (g1->resolved_level)); } else /* Right-to-left glyph row. */ { @@ -23047,7 +23129,7 @@ Emacs UBA implementation, in particular with the test suite. */) nglyphs++; levels = make_uninit_vector (nglyphs); for (i = 0; g1 > g; i++, g1--) - ASET (levels, i, make_number (g1->resolved_level)); + ASET (levels, i, make_fixnum (g1->resolved_level)); } return levels; } @@ -23149,7 +23231,7 @@ display_menu_bar (struct window *w) break; /* Remember where item was displayed. */ - ASET (items, i + 3, make_number (it.hpos)); + ASET (items, i + 3, make_fixnum (it.hpos)); /* Display the item, pad with one space. */ if (it.current_x < it.last_visible_x) @@ -23356,6 +23438,23 @@ display_mode_lines (struct window *w) Lisp_Object old_frame_selected_window = XFRAME (new_frame)->selected_window; int n = 0; + if (window_wants_mode_line (w)) + { + Lisp_Object window; + Lisp_Object default_help + = buffer_local_value (Qmode_line_default_help_echo, w->contents); + + /* Set up mode line help echo. Do this before selecting w so it + can reasonably tell whether a mouse click will select w. */ + XSETWINDOW (window, w); + if (FUNCTIONP (default_help)) + wset_mode_line_help_echo (w, safe_call1 (default_help, window)); + else if (STRINGP (default_help)) + wset_mode_line_help_echo (w, default_help); + else + wset_mode_line_help_echo (w, Qnil); + } + selected_frame = new_frame; /* FIXME: If we were to allow the mode-line's computation changing the buffer or window's point, then we'd need select_window_1 here as well. */ @@ -23370,7 +23469,6 @@ display_mode_lines (struct window *w) { Lisp_Object window_mode_line_format = window_parameter (w, Qmode_line_format); - struct window *sel_w = XWINDOW (old_selected_window); /* Select mode line face based on the real selected window. */ @@ -23503,6 +23601,17 @@ move_elt_to_front (Lisp_Object elt, Lisp_Object list) return list; } +/* Subroutine to call Fset_text_properties through + internal_condition_case_n. ARGS are the arguments of + Fset_text_properties, in order. */ + +static Lisp_Object +safe_set_text_properties (ptrdiff_t nargs, Lisp_Object *args) +{ + eassert (nargs == 4); + return Fset_text_properties (args[0], args[1], args[2], args[3]); +} + /* Contribute ELT to the mode line for window IT->w. How it translates into text depends on its data type. @@ -23552,7 +23661,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, && (!NILP (props) || risky)) { Lisp_Object oprops, aelt; - oprops = Ftext_properties_at (make_number (0), elt); + oprops = Ftext_properties_at (make_fixnum (0), elt); /* If the starting string's properties are not what we want, translate the string. Also, if the string @@ -23597,15 +23706,24 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, = Fdelq (aelt, mode_line_proptrans_alist); elt = Fcopy_sequence (elt); - Fset_text_properties (make_number (0), Flength (elt), - props, elt); + /* PROPS might cause set-text-properties to signal + an error, so we call it via internal_condition_case_n, + to avoid an infloop in redisplay due to the error. */ + internal_condition_case_n (safe_set_text_properties, + 4, + ((Lisp_Object []) + {make_fixnum (0), + Flength (elt), + props, + elt}), + Qt, safe_eval_handler); /* Add this item to mode_line_proptrans_alist. */ mode_line_proptrans_alist = Fcons (Fcons (elt, props), mode_line_proptrans_alist); /* Truncate mode_line_proptrans_alist to at most 50 elements. */ - tem = Fnthcdr (make_number (50), + tem = Fnthcdr (make_fixnum (50), mode_line_proptrans_alist); if (! NILP (tem)) XSETCDR (tem, Qnil); @@ -23676,8 +23794,8 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, ? string_byte_to_char (elt, offset) : charpos + nchars); Lisp_Object mode_string - = Fsubstring (elt, make_number (charpos), - make_number (endpos)); + = Fsubstring (elt, make_fixnum (charpos), + make_fixnum (endpos)); n += store_mode_line_string (NULL, mode_string, false, 0, 0, Qnil); } @@ -23740,7 +23858,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, case MODE_LINE_STRING: { Lisp_Object tem = build_string (spec); - props = Ftext_properties_at (make_number (charpos), elt); + props = Ftext_properties_at (make_fixnum (charpos), elt); /* Should only keep face property in props */ n += store_mode_line_string (NULL, tem, false, field, prec, props); @@ -23897,9 +24015,9 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, elt = XCAR (elt); goto tail_recurse; } - else if (INTEGERP (car)) + else if (FIXNUMP (car)) { - register int lim = XINT (car); + register int lim = XFIXNUM (car); elt = XCDR (elt); if (lim < 0) { @@ -24014,23 +24132,23 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string, face = list2 (face, mode_line_string_face); props = Fplist_put (props, Qface, face); } - Fadd_text_properties (make_number (0), make_number (len), + Fadd_text_properties (make_fixnum (0), make_fixnum (len), props, lisp_string); } else { - len = XFASTINT (Flength (lisp_string)); + len = XFIXNAT (Flength (lisp_string)); if (precision > 0 && len > precision) { len = precision; - lisp_string = Fsubstring (lisp_string, make_number (0), make_number (len)); + lisp_string = Fsubstring (lisp_string, make_fixnum (0), make_fixnum (len)); precision = -1; } if (!NILP (mode_line_string_face)) { Lisp_Object face; if (NILP (props)) - props = Ftext_properties_at (make_number (0), lisp_string); + props = Ftext_properties_at (make_fixnum (0), lisp_string); face = Fplist_get (props, Qface); if (NILP (face)) face = mode_line_string_face; @@ -24041,7 +24159,7 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string, lisp_string = Fcopy_sequence (lisp_string); } if (!NILP (props)) - Fadd_text_properties (make_number (0), make_number (len), + Fadd_text_properties (make_fixnum (0), make_fixnum (len), props, lisp_string); } @@ -24054,9 +24172,10 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string, if (field_width > len) { field_width -= len; - lisp_string = Fmake_string (make_number (field_width), make_number (' ')); + lisp_string = Fmake_string (make_fixnum (field_width), make_fixnum (' '), + Qnil); if (!NILP (props)) - Fadd_text_properties (make_number (0), make_number (field_width), + Fadd_text_properties (make_fixnum (0), make_fixnum (field_width), props, lisp_string); mode_line_string_list = Fcons (lisp_string, mode_line_string_list); n += field_width; @@ -24093,7 +24212,7 @@ are the selected window and the WINDOW's buffer). */) struct window *w; struct buffer *old_buffer = NULL; int face_id; - bool no_props = INTEGERP (face); + bool no_props = FIXNUMP (face); ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object str; int string_start = 0; @@ -24169,8 +24288,7 @@ are the selected window and the WINDOW's buffer). */) empty_unibyte_string); } - unbind_to (count, Qnil); - return str; + return unbind_to (count, str); } /* Write a null-terminated, right justified decimal representation of @@ -24349,7 +24467,7 @@ decode_mode_spec_coding (Lisp_Object coding_system, char *buf, bool eol_flag) eolvalue = AREF (val, 2); *buf++ = multibyte - ? XFASTINT (CODING_ATTR_MNEMONIC (attrs)) + ? XFIXNAT (CODING_ATTR_MNEMONIC (attrs)) : ' '; if (eol_flag) @@ -24378,7 +24496,7 @@ decode_mode_spec_coding (Lisp_Object coding_system, char *buf, bool eol_flag) } else if (CHARACTERP (eoltype)) { - int c = XFASTINT (eoltype); + int c = XFIXNAT (eoltype); return buf + CHAR_STRING (c, (unsigned char *) buf); } else @@ -24584,8 +24702,8 @@ decode_mode_spec (struct window *w, register int c, int field_width, goto no_value; /* If the buffer is very big, don't waste time. */ - if (INTEGERP (Vline_number_display_limit) - && BUF_ZV (b) - BUF_BEGV (b) > XINT (Vline_number_display_limit)) + if (FIXNUMP (Vline_number_display_limit) + && BUF_ZV (b) - BUF_BEGV (b) > XFIXNUM (Vline_number_display_limit)) { w->base_line_pos = 0; w->base_line_number = 0; @@ -24790,7 +24908,7 @@ decode_mode_spec (struct window *w, register int c, int field_width, if (STRINGP (curdir)) val = call1 (intern ("file-remote-p"), curdir); - unbind_to (count, Qnil); + val = unbind_to (count, val); if (NILP (val)) return "-"; @@ -24873,7 +24991,7 @@ display_count_lines (ptrdiff_t start_byte, check only for newlines. */ bool selective_display = (!NILP (BVAR (current_buffer, selective_display)) - && !INTEGERP (BVAR (current_buffer, selective_display))); + && !FIXNUMP (BVAR (current_buffer, selective_display))); if (count > 0) { @@ -25272,13 +25390,13 @@ display may depend on `buffer-invisibility-spec', which see. */) (Lisp_Object pos) { Lisp_Object prop - = (NATNUMP (pos) || MARKERP (pos) + = (FIXNATP (pos) || MARKERP (pos) ? Fget_char_property (pos, Qinvisible, Qnil) : pos); int invis = TEXT_PROP_MEANS_INVISIBLE (prop); return (invis == 0 ? Qnil : invis == 1 ? Qt - : make_number (invis)); + : make_fixnum (invis)); } /* Calculate a width or height in pixels from a specification using @@ -25552,7 +25670,7 @@ calc_pixel_width_or_height (double *res, struct it *it, Lisp_Object prop, /* '(NUM)': absolute number of pixels. */ if (NUMBERP (car)) - { +{ double fact; int offset = width_p && align_to && *align_to < 0 ? it->lnum_pixel_width : 0; @@ -27177,23 +27295,23 @@ produce_image_glyph (struct it *it) slice.width = img->width; slice.height = img->height; - if (INTEGERP (it->slice.x)) - slice.x = XINT (it->slice.x); + if (FIXNUMP (it->slice.x)) + slice.x = XFIXNUM (it->slice.x); else if (FLOATP (it->slice.x)) slice.x = XFLOAT_DATA (it->slice.x) * img->width; - if (INTEGERP (it->slice.y)) - slice.y = XINT (it->slice.y); + if (FIXNUMP (it->slice.y)) + slice.y = XFIXNUM (it->slice.y); else if (FLOATP (it->slice.y)) slice.y = XFLOAT_DATA (it->slice.y) * img->height; - if (INTEGERP (it->slice.width)) - slice.width = XINT (it->slice.width); + if (FIXNUMP (it->slice.width)) + slice.width = XFIXNUM (it->slice.width); else if (FLOATP (it->slice.width)) slice.width = XFLOAT_DATA (it->slice.width) * img->width; - if (INTEGERP (it->slice.height)) - slice.height = XINT (it->slice.height); + if (FIXNUMP (it->slice.height)) + slice.height = XFIXNUM (it->slice.height); else if (FLOATP (it->slice.height)) slice.height = XFLOAT_DATA (it->slice.height) * img->height; @@ -27827,7 +27945,7 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font, face_name = XCAR (val); val = XCDR (val); if (!NUMBERP (val)) - val = make_number (1); + val = make_fixnum (1); if (NILP (face_name)) { height = it->ascent + it->descent; @@ -27849,10 +27967,10 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font, int face_id; struct face *face; - face_id = lookup_named_face (it->f, face_name, false); + face_id = lookup_named_face (it->w, it->f, face_name, false); face = FACE_FROM_ID_OR_NULL (it->f, face_id); if (face == NULL || ((font = face->font) == NULL)) - return make_number (-1); + return make_fixnum (-1); boff = font->baseline_offset; if (font->vertical_centering) boff = VCENTER_BASELINE_OFFSET (font, it->f) - boff; @@ -27870,12 +27988,17 @@ calc_line_height_property (struct it *it, Lisp_Object val, struct font *font, height = ascent + descent; scale: + /* FIXME: Check for overflow in multiplication or conversion. */ if (FLOATP (val)) height = (int)(XFLOAT_DATA (val) * height); else if (INTEGERP (val)) - height *= XINT (val); + { + intmax_t v; + if (integer_to_intmax (val, &v)) + height *= v; + } - return make_number (height); + return make_fixnum (height); } @@ -28363,8 +28486,8 @@ x_produce_glyphs (struct it *it) it->descent += face->box_line_width; } if (!NILP (height) - && XINT (height) > it->ascent + it->descent) - it->ascent = XINT (height) - it->descent; + && XFIXNUM (height) > it->ascent + it->descent) + it->ascent = XFIXNUM (height) - it->descent; if (!NILP (total_height)) spacing = calc_line_height_property (it, total_height, font, @@ -28375,9 +28498,9 @@ x_produce_glyphs (struct it *it) spacing = calc_line_height_property (it, spacing, font, boff, false); } - if (INTEGERP (spacing)) + if (FIXNUMP (spacing)) { - extra_line_spacing = XINT (spacing); + extra_line_spacing = XFIXNUM (spacing); if (!NILP (total_height)) extra_line_spacing -= (it->phys_ascent + it->phys_descent); } @@ -28594,7 +28717,7 @@ x_produce_glyphs (struct it *it) && font->default_ascent && CHAR_TABLE_P (Vuse_default_ascent) && !NILP (Faref (Vuse_default_ascent, - make_number (it->char_to_display)))) + make_fixnum (it->char_to_display)))) highest = font->default_ascent + boff; /* Draw the first glyph at the normal position. It may be @@ -28645,7 +28768,7 @@ x_produce_glyphs (struct it *it) if (font->relative_compose && (! CHAR_TABLE_P (Vignore_relative_composition) || NILP (Faref (Vignore_relative_composition, - make_number (ch))))) + make_fixnum (ch))))) { if (- descent >= font->relative_compose) @@ -29081,9 +29204,9 @@ get_specified_cursor_type (Lisp_Object arg, int *width) if (CONSP (arg) && EQ (XCAR (arg), Qbar) - && RANGED_INTEGERP (0, XCDR (arg), INT_MAX)) + && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX)) { - *width = XINT (XCDR (arg)); + *width = XFIXNUM (XCDR (arg)); return BAR_CURSOR; } @@ -29095,9 +29218,9 @@ get_specified_cursor_type (Lisp_Object arg, int *width) if (CONSP (arg) && EQ (XCAR (arg), Qhbar) - && RANGED_INTEGERP (0, XCDR (arg), INT_MAX)) + && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX)) { - *width = XINT (XCDR (arg)); + *width = XFIXNUM (XCDR (arg)); return HBAR_CURSOR; } @@ -30720,13 +30843,13 @@ on_hot_spot_p (Lisp_Object hot_spot, int x, int y) return false; if (!CONSP (XCDR (rect))) return false; - if (!(tem = XCAR (XCAR (rect)), INTEGERP (tem) && x >= XINT (tem))) + if (!(tem = XCAR (XCAR (rect)), FIXNUMP (tem) && x >= XFIXNUM (tem))) return false; - if (!(tem = XCDR (XCAR (rect)), INTEGERP (tem) && y >= XINT (tem))) + if (!(tem = XCDR (XCAR (rect)), FIXNUMP (tem) && y >= XFIXNUM (tem))) return false; - if (!(tem = XCAR (XCDR (rect)), INTEGERP (tem) && x <= XINT (tem))) + if (!(tem = XCAR (XCDR (rect)), FIXNUMP (tem) && x <= XFIXNUM (tem))) return false; - if (!(tem = XCDR (XCDR (rect)), INTEGERP (tem) && y <= XINT (tem))) + if (!(tem = XCDR (XCDR (rect)), FIXNUMP (tem) && y <= XFIXNUM (tem))) return false; return true; } @@ -30738,12 +30861,12 @@ on_hot_spot_p (Lisp_Object hot_spot, int x, int y) if (CONSP (circ) && CONSP (XCAR (circ)) && (lr = XCDR (circ), NUMBERP (lr)) - && (lx0 = XCAR (XCAR (circ)), INTEGERP (lx0)) - && (ly0 = XCDR (XCAR (circ)), INTEGERP (ly0))) + && (lx0 = XCAR (XCAR (circ)), FIXNUMP (lx0)) + && (ly0 = XCDR (XCAR (circ)), FIXNUMP (ly0))) { double r = XFLOATINT (lr); - double dx = XINT (lx0) - x; - double dy = XINT (ly0) - y; + double dx = XFIXNUM (lx0) - x; + double dy = XFIXNUM (ly0) - y; return (dx * dx + dy * dy <= r * r); } } @@ -30768,17 +30891,17 @@ on_hot_spot_p (Lisp_Object hot_spot, int x, int y) If count is odd, we are inside polygon. Pixels on edges may or may not be included depending on actual geometry of the polygon. */ - if ((lx = poly[n-2], !INTEGERP (lx)) - || (ly = poly[n-1], !INTEGERP (lx))) + if ((lx = poly[n-2], !FIXNUMP (lx)) + || (ly = poly[n-1], !FIXNUMP (lx))) return false; - x0 = XINT (lx), y0 = XINT (ly); + x0 = XFIXNUM (lx), y0 = XFIXNUM (ly); for (i = 0; i < n; i += 2) { int x1 = x0, y1 = y0; - if ((lx = poly[i], !INTEGERP (lx)) - || (ly = poly[i+1], !INTEGERP (ly))) + if ((lx = poly[i], !FIXNUMP (lx)) + || (ly = poly[i+1], !FIXNUMP (ly))) return false; - x0 = XINT (lx), y0 = XINT (ly); + x0 = XFIXNUM (lx), y0 = XFIXNUM (ly); /* Does this segment cross the X line? */ if (x0 >= x) @@ -30830,12 +30953,12 @@ Returns the alist element for the first matching AREA in MAP. */) if (NILP (map)) return Qnil; - CHECK_NUMBER (x); - CHECK_NUMBER (y); + CHECK_FIXNUM (x); + CHECK_FIXNUM (y); return find_hot_spot (map, - clip_to_bounds (INT_MIN, XINT (x), INT_MAX), - clip_to_bounds (INT_MIN, XINT (y), INT_MAX)); + clip_to_bounds (INT_MIN, XFIXNUM (x), INT_MAX), + clip_to_bounds (INT_MIN, XFIXNUM (y), INT_MAX)); } #endif /* HAVE_WINDOW_SYSTEM */ @@ -30894,9 +31017,6 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, struct window *w = XWINDOW (window); struct frame *f = XFRAME (w->frame); Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); -#ifdef HAVE_WINDOW_SYSTEM - Display_Info *dpyinfo; -#endif Cursor cursor = No_Cursor; Lisp_Object pointer = Qnil; int dx, dy, width, height; @@ -30986,11 +31106,12 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, #endif /* HAVE_WINDOW_SYSTEM */ if (STRINGP (string)) - pos = make_number (charpos); + pos = make_fixnum (charpos); /* Set the help text and mouse pointer. If the mouse is on a part of the mode line without any text (e.g. past the right edge of - the mode line text), use the default help text and pointer. */ + the mode line text), use that windows's mode line help echo if it + has been set. */ if (STRINGP (string) || area == ON_MODE_LINE) { /* Arrange to display the help by setting the global variables @@ -31007,19 +31128,13 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, help_echo_object = string; help_echo_pos = charpos; } - else if (area == ON_MODE_LINE) + else if (area == ON_MODE_LINE + && !NILP (w->mode_line_help_echo)) { - Lisp_Object default_help - = buffer_local_value (Qmode_line_default_help_echo, - w->contents); - - if (STRINGP (default_help)) - { - help_echo_string = default_help; - XSETWINDOW (help_echo_window, w); - help_echo_object = Qnil; - help_echo_pos = -1; - } + help_echo_string = w->mode_line_help_echo; + XSETWINDOW (help_echo_window, w); + help_echo_object = Qnil; + help_echo_pos = -1; } } @@ -31031,7 +31146,6 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, || minibuf_level || NILP (Vresize_mini_windows)); - dpyinfo = FRAME_DISPLAY_INFO (f); if (STRINGP (string)) { cursor = FRAME_X_OUTPUT (f)->nontext_cursor; @@ -31041,25 +31155,28 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, /* Change the mouse pointer according to what is under X/Y. */ if (NILP (pointer) - && ((area == ON_MODE_LINE) || (area == ON_HEADER_LINE))) + && (area == ON_MODE_LINE || area == ON_HEADER_LINE)) { Lisp_Object map; + map = Fget_text_property (pos, Qlocal_map, string); if (!KEYMAPP (map)) map = Fget_text_property (pos, Qkeymap, string); - if (!KEYMAPP (map) && draggable) - cursor = dpyinfo->vertical_scroll_bar_cursor; + if (!KEYMAPP (map) && draggable && area == ON_MODE_LINE) + cursor = FRAME_X_OUTPUT (f)->vertical_drag_cursor; } } - else if (draggable) - /* Default mode-line pointer. */ - cursor = FRAME_DISPLAY_INFO (f)->vertical_scroll_bar_cursor; + else if (draggable && area == ON_MODE_LINE) + cursor = FRAME_X_OUTPUT (f)->vertical_drag_cursor; + else + cursor = FRAME_X_OUTPUT (f)->nontext_cursor; } #endif } /* Change the mouse face according to what is under X/Y. */ bool mouse_face_shown = false; + if (STRINGP (string)) { mouse_face = Fget_text_property (pos, Qmouse_face, string); @@ -31078,18 +31195,18 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, int vpos, hpos; - b = Fprevious_single_property_change (make_number (charpos + 1), + b = Fprevious_single_property_change (make_fixnum (charpos + 1), Qmouse_face, string, Qnil); if (NILP (b)) begpos = 0; else - begpos = XINT (b); + begpos = XFIXNUM (b); e = Fnext_single_property_change (pos, Qmouse_face, string, Qnil); if (NILP (e)) endpos = SCHARS (string); else - endpos = XINT (e); + endpos = XFIXNUM (e); /* Calculate the glyph position GPOS of GLYPH in the displayed string, relative to the beginning of the @@ -31487,7 +31604,7 @@ note_mouse_highlight (struct frame *f, int x, int y) ZV = Z; /* Is this char mouse-active or does it have help-echo? */ - position = make_number (pos); + position = make_fixnum (pos); USE_SAFE_ALLOCA; @@ -31558,15 +31675,15 @@ note_mouse_highlight (struct frame *f, int x, int y) ptrdiff_t ignore; s = Fprevious_single_property_change - (make_number (pos + 1), Qmouse_face, object, Qnil); + (make_fixnum (pos + 1), Qmouse_face, object, Qnil); e = Fnext_single_property_change (position, Qmouse_face, object, Qnil); if (NILP (s)) - s = make_number (0); + s = make_fixnum (0); if (NILP (e)) - e = make_number (SCHARS (object)); + e = make_fixnum (SCHARS (object)); mouse_face_from_string_pos (w, hlinfo, object, - XINT (s), XINT (e)); + XFIXNUM (s), XFIXNUM (e)); hlinfo->mouse_face_past_end = false; hlinfo->mouse_face_window = window; hlinfo->mouse_face_face_id @@ -31592,7 +31709,7 @@ note_mouse_highlight (struct frame *f, int x, int y) if (pos > 0) { mouse_face = get_char_property_and_overlay - (make_number (pos), Qmouse_face, w->contents, &overlay); + (make_fixnum (pos), Qmouse_face, w->contents, &overlay); buffer = w->contents; disp_string = object; } @@ -31623,7 +31740,7 @@ note_mouse_highlight (struct frame *f, int x, int y) : Qnil; Lisp_Object lim2 = NILP (BVAR (XBUFFER (buffer), bidi_display_reordering)) - ? make_number (BUF_Z (XBUFFER (buffer)) + ? make_fixnum (BUF_Z (XBUFFER (buffer)) - w->window_end_pos) : Qnil; @@ -31631,9 +31748,9 @@ note_mouse_highlight (struct frame *f, int x, int y) { /* Handle the text property case. */ before = Fprevious_single_property_change - (make_number (pos + 1), Qmouse_face, buffer, lim1); + (make_fixnum (pos + 1), Qmouse_face, buffer, lim1); after = Fnext_single_property_change - (make_number (pos), Qmouse_face, buffer, lim2); + (make_fixnum (pos), Qmouse_face, buffer, lim2); before_string = after_string = Qnil; } else @@ -31651,10 +31768,10 @@ note_mouse_highlight (struct frame *f, int x, int y) mouse_face_from_buffer_pos (window, hlinfo, pos, NILP (before) ? 1 - : XFASTINT (before), + : XFIXNAT (before), NILP (after) ? BUF_Z (XBUFFER (buffer)) - : XFASTINT (after), + : XFIXNAT (after), before_string, after_string, disp_string); cursor = No_Cursor; @@ -31693,7 +31810,7 @@ note_mouse_highlight (struct frame *f, int x, int y) && charpos >= 0 && charpos < SCHARS (obj)) { - help = Fget_text_property (make_number (charpos), + help = Fget_text_property (make_fixnum (charpos), Qhelp_echo, obj); if (NILP (help)) { @@ -31705,7 +31822,7 @@ note_mouse_highlight (struct frame *f, int x, int y) ptrdiff_t p = string_buffer_position (obj, start); if (p > 0) { - help = Fget_char_property (make_number (p), + help = Fget_char_property (make_fixnum (p), Qhelp_echo, w->contents); if (!NILP (help)) { @@ -31718,7 +31835,7 @@ note_mouse_highlight (struct frame *f, int x, int y) else if (BUFFERP (obj) && charpos >= BEGV && charpos < ZV) - help = Fget_text_property (make_number (charpos), Qhelp_echo, + help = Fget_text_property (make_fixnum (charpos), Qhelp_echo, obj); if (!NILP (help)) @@ -31749,7 +31866,7 @@ note_mouse_highlight (struct frame *f, int x, int y) && charpos >= 0 && charpos < SCHARS (obj)) { - pointer = Fget_text_property (make_number (charpos), + pointer = Fget_text_property (make_fixnum (charpos), Qpointer, obj); if (NILP (pointer)) { @@ -31760,14 +31877,14 @@ note_mouse_highlight (struct frame *f, int x, int y) ptrdiff_t start = MATRIX_ROW_START_CHARPOS (r); ptrdiff_t p = string_buffer_position (obj, start); if (p > 0) - pointer = Fget_char_property (make_number (p), + pointer = Fget_char_property (make_fixnum (p), Qpointer, w->contents); } } else if (BUFFERP (obj) && charpos >= BEGV && charpos < ZV) - pointer = Fget_text_property (make_number (charpos), + pointer = Fget_text_property (make_fixnum (charpos), Qpointer, obj); } } @@ -32084,7 +32201,7 @@ x_draw_bottom_divider (struct window *w) int x1 = WINDOW_RIGHT_EDGE_X (w); int y0 = WINDOW_BOTTOM_EDGE_Y (w) - WINDOW_BOTTOM_DIVIDER_WIDTH (w); int y1 = WINDOW_BOTTOM_EDGE_Y (w); - struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : false; + struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : NULL; /* If W is vertically combined and has a sibling below, don't draw over any right divider. */ @@ -32168,6 +32285,18 @@ expose_window (struct window *w, XRectangle *fr) y0 or y1 is negative (can happen for tall images). */ int r_bottom = r.y + r.height; + /* We must temporarily switch to the window's buffer, in case + the fringe face has been remapped in that buffer's + face-remapping-alist, so that draw_row_fringe_bitmaps, + called from expose_line, will use the right face. */ + bool buffer_changed = false; + struct buffer *oldbuf = current_buffer; + if (!w->pseudo_window_p) + { + set_buffer_internal_1 (XBUFFER (w->contents)); + buffer_changed = true; + } + /* Update lines intersecting rectangle R. */ first_overlapping_row = last_overlapping_row = NULL; for (row = w->current_matrix->rows; @@ -32213,6 +32342,9 @@ expose_window (struct window *w, XRectangle *fr) break; } + if (buffer_changed) + set_buffer_internal_1 (oldbuf); + /* Display the mode line if there is one. */ if (window_wants_mode_line (w) && (row = MATRIX_MODE_LINE_ROW (w->current_matrix), @@ -32755,7 +32887,7 @@ not span the full frame width. A value of nil means to respect the value of `truncate-lines'. If `word-wrap' is enabled, you might want to reduce this. */); - Vtruncate_partial_width_windows = make_number (50); + Vtruncate_partial_width_windows = make_fixnum (50); DEFVAR_LISP ("line-number-display-limit", Vline_number_display_limit, doc: /* Maximum buffer size for which line number should be displayed. @@ -32809,7 +32941,7 @@ and is used only on frames for which no explicit name has been set doc: /* Maximum number of lines to keep in the message log buffer. 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); + Vmessage_log_max = make_fixnum (1000); DEFVAR_LISP ("window-scroll-functions", Vwindow_scroll_functions, doc: /* List of functions to call before redisplaying a window with scrolling. @@ -32869,9 +33001,15 @@ automatically; to decrease the tool-bar height, use \\[recenter]. */); doc: /* Non-nil means raise tool-bar buttons when the mouse moves over them. */); auto_raise_tool_bar_buttons_p = true; - DEFVAR_BOOL ("make-cursor-line-fully-visible", make_cursor_line_fully_visible_p, - doc: /* Non-nil means to scroll (recenter) cursor line if it is not fully visible. */); - make_cursor_line_fully_visible_p = true; + DEFVAR_LISP ("make-cursor-line-fully-visible", Vmake_cursor_line_fully_visible, + doc: /* Whether to scroll the window if the cursor line is not fully visible. +If the value is non-nil, Emacs scrolls or recenters the window to make +the cursor line fully visible. The value could also be a function, which +is called with a single argument, the window to be scrolled, and should +return non-nil if the partially-visible cursor requires scrolling the +window, nil if it's okay to leave the cursor partially-visible. */); + Vmake_cursor_line_fully_visible = Qt; + DEFSYM (Qmake_cursor_line_fully_visible, "make-cursor-line-fully-visible"); DEFVAR_LISP ("tool-bar-border", Vtool_bar_border, doc: /* Border below tool-bar in pixels. @@ -32887,7 +33025,7 @@ If an integer, use that for both horizontal and vertical margins. Otherwise, value should be a pair of integers `(HORZ . VERT)' with HORZ specifying the horizontal margin, and VERT specifying the vertical margin. */); - Vtool_bar_button_margin = make_number (DEFAULT_TOOL_BAR_BUTTON_MARGIN); + Vtool_bar_button_margin = make_fixnum (DEFAULT_TOOL_BAR_BUTTON_MARGIN); DEFVAR_INT ("tool-bar-button-relief", tool_bar_button_relief, doc: /* Relief thickness of tool-bar buttons. */); @@ -32995,7 +33133,7 @@ scroll more than the value given by the scroll step. Note that the lower bound for automatic hscrolling specified by `scroll-left' and `scroll-right' overrides this variable's effect. */); - Vhscroll_step = make_number (0); + Vhscroll_step = make_fixnum (0); DEFVAR_BOOL ("message-truncate-lines", message_truncate_lines, doc: /* If non-nil, messages are truncated instead of resizing the echo area. @@ -33134,6 +33272,7 @@ particularly when using variable `x-use-underline-position-properties' with fonts that specify an UNDERLINE_POSITION relatively close to the baseline. The default value is 1. */); underline_minimum_offset = 1; + DEFSYM (Qunderline_minimum_offset, "underline-minimum-offset"); DEFVAR_BOOL ("display-hourglass", display_hourglass_p, doc: /* Non-nil means show an hourglass pointer, when Emacs is busy. @@ -33143,7 +33282,7 @@ cursor shapes. */); DEFVAR_LISP ("hourglass-delay", Vhourglass_delay, doc: /* Seconds to wait before displaying an hourglass pointer when Emacs is busy. */); - Vhourglass_delay = make_number (DEFAULT_HOURGLASS_DELAY); + Vhourglass_delay = make_fixnum (DEFAULT_HOURGLASS_DELAY); #ifdef HAVE_WINDOW_SYSTEM hourglass_atimer = NULL; @@ -33168,7 +33307,7 @@ or t (meaning all windows). */); /* Symbol for the purpose of Vglyphless_char_display. */ DEFSYM (Qglyphless_char_display, "glyphless-char-display"); - Fput (Qglyphless_char_display, Qchar_table_extra_slots, make_number (1)); + Fput (Qglyphless_char_display, Qchar_table_extra_slots, make_fixnum (1)); DEFVAR_LISP ("glyphless-char-display", Vglyphless_char_display, doc: /* Char-table defining glyphless characters. @@ -33191,7 +33330,7 @@ If a character has a non-nil entry in an active display table, the display table takes effect; in this case, Emacs does not consult `glyphless-char-display' at all. */); Vglyphless_char_display = Fmake_char_table (Qglyphless_char_display, Qnil); - Fset_char_table_extra_slot (Vglyphless_char_display, make_number (0), + Fset_char_table_extra_slot (Vglyphless_char_display, make_fixnum (0), Qempty_box); DEFVAR_LISP ("debug-on-message", Vdebug_on_message, @@ -33259,7 +33398,7 @@ init_xdisp (void) /* The default ellipsis glyphs `...'. */ for (i = 0; i < 3; ++i) - default_invis_vector[i] = make_number ('.'); + default_invis_vector[i] = make_fixnum ('.'); } { @@ -33318,9 +33457,9 @@ start_hourglass (void) cancel_hourglass (); - if (INTEGERP (Vhourglass_delay) - && XINT (Vhourglass_delay) > 0) - delay = make_timespec (min (XINT (Vhourglass_delay), + if (FIXNUMP (Vhourglass_delay) + && XFIXNUM (Vhourglass_delay) > 0) + delay = make_timespec (min (XFIXNUM (Vhourglass_delay), TYPE_MAXIMUM (time_t)), 0); else if (FLOATP (Vhourglass_delay) diff --git a/src/xfaces.c b/src/xfaces.c index a219fe89e42..8fe99e7655d 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -350,7 +350,8 @@ static bool realize_default_face (struct frame *); static void realize_named_face (struct frame *, Lisp_Object, int); static struct face_cache *make_face_cache (struct frame *); static void free_face_cache (struct face_cache *); -static bool merge_face_ref (struct frame *, Lisp_Object, Lisp_Object *, +static bool merge_face_ref (struct window *w, + struct frame *, Lisp_Object, Lisp_Object *, bool, struct named_merge_point *); static int color_distance (XColor *x, XColor *y); @@ -735,11 +736,11 @@ the pixmap. Bits are stored row by row, each row occupies } if (STRINGP (data) - && RANGED_INTEGERP (1, width, INT_MAX) - && RANGED_INTEGERP (1, height, INT_MAX)) + && RANGED_FIXNUMP (1, width, INT_MAX) + && RANGED_FIXNUMP (1, height, INT_MAX)) { - int bytes_per_row = (XINT (width) + CHAR_BIT - 1) / CHAR_BIT; - if (XINT (height) <= SBYTES (data) / bytes_per_row) + int bytes_per_row = (XFIXNUM (width) + CHAR_BIT - 1) / CHAR_BIT; + if (XFIXNUM (height) <= SBYTES (data) / bytes_per_row) pixmap_p = true; } } @@ -772,8 +773,8 @@ load_pixmap (struct frame *f, Lisp_Object name) int h, w; Lisp_Object bits; - w = XINT (Fcar (name)); - h = XINT (Fcar (Fcdr (name))); + w = XFIXNUM (Fcar (name)); + h = XFIXNUM (Fcar (Fcdr (name))); bits = Fcar (Fcdr (Fcdr (name))); bitmap_id = x_create_bitmap_from_data (f, SSDATA (bits), @@ -817,9 +818,9 @@ static bool parse_rgb_list (Lisp_Object rgb_list, XColor *color) { #define PARSE_RGB_LIST_FIELD(field) \ - if (CONSP (rgb_list) && INTEGERP (XCAR (rgb_list))) \ + if (CONSP (rgb_list) && FIXNUMP (XCAR (rgb_list))) \ { \ - color->field = XINT (XCAR (rgb_list)); \ + color->field = XFIXNUM (XCAR (rgb_list)); \ rgb_list = XCDR (rgb_list); \ } \ else \ @@ -854,10 +855,10 @@ tty_lookup_color (struct frame *f, Lisp_Object color, XColor *tty_color, { Lisp_Object rgb; - if (! INTEGERP (XCAR (XCDR (color_desc)))) + if (! FIXNUMP (XCAR (XCDR (color_desc)))) return false; - tty_color->pixel = XINT (XCAR (XCDR (color_desc))); + tty_color->pixel = XFIXNUM (XCAR (XCDR (color_desc))); rgb = XCDR (XCDR (color_desc)); if (! parse_rgb_list (rgb, tty_color)) @@ -970,7 +971,7 @@ tty_color_name (struct frame *f, int idx) Lisp_Object coldesc; XSETFRAME (frame, f); - coldesc = call2 (Qtty_color_by_index, make_number (idx), frame); + coldesc = call2 (Qtty_color_by_index, make_fixnum (idx), frame); if (!NILP (coldesc)) return XCAR (coldesc); @@ -1389,12 +1390,12 @@ compare_fonts_by_sort_order (const void *v1, const void *v2) } else { - if (INTEGERP (val1)) - result = (INTEGERP (val2) && XINT (val1) >= XINT (val2) - ? XINT (val1) > XINT (val2) + if (FIXNUMP (val1)) + result = (FIXNUMP (val2) && XFIXNUM (val1) >= XFIXNUM (val2) + ? XFIXNUM (val1) > XFIXNUM (val2) : -1); else - result = INTEGERP (val2) ? 1 : 0; + result = FIXNUMP (val2) ? 1 : 0; } if (result) return result; @@ -1456,7 +1457,7 @@ the face font sort order. */) font_props_for_sorting[i++] = FONT_ADSTYLE_INDEX; font_props_for_sorting[i++] = FONT_REGISTRY_INDEX; - ndrivers = XINT (Flength (list)); + ndrivers = XFIXNUM (Flength (list)); SAFE_ALLOCA_LISP (drivers, ndrivers); for (i = 0; i < ndrivers; i++, list = XCDR (list)) drivers[i] = XCAR (list); @@ -1476,9 +1477,9 @@ the face font sort order. */) ASET (v, 0, AREF (font, FONT_FAMILY_INDEX)); ASET (v, 1, FONT_WIDTH_SYMBOLIC (font)); - point = PIXEL_TO_POINT (XINT (AREF (font, FONT_SIZE_INDEX)) * 10, + point = PIXEL_TO_POINT (XFIXNUM (AREF (font, FONT_SIZE_INDEX)) * 10, FRAME_RES_Y (f)); - ASET (v, 2, make_number (point)); + ASET (v, 2, make_fixnum (point)); ASET (v, 3, FONT_WEIGHT_SYMBOLIC (font)); ASET (v, 4, FONT_SLANT_SYMBOLIC (font)); spacing = Ffont_get (font, QCspacing); @@ -1525,10 +1526,10 @@ the WIDTH times as wide as FACE on FRAME. */) CHECK_STRING (pattern); if (! NILP (maximum)) - CHECK_NATNUM (maximum); + CHECK_FIXNAT (maximum); if (!NILP (width)) - CHECK_NUMBER (width); + CHECK_FIXNUM (width); /* We can't simply call decode_window_system_frame because this function may be called before any frame is created. */ @@ -1551,7 +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); + int face_id = lookup_named_face (NULL, f, face, false); struct face *width_face = FACE_FROM_ID_OR_NULL (f, face_id); if (width_face && width_face->font) @@ -1565,7 +1566,7 @@ the WIDTH times as wide as FACE on FRAME. */) avgwidth = FRAME_FONT (f)->average_width; } if (!NILP (width)) - avgwidth *= XINT (width); + avgwidth *= XFIXNUM (width); } Lisp_Object font_spec = font_spec_from_name (pattern); @@ -1574,8 +1575,8 @@ the WIDTH times as wide as FACE on FRAME. */) if (size) { - Ffont_put (font_spec, QCsize, make_number (size)); - Ffont_put (font_spec, QCavgwidth, make_number (avgwidth)); + Ffont_put (font_spec, QCsize, make_fixnum (size)); + Ffont_put (font_spec, QCavgwidth, make_fixnum (avgwidth)); } Lisp_Object fonts = Flist_fonts (font_spec, frame, maximum, font_spec); for (Lisp_Object tail = fonts; CONSP (tail); tail = XCDR (tail)) @@ -1584,7 +1585,7 @@ the WIDTH times as wide as FACE on FRAME. */) font_entity = XCAR (tail); if ((NILP (AREF (font_entity, FONT_SIZE_INDEX)) - || XINT (AREF (font_entity, FONT_SIZE_INDEX)) == 0) + || XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX)) == 0) && ! NILP (AREF (font_spec, FONT_SIZE_INDEX))) { /* This is a scalable font. For backward compatibility, @@ -1683,7 +1684,7 @@ check_lface_attrs (Lisp_Object attrs[LFACE_VECTOR_SIZE]) || IGNORE_DEFFACE_P (attrs[LFACE_BOX_INDEX]) || SYMBOLP (attrs[LFACE_BOX_INDEX]) || STRINGP (attrs[LFACE_BOX_INDEX]) - || INTEGERP (attrs[LFACE_BOX_INDEX]) + || FIXNUMP (attrs[LFACE_BOX_INDEX]) || CONSP (attrs[LFACE_BOX_INDEX])); eassert (UNSPECIFIEDP (attrs[LFACE_INVERSE_INDEX]) || IGNORE_DEFFACE_P (attrs[LFACE_INVERSE_INDEX]) @@ -1907,19 +1908,22 @@ get_lface_attributes_no_remap (struct frame *f, Lisp_Object face_name, return !NILP (lface); } -/* Get face attributes of face FACE_NAME from frame-local faces on frame - F. Store the resulting attributes in ATTRS which must point to a - vector of Lisp_Objects of size LFACE_VECTOR_SIZE. If FACE_NAME is an - alias for another face, use that face's definition. - If SIGNAL_P, signal an error if FACE_NAME does not name a face. - Otherwise, return true iff FACE_NAME is a face. */ - +/* Get face attributes of face FACE_NAME from frame-local faces on + frame F. Store the resulting attributes in ATTRS which must point + to a vector of Lisp_Objects of size LFACE_VECTOR_SIZE. + If FACE_NAME is an alias for another face, use that face's + definition. If SIGNAL_P, signal an error if FACE_NAME does not + name a face. Otherwise, return true iff FACE_NAME is a face. If W + is non-NULL, also consider remappings attached to the window. + */ static bool -get_lface_attributes (struct frame *f, Lisp_Object face_name, +get_lface_attributes (struct window *w, + struct frame *f, Lisp_Object face_name, Lisp_Object attrs[LFACE_VECTOR_SIZE], bool signal_p, struct named_merge_point *named_merge_points) { Lisp_Object face_remapping; + eassert (w == NULL || WINDOW_XFRAME (w) == f); face_name = resolve_face_name (face_name, signal_p); @@ -1939,7 +1943,7 @@ get_lface_attributes (struct frame *f, Lisp_Object face_name, for (i = 1; i < LFACE_VECTOR_SIZE; ++i) attrs[i] = Qunspecified; - return merge_face_ref (f, XCDR (face_remapping), attrs, + return merge_face_ref (w, f, XCDR (face_remapping), attrs, signal_p, named_merge_points); } } @@ -2003,7 +2007,7 @@ set_lface_from_font (struct frame *f, Lisp_Object lface, int pt = PIXEL_TO_POINT (font->pixel_size * 10, FRAME_RES_Y (f)); eassert (pt > 0); - ASET (lface, LFACE_HEIGHT_INDEX, make_number (pt)); + ASET (lface, LFACE_HEIGHT_INDEX, make_fixnum (pt)); } if (force_p || UNSPECIFIEDP (LFACE_WEIGHT (lface))) @@ -2039,15 +2043,15 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid) { Lisp_Object result = invalid; - if (INTEGERP (from)) + if (FIXNUMP (from)) /* FROM is absolute, just use it as is. */ result = from; else if (FLOATP (from)) /* FROM is a scale, use it to adjust TO. */ { - if (INTEGERP (to)) + if (FIXNUMP (to)) /* relative X absolute => absolute */ - result = make_number (XFLOAT_DATA (from) * XINT (to)); + result = make_fixnum (XFLOAT_DATA (from) * XFIXNUM (to)); else if (FLOATP (to)) /* relative X relative => relative */ result = make_float (XFLOAT_DATA (from) * XFLOAT_DATA (to)); @@ -2062,7 +2066,7 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid) result = safe_call1 (from, to); /* Ensure that if TO was absolute, so is the result. */ - if (INTEGERP (to) && !INTEGERP (result)) + if (FIXNUMP (to) && !FIXNUMP (result)) result = invalid; } @@ -2072,15 +2076,16 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid) /* Merge two Lisp face attribute vectors on frame F, FROM and TO, and store the resulting attributes in TO, which must be already be - completely specified and contain only absolute attributes. Every - specified attribute of FROM overrides the corresponding attribute of - TO; relative attributes in FROM are merged with the absolute value in - TO and replace it. NAMED_MERGE_POINTS is used internally to detect - loops in face inheritance/remapping; it should be 0 when called from - other places. */ - + completely specified and contain only absolute attributes. + Every specified attribute of FROM overrides the corresponding + attribute of TO; relative attributes in FROM are merged with the + absolute value in TO and replace it. NAMED_MERGE_POINTS is used + internally to detect loops in face inheritance/remapping; it should + be 0 when called from other places. If window W is non-NULL, use W + to interpret face specifications. */ static void -merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to, +merge_face_vectors (struct window *w, + struct frame *f, Lisp_Object *from, Lisp_Object *to, struct named_merge_point *named_merge_points) { int i; @@ -2093,7 +2098,8 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to, other code uses `unspecified' as a generic value for face attributes. */ if (!UNSPECIFIEDP (from[LFACE_INHERIT_INDEX]) && !NILP (from[LFACE_INHERIT_INDEX])) - merge_face_ref (f, from[LFACE_INHERIT_INDEX], to, false, named_merge_points); + merge_face_ref (w, f, from[LFACE_INHERIT_INDEX], + to, false, named_merge_points); if (FONT_SPEC_P (from[LFACE_FONT_INDEX])) { @@ -2107,7 +2113,7 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to, for (i = 1; i < LFACE_VECTOR_SIZE; ++i) if (!UNSPECIFIEDP (from[i])) { - if (i == LFACE_HEIGHT_INDEX && !INTEGERP (from[i])) + if (i == LFACE_HEIGHT_INDEX && !FIXNUMP (from[i])) { to[i] = merge_face_heights (from[i], to[i], to[i]); font_clear_prop (to, FONT_SIZE_INDEX); @@ -2153,10 +2159,12 @@ merge_face_vectors (struct frame *f, Lisp_Object *from, Lisp_Object *to, /* Merge the named face FACE_NAME on frame F, into the vector of face attributes TO. Use NAMED_MERGE_POINTS to detect loops in face inheritance. Return true if FACE_NAME is a valid face name and - merging succeeded. */ + merging succeeded. Window W, if non-NULL, is used to filter face + specifications. */ static bool -merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, +merge_named_face (struct window *w, + struct frame *f, Lisp_Object face_name, Lisp_Object *to, struct named_merge_point *named_merge_points) { struct named_merge_point named_merge_point; @@ -2166,11 +2174,11 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, &named_merge_points)) { Lisp_Object from[LFACE_VECTOR_SIZE]; - bool ok = get_lface_attributes (f, face_name, from, false, + bool ok = get_lface_attributes (w, f, face_name, from, false, named_merge_points); if (ok) - merge_face_vectors (f, from, to, named_merge_points); + merge_face_vectors (w, f, from, to, named_merge_points); return ok; } @@ -2178,6 +2186,119 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, return false; } +/* Determine whether the face filter FILTER evaluated in window W + matches. W can be NULL if the window context is unknown. + + A face filter is either nil, which always matches, or a list + (:window PARAMETER VALUE), which matches if the current window has + a PARAMETER EQ to VALUE. + + This function returns true if the face filter matches, and false if + it doesn't or if the function encountered an error. If the filter + is invalid, set *OK to false and, if ERR_MSGS is true, log an error + message. On success, *OK is untouched. */ +static bool +evaluate_face_filter (Lisp_Object filter, struct window *w, + bool *ok, bool err_msgs) +{ + Lisp_Object orig_filter = filter; + + /* Inner braces keep compiler happy about the goto skipping variable + initialization. */ + { + if (NILP (filter)) + return true; + + if (face_filters_always_match) + return true; + + if (!CONSP (filter)) + goto err; + + if (!EQ (XCAR (filter), QCwindow)) + goto err; + filter = XCDR (filter); + + Lisp_Object parameter = XCAR (filter); + filter = XCDR (filter); + if (!CONSP (filter)) + goto err; + + Lisp_Object value = XCAR (filter); + filter = XCDR (filter); + if (!NILP (filter)) + goto err; + + bool match = false; + if (w) + { + Lisp_Object found = assq_no_quit (parameter, w->window_parameters); + if (!NILP (found) && EQ (XCDR (found), value)) + match = true; + } + + return match; + } + + err: + if (err_msgs) + add_to_log ("Invalid face filter %S", orig_filter); + *ok = false; + return false; +} + +/* Determine whether FACE_REF is a "filter" face specification (case + #4 in merge_face_ref). If it is, evaluate the filter, and if the + filter matches, return the filtered face spec. If the filter does + not match, return `nil'. If FACE_REF is not a filtered face + specification, return FACE_REF. + + On error, set *OK to false, having logged an error message if + ERR_MSGS is true, and return `nil'. Otherwise, *OK is not touched. + + W is either NULL or a window used to evaluate filters. If W is + NULL, no window-based face specification filter matches. +*/ +static Lisp_Object +filter_face_ref (Lisp_Object face_ref, + struct window *w, + bool *ok, + bool err_msgs) +{ + Lisp_Object orig_face_ref = face_ref; + if (!CONSP (face_ref)) + return face_ref; + + /* Inner braces keep compiler happy about the goto skipping variable + initialization. */ + { + if (!EQ (XCAR (face_ref), QCfiltered)) + return face_ref; + face_ref = XCDR (face_ref); + + if (!CONSP (face_ref)) + goto err; + Lisp_Object filter = XCAR (face_ref); + face_ref = XCDR (face_ref); + + if (!CONSP (face_ref)) + goto err; + Lisp_Object filtered_face_ref = XCAR (face_ref); + face_ref = XCDR (face_ref); + + if (!NILP (face_ref)) + goto err; + + return evaluate_face_filter (filter, w, ok, err_msgs) + ? filtered_face_ref : Qnil; + } + + err: + if (err_msgs) + add_to_log ("Invalid face ref %S", orig_face_ref); + *ok = false; + return Qnil; +} /* Merge face attributes from the lisp `face reference' FACE_REF on frame F into the face attribute vector TO. If ERR_MSGS, @@ -2199,14 +2320,38 @@ merge_named_face (struct frame *f, Lisp_Object face_name, Lisp_Object *to, (BACKGROUND-COLOR . COLOR) where COLOR is a color name. This is for compatibility with 20.2. + 4. Conses of the form + (:filtered (:window PARAMETER VALUE) FACE-SPECIFICATION), + which applies FACE-SPECIFICATION only if the + given face attributes are being evaluated in the context of a + window with a parameter named PARAMETER being EQ VALUE. + + 5. nil, which means to merge nothing. + Face specifications earlier in lists take precedence over later specifications. */ static bool -merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to, +merge_face_ref (struct window *w, + struct frame *f, Lisp_Object face_ref, Lisp_Object *to, bool err_msgs, struct named_merge_point *named_merge_points) { bool ok = true; /* Succeed without an error? */ + Lisp_Object filtered_face_ref; + + filtered_face_ref = face_ref; + do + { + face_ref = filtered_face_ref; + filtered_face_ref = filter_face_ref (face_ref, w, &ok, err_msgs); + } + while (ok && !EQ (face_ref, filtered_face_ref)); + + if (!ok) + return false; + + if (NILP (face_ref)) + return true; if (CONSP (face_ref)) { @@ -2331,8 +2476,8 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to, else if (EQ (keyword, QCbox)) { if (EQ (value, Qt)) - value = make_number (1); - if (INTEGERP (value) + value = make_fixnum (1); + if (FIXNUMP (value) || STRINGP (value) || CONSP (value) || NILP (value)) @@ -2400,7 +2545,7 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to, { /* This is not really very useful; it's just like a normal face reference. */ - if (! merge_face_ref (f, value, to, + if (! merge_face_ref (w, f, value, to, err_msgs, named_merge_points)) err = true; } @@ -2424,16 +2569,16 @@ merge_face_ref (struct frame *f, Lisp_Object face_ref, Lisp_Object *to, Lisp_Object next = XCDR (face_ref); if (! NILP (next)) - ok = merge_face_ref (f, next, to, err_msgs, named_merge_points); + ok = merge_face_ref (w, f, next, to, err_msgs, named_merge_points); - if (! merge_face_ref (f, first, to, err_msgs, named_merge_points)) + if (! merge_face_ref (w, f, first, to, err_msgs, named_merge_points)) ok = false; } } else { /* FACE_REF ought to be a face name. */ - ok = merge_named_face (f, face_ref, to, named_merge_points); + ok = merge_named_face (w, f, face_ref, to, named_merge_points); if (!ok && err_msgs) add_to_log ("Invalid face reference: %s", face_ref); } @@ -2470,8 +2615,7 @@ Value is a vector of face attributes. */) /* Add a global definition if there is none. */ if (NILP (global_lface)) { - global_lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE), - Qunspecified); + global_lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified); ASET (global_lface, 0, Qface); Vface_new_frame_defaults = Fcons (Fcons (face, global_lface), Vface_new_frame_defaults); @@ -2486,7 +2630,7 @@ Value is a vector of face attributes. */) sizeof *lface_id_to_name); lface_id_to_name[next_lface_id] = face; - Fput (face, Qface, make_number (next_lface_id)); + Fput (face, Qface, make_fixnum (next_lface_id)); ++next_lface_id; } else if (f == NULL) @@ -2498,8 +2642,7 @@ Value is a vector of face attributes. */) { if (NILP (lface)) { - lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE), - Qunspecified); + lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified); ASET (lface, 0, Qface); fset_face_alist (f, Fcons (Fcons (face, lface), f->face_alist)); } @@ -2647,7 +2790,7 @@ FRAME 0 means change the face on all frames, and change the default /* If FRAME is 0, change face on all frames, and change the default for new frames. */ - if (INTEGERP (frame) && XINT (frame) == 0) + if (FIXNUMP (frame) && XFIXNUM (frame) == 0) { Lisp_Object tail; Finternal_set_lisp_face_attribute (face, attr, value, Qt); @@ -2717,7 +2860,7 @@ FRAME 0 means change the face on all frames, and change the default if (EQ (face, Qdefault)) { /* The default face must have an absolute size. */ - if (!INTEGERP (value) || XINT (value) <= 0) + if (!FIXNUMP (value) || XFIXNUM (value) <= 0) signal_error ("Default face height not absolute and positive", value); } @@ -2726,9 +2869,9 @@ FRAME 0 means change the face on all frames, and change the default /* For non-default faces, do a test merge with a random height to see if VALUE's ok. */ Lisp_Object test = merge_face_heights (value, - make_number (10), + make_fixnum (10), Qnil); - if (!INTEGERP (test) || XINT (test) <= 0) + if (!FIXNUMP (test) || XFIXNUM (test) <= 0) signal_error ("Face height does not produce a positive integer", value); } @@ -2826,7 +2969,7 @@ FRAME 0 means change the face on all frames, and change the default if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value)) if ((SYMBOLP (value) && !EQ (value, Qt) - && !EQ (value, Qnil)) + && !NILP (value)) /* Overline color. */ || (STRINGP (value) && SCHARS (value) == 0)) @@ -2840,7 +2983,7 @@ FRAME 0 means change the face on all frames, and change the default if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value)) if ((SYMBOLP (value) && !EQ (value, Qt) - && !EQ (value, Qnil)) + && !NILP (value)) /* Strike-through color. */ || (STRINGP (value) && SCHARS (value) == 0)) @@ -2856,14 +2999,14 @@ FRAME 0 means change the face on all frames, and change the default /* Allow t meaning a simple box of width 1 in foreground color of the face. */ if (EQ (value, Qt)) - value = make_number (1); + value = make_fixnum (1); if (UNSPECIFIEDP (value) || IGNORE_DEFFACE_P (value)) valid_p = true; else if (NILP (value)) valid_p = true; - else if (INTEGERP (value)) - valid_p = XINT (value) != 0; + else if (FIXNUMP (value)) + valid_p = XFIXNUM (value) != 0; else if (STRINGP (value)) valid_p = SCHARS (value) > 0; else if (CONSP (value)) @@ -2884,7 +3027,7 @@ FRAME 0 means change the face on all frames, and change the default if (EQ (k, QCline_width)) { - if (!INTEGERP (v) || XINT (v) == 0) + if (!FIXNUMP (v) || XFIXNUM (v) == 0) break; } else if (EQ (k, QCcolor)) @@ -3359,7 +3502,7 @@ ordinary `x-get-resource' doesn't take a frame argument. */) static Lisp_Object face_boolean_x_resource_value (Lisp_Object value, bool signal_p) { - Lisp_Object result = make_number (0); + Lisp_Object result = make_fixnum (0); eassert (STRINGP (value)); @@ -3392,8 +3535,8 @@ DEFUN ("internal-set-lisp-face-attribute-from-resource", value = Qunspecified; else if (EQ (attr, QCheight)) { - value = Fstring_to_number (value, make_number (10)); - if (XINT (value) <= 0) + value = Fstring_to_number (value, Qnil); + if (!FIXNUMP (value) || XFIXNUM (value) <= 0) signal_error ("Invalid face height from X resource", value); } else if (EQ (attr, QCbold) || EQ (attr, QCitalic)) @@ -3553,7 +3696,7 @@ However, for :height, floating point values are also relative. */ if (EQ (value, Qunspecified) || (EQ (value, QCignore_defface))) return Qt; else if (EQ (attribute, QCheight)) - return INTEGERP (value) ? Qnil : Qt; + return FIXNUMP (value) ? Qnil : Qt; else return Qnil; } @@ -3701,7 +3844,7 @@ Default face attributes override any local face attributes. */) /* Ensure that the face vector is fully specified by merging the previously-cached vector. */ memcpy (attrs, oldface->lface, sizeof attrs); - merge_face_vectors (f, lvec, attrs, 0); + merge_face_vectors (NULL, f, lvec, attrs, 0); vcopy (local_lface, 0, attrs, LFACE_VECTOR_SIZE); newface = realize_face (c, lvec, DEFAULT_FACE_ID); @@ -3774,7 +3917,7 @@ return the font name used for CHARACTER. */) else { struct frame *f = decode_live_frame (frame); - int face_id = lookup_named_face (f, face, true); + int face_id = lookup_named_face (NULL, f, face, true); struct face *fface = FACE_FROM_ID_OR_NULL (f, face_id); if (! fface) @@ -3783,7 +3926,7 @@ return the font name used for CHARACTER. */) if (FRAME_WINDOW_P (f) && !NILP (character)) { CHECK_CHARACTER (character); - face_id = FACE_FOR_CHAR (f, fface, XINT (character), -1, Qnil); + face_id = FACE_FOR_CHAR (f, fface, XFIXNUM (character), -1, Qnil); fface = FACE_FROM_ID_OR_NULL (f, face_id); } return ((fface && fface->font) @@ -4111,15 +4254,15 @@ two lists of the form (RED GREEN BLUE) aforementioned. */) signal_error ("Invalid color", color2); if (NILP (metric)) - return make_number (color_distance (&cdef1, &cdef2)); + return make_fixnum (color_distance (&cdef1, &cdef2)); else return call2 (metric, - list3 (make_number (cdef1.red), - make_number (cdef1.green), - make_number (cdef1.blue)), - list3 (make_number (cdef2.red), - make_number (cdef2.green), - make_number (cdef2.blue))); + list3 (make_fixnum (cdef1.red), + make_fixnum (cdef1.green), + make_fixnum (cdef1.blue)), + list3 (make_fixnum (cdef2.red), + make_fixnum (cdef2.green), + make_fixnum (cdef2.blue))); } @@ -4432,10 +4575,12 @@ face_for_font (struct frame *f, Lisp_Object font_object, struct face *base_face) /* Return the face id of the realized face for named face SYMBOL on frame F suitable for displaying ASCII characters. Value is -1 if the face couldn't be determined, which might happen if the default - face isn't realized and cannot be realized. */ - + face isn't realized and cannot be realized. If window W is given, + consider face remappings specified for W or for W's buffer. If W + is NULL, consider only frame-level face configuration. */ int -lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p) +lookup_named_face (struct window *w, struct frame *f, + Lisp_Object symbol, bool signal_p) { Lisp_Object attrs[LFACE_VECTOR_SIZE]; Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE]; @@ -4448,11 +4593,11 @@ lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p) default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); } - if (! get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0)) + if (! get_lface_attributes (w, f, symbol, symbol_attrs, signal_p, 0)) return -1; memcpy (attrs, default_face->lface, sizeof attrs); - merge_face_vectors (f, symbol_attrs, attrs, 0); + merge_face_vectors (w, f, symbol_attrs, attrs, 0); return lookup_face (f, attrs); } @@ -4462,10 +4607,10 @@ lookup_named_face (struct frame *f, Lisp_Object symbol, bool signal_p) is FACE_ID. The return value will usually simply be FACE_ID, unless that basic face has bee remapped via Vface_remapping_alist. This function is conservative: if something goes wrong, it will simply return FACE_ID - rather than signal an error. */ - + rather than signal an error. Window W, if non-NULL, is used to filter + face specifications for remapping. */ int -lookup_basic_face (struct frame *f, int face_id) +lookup_basic_face (struct window *w, struct frame *f, int face_id) { Lisp_Object name, mapping; int remapped_face_id; @@ -4487,6 +4632,7 @@ lookup_basic_face (struct frame *f, int face_id) case MOUSE_FACE_ID: name = Qmouse; break; case MENU_FACE_ID: name = Qmenu; break; case WINDOW_DIVIDER_FACE_ID: name = Qwindow_divider; break; + case VERTICAL_BORDER_FACE_ID: name = Qvertical_border; break; case WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID: name = Qwindow_divider_first_pixel; break; case WINDOW_DIVIDER_LAST_PIXEL_FACE_ID: name = Qwindow_divider_last_pixel; break; case INTERNAL_BORDER_FACE_ID: name = Qinternal_border; break; @@ -4504,7 +4650,7 @@ lookup_basic_face (struct frame *f, int face_id) /* If there is a remapping entry, lookup the face using NAME, which will handle the remapping too. */ - remapped_face_id = lookup_named_face (f, name, false); + remapped_face_id = lookup_named_face (w, f, name, false); if (remapped_face_id < 0) return face_id; /* Give up. */ @@ -4537,7 +4683,7 @@ smaller_face (struct frame *f, int face_id, int steps) face = FACE_FROM_ID (f, face_id); memcpy (attrs, face->lface, sizeof attrs); - pt = last_pt = XFASTINT (attrs[LFACE_HEIGHT_INDEX]); + pt = last_pt = XFIXNAT (attrs[LFACE_HEIGHT_INDEX]); new_face_id = face_id; last_height = FONT_HEIGHT (face->font); @@ -4548,7 +4694,7 @@ smaller_face (struct frame *f, int face_id, int steps) { /* Look up a face for a slightly smaller/larger font. */ pt += delta; - attrs[LFACE_HEIGHT_INDEX] = make_number (pt); + attrs[LFACE_HEIGHT_INDEX] = make_fixnum (pt); new_face_id = lookup_face (f, attrs); new_face = FACE_FROM_ID (f, new_face_id); @@ -4588,7 +4734,7 @@ face_with_height (struct frame *f, int face_id, int height) face = FACE_FROM_ID (f, face_id); memcpy (attrs, face->lface, sizeof attrs); - attrs[LFACE_HEIGHT_INDEX] = make_number (height); + attrs[LFACE_HEIGHT_INDEX] = make_fixnum (height); font_clear_prop (attrs, FONT_SIZE_INDEX); face_id = lookup_face (f, attrs); #endif /* HAVE_WINDOW_SYSTEM */ @@ -4602,22 +4748,23 @@ face_with_height (struct frame *f, int face_id, int height) attributes of the face FACE_ID for attributes that aren't completely specified by SYMBOL. This is like lookup_named_face, except that the default attributes come from FACE_ID, not from the - default face. FACE_ID is assumed to be already realized. */ - + default face. FACE_ID is assumed to be already realized. + Window W, if non-NULL, filters face specifications. */ int -lookup_derived_face (struct frame *f, Lisp_Object symbol, int face_id, +lookup_derived_face (struct window *w, + struct frame *f, Lisp_Object symbol, int face_id, bool signal_p) { Lisp_Object attrs[LFACE_VECTOR_SIZE]; Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE]; struct face *default_face; - if (!get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0)) + if (!get_lface_attributes (w, 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); + merge_face_vectors (w, f, symbol_attrs, attrs, 0); return lookup_face (f, attrs); } @@ -4626,10 +4773,9 @@ DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector, doc: /* Return a vector of face attributes corresponding to PLIST. */) (Lisp_Object plist) { - Lisp_Object lface; - lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE), - Qunspecified); - merge_face_ref (XFRAME (selected_frame), plist, XVECTOR (lface)->contents, + Lisp_Object lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified); + merge_face_ref (NULL, XFRAME (selected_frame), + plist, XVECTOR (lface)->contents, true, 0); return lface; } @@ -4713,7 +4859,7 @@ x_supports_face_attributes_p (struct frame *f, memcpy (merged_attrs, def_attrs, sizeof merged_attrs); - merge_face_vectors (f, attrs, merged_attrs, 0); + merge_face_vectors (NULL, f, attrs, merged_attrs, 0); face_id = lookup_face (f, merged_attrs); face = FACE_FROM_ID_OR_NULL (f, face_id); @@ -4736,8 +4882,8 @@ x_supports_face_attributes_p (struct frame *f, return true; s1 = SYMBOL_NAME (face->font->props[i]); s2 = SYMBOL_NAME (def_face->font->props[i]); - if (! EQ (Fcompare_strings (s1, make_number (0), Qnil, - s2, make_number (0), Qnil, Qt), Qt)) + if (! EQ (Fcompare_strings (s1, make_fixnum (0), Qnil, + s2, make_fixnum (0), Qnil, Qt), Qt)) return true; } return false; @@ -4984,7 +5130,7 @@ face for italic. */) for (i = 0; i < LFACE_VECTOR_SIZE; i++) attrs[i] = Qunspecified; - merge_face_ref (f, attributes, attrs, true, 0); + merge_face_ref (NULL, f, attributes, attrs, true, 0); def_face = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); if (def_face == NULL) @@ -5241,7 +5387,7 @@ realize_default_face (struct frame *f) ASET (lface, LFACE_FAMILY_INDEX, build_string ("default")); ASET (lface, LFACE_FOUNDRY_INDEX, LFACE_FAMILY (lface)); ASET (lface, LFACE_SWIDTH_INDEX, Qnormal); - ASET (lface, LFACE_HEIGHT_INDEX, make_number (1)); + ASET (lface, LFACE_HEIGHT_INDEX, make_fixnum (1)); if (UNSPECIFIEDP (LFACE_WEIGHT (lface))) ASET (lface, LFACE_WEIGHT_INDEX, Qnormal); if (UNSPECIFIEDP (LFACE_SLANT (lface))) @@ -5353,7 +5499,7 @@ realize_named_face (struct frame *f, Lisp_Object symbol, int id) /* Merge SYMBOL's face with the default face. */ get_lface_attributes_no_remap (f, symbol, symbol_attrs, true); - merge_face_vectors (f, symbol_attrs, attrs, 0); + merge_face_vectors (NULL, f, symbol_attrs, attrs, 0); /* Realize the face. */ realize_face (c, attrs, id); @@ -5525,13 +5671,13 @@ realize_x_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE]) face->box = FACE_SIMPLE_BOX; face->box_line_width = 1; } - else if (INTEGERP (box)) + else if (FIXNUMP (box)) { /* Simple box of specified line width in foreground color of the face. */ - eassert (XINT (box) != 0); + eassert (XFIXNUM (box) != 0); face->box = FACE_SIMPLE_BOX; - face->box_line_width = XINT (box); + face->box_line_width = XFIXNUM (box); face->box_color = face->foreground; face->box_color_defaulted_p = true; } @@ -5558,8 +5704,8 @@ realize_x_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE]) if (EQ (keyword, QCline_width)) { - if (INTEGERP (value) && XINT (value) != 0) - face->box_line_width = XINT (value); + if (FIXNUMP (value) && XFIXNUM (value) != 0) + face->box_line_width = XFIXNUM (value); } else if (EQ (keyword, QCcolor)) { @@ -5725,7 +5871,7 @@ map_tty_color (struct frame *f, struct face *face, { /* Associations in tty-defined-color-alist are of the form (NAME INDEX R G B). We need the INDEX part. */ - pixel = XINT (XCAR (XCDR (def))); + pixel = XFIXNUM (XCAR (XCDR (def))); } if (pixel == default_pixel && STRINGP (color)) @@ -5868,7 +6014,7 @@ compute_char_face (struct frame *f, int ch, Lisp_Object prop) Lisp_Object attrs[LFACE_VECTOR_SIZE]; struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID); memcpy (attrs, default_face->lface, sizeof attrs); - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (NULL, f, prop, attrs, true, 0); face_id = lookup_face (f, attrs); } @@ -5924,8 +6070,8 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, prop = Fget_text_property (position, propname, w->contents); XSETFASTINT (limit1, (limit < endpos ? limit : endpos)); end = Fnext_single_property_change (position, propname, w->contents, limit1); - if (INTEGERP (end)) - endpos = XINT (end); + if (FIXNUMP (end)) + endpos = XFIXNUM (end); /* Look at properties from overlays. */ USE_SAFE_ALLOCA; @@ -5949,12 +6095,12 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, cached faces since we've looked up the base face, we need to look it up again. */ if (!FACE_FROM_ID_OR_NULL (f, face_id)) - face_id = lookup_basic_face (f, DEFAULT_FACE_ID); + face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); } else if (NILP (Vface_remapping_alist)) face_id = DEFAULT_FACE_ID; else - face_id = lookup_basic_face (f, DEFAULT_FACE_ID); + face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); default_face = FACE_FROM_ID (f, face_id); } @@ -5972,7 +6118,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, /* Merge in attributes specified via text properties. */ if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); /* Now merge the overlay data. */ noverlays = sort_overlays (overlay_vec, noverlays, w); @@ -5992,7 +6138,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, so discard the mouse-face text property, if any, and use the overlay property instead. */ memcpy (attrs, default_face->lface, sizeof attrs); - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); } oend = OVERLAY_END (overlay_vec[i]); @@ -6010,7 +6156,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, prop = Foverlay_get (overlay_vec[i], propname); if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); oend = OVERLAY_END (overlay_vec[i]); oendpos = OVERLAY_POSITION (oend); @@ -6060,8 +6206,8 @@ face_for_overlay_string (struct window *w, ptrdiff_t pos, prop = Fget_text_property (position, propname, w->contents); XSETFASTINT (limit1, (limit < endpos ? limit : endpos)); end = Fnext_single_property_change (position, propname, w->contents, limit1); - if (INTEGERP (end)) - endpos = XINT (end); + if (FIXNUMP (end)) + endpos = XFIXNUM (end); *endptr = endpos; @@ -6071,12 +6217,12 @@ face_for_overlay_string (struct window *w, ptrdiff_t pos, return DEFAULT_FACE_ID; /* Begin with attributes from the default face. */ - default_face = FACE_FROM_ID (f, lookup_basic_face (f, DEFAULT_FACE_ID)); + default_face = FACE_FROM_ID (f, lookup_basic_face (w, f, DEFAULT_FACE_ID)); memcpy (attrs, default_face->lface, sizeof attrs); /* Merge in attributes specified via text properties. */ if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); *endptr = endpos; @@ -6133,8 +6279,8 @@ face_at_string_position (struct window *w, Lisp_Object string, short, so set the limit to the end of the string. */ XSETFASTINT (limit, SCHARS (string)); end = Fnext_single_property_change (position, prop_name, string, limit); - if (INTEGERP (end)) - *endptr = XFASTINT (end); + if (FIXNUMP (end)) + *endptr = XFIXNAT (end); else *endptr = -1; @@ -6155,7 +6301,7 @@ face_at_string_position (struct window *w, Lisp_Object string, /* Merge in attributes specified via text properties. */ if (!NILP (prop)) - merge_face_ref (f, prop, attrs, true, 0); + merge_face_ref (w, f, prop, attrs, true, 0); /* Look up a realized face with the given face attributes, or realize a new one for ASCII characters. */ @@ -6165,7 +6311,7 @@ face_at_string_position (struct window *w, Lisp_Object string, /* Merge a face into a realized face. - F is frame where faces are (to be) realized. + W is a window in the frame where faces are (to be) realized. FACE_NAME is named face to merge. @@ -6179,9 +6325,10 @@ face_at_string_position (struct window *w, Lisp_Object string, */ int -merge_faces (struct frame *f, Lisp_Object face_name, int face_id, +merge_faces (struct window *w, Lisp_Object face_name, int face_id, int base_face_id) { + struct frame *f = WINDOW_XFRAME (w); Lisp_Object attrs[LFACE_VECTOR_SIZE]; struct face *base_face; @@ -6196,7 +6343,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id, face_name = lface_id_to_name[face_id]; /* When called during make-frame, lookup_derived_face may fail if the faces are uninitialized. Don't signal an error. */ - face_id = lookup_derived_face (f, face_name, base_face_id, 0); + face_id = lookup_derived_face (w, f, face_name, base_face_id, 0); return (face_id >= 0 ? face_id : base_face_id); } @@ -6205,7 +6352,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int face_id, if (!NILP (face_name)) { - if (!merge_named_face (f, face_name, attrs, 0)) + if (!merge_named_face (w, f, face_name, attrs, 0)) return base_face_id; } else @@ -6216,7 +6363,7 @@ merge_faces (struct frame *f, Lisp_Object face_name, int 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); + merge_face_vectors (w, f, face->lface, attrs, 0); } /* Look up a realized face with the given face attributes, @@ -6262,7 +6409,7 @@ where R,G,B are numbers between 0 and 255 and name is an arbitrary string. */) char *name = buf + num; ptrdiff_t len = strlen (name); len -= 0 < len && name[len - 1] == '\n'; - cmap = Fcons (Fcons (make_string (name, len), make_number (color)), + cmap = Fcons (Fcons (make_string (name, len), make_fixnum (color)), cmap); } } @@ -6327,13 +6474,13 @@ DEFUN ("dump-face", Fdump_face, Sdump_face, 0, 1, 0, doc: /* */) fprintf (stderr, "\n"); for (i = 0; i < FRAME_FACE_CACHE (SELECTED_FRAME ())->used; ++i) - Fdump_face (make_number (i)); + Fdump_face (make_fixnum (i)); } else { struct face *face; - CHECK_NUMBER (n); - face = FACE_FROM_ID_OR_NULL (SELECTED_FRAME (), XINT (n)); + CHECK_FIXNUM (n); + face = FACE_FROM_ID_OR_NULL (SELECTED_FRAME (), XFIXNUM (n)); if (face == NULL) error ("Not a valid face"); dump_realized_face (face); @@ -6427,6 +6574,11 @@ syms_of_xfaces (void) DEFSYM (Qunspecified, "unspecified"); DEFSYM (QCignore_defface, ":ignore-defface"); + /* Used for limiting character attributes to windows with specific + characteristics. */ + DEFSYM (QCwindow, ":window"); + DEFSYM (QCfiltered, ":filtered"); + /* The symbol `face-alias'. A symbol having that property is an alias for another face. Value of the property is the name of the aliased face. */ @@ -6502,6 +6654,12 @@ syms_of_xfaces (void) defsubr (&Sdump_colors); #endif + DEFVAR_BOOL ("face-filters-always-match", face_filters_always_match, + doc: /* Non-nil means that face filters are always deemed to match. +This variable is intended for use only by code that evaluates +the "specifity" of a face specification and should be let-bound +only for this purpose. */); + DEFVAR_LISP ("face-new-frame-defaults", Vface_new_frame_defaults, doc: /* List of global face definitions (for internal use only.) */); Vface_new_frame_defaults = Qnil; @@ -6532,7 +6690,12 @@ other font of the appropriate family and registry is available. */); doc: /* List of ignored fonts. Each element is a regular expression that matches names of fonts to ignore. */); +#ifdef HAVE_OTF_KANNADA_BUG + /* https://debbugs.gnu.org/30193 */ + Vface_ignored_fonts = list1 (build_string ("Noto Serif Kannada")); +#else Vface_ignored_fonts = Qnil; +#endif DEFVAR_LISP ("face-remapping-alist", Vface_remapping_alist, doc: /* Alist of face remappings. @@ -6545,7 +6708,7 @@ REPLACEMENT is a face specification, i.e. one of the following: (1) a face name (2) a property list of attribute/value pairs, or - (3) a list in which each element has the form of (1) or (2). + (3) a list in which each element has one of the above forms. List values for REPLACEMENT are merged to form the final face specification, with earlier entries taking precedence, in the same way @@ -6565,17 +6728,37 @@ causes EXTRA-FACE... or (FACE-ATTR VAL ...) to be _merged_ with the existing definition of FACE. Note that this isn't necessary for the default face, since every face inherits from the default face. -If this variable is made buffer-local, the face remapping takes effect -only in that buffer. For instance, the mode my-mode could define a -face `my-mode-default', and then in the mode setup function, do: +An entry in the list can also be a filtered face expression of the +form: + + (:filtered FILTER FACE-SPECIFICATION) + +This construct applies FACE-SPECIFICATION (which can have any of the +forms allowed for face specifications generally) only if FILTER +matches at the moment Emacs wants to draw text with the combined face. + +The only filters currently defined are NIL (which always matches) and +(:window PARAMETER VALUE), which matches only in the context of a +window with a parameter EQ-equal to VALUE. + +An entry in the face list can also be nil, which does nothing. + +If `face-remapping-alist' is made buffer-local, the face remapping +takes effect only in that buffer. For instance, the mode my-mode +could define a face `my-mode-default', and then in the mode setup +function, do: (set (make-local-variable \\='face-remapping-alist) \\='((default my-mode-default)))). +You probably want to use the face-remap package included in Emacs +instead of manipulating face-remapping-alist directly. + Because Emacs normally only redraws screen areas when the underlying buffer contents change, you may need to call `redraw-display' after changing this variable for it to take effect. */); Vface_remapping_alist = Qnil; + DEFSYM (Qface_remapping_alist,"face-remapping-alist"); DEFVAR_LISP ("face-font-rescale-alist", Vface_font_rescale_alist, doc: /* Alist of fonts vs the rescaling factors. diff --git a/src/xfns.c b/src/xfns.c index 732bc87814a..9cea420a404 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -215,8 +215,9 @@ x_real_pos_and_offsets (struct frame *f, int win_x = 0, win_y = 0, outer_x = 0, outer_y = 0; int real_x = 0, real_y = 0; bool had_errors = false; - Window win = (FRAME_PARENT_FRAME (f) - ? FRAME_X_WINDOW (FRAME_PARENT_FRAME (f)) + struct frame *parent_frame = FRAME_PARENT_FRAME (f); + Window win = (parent_frame + ? FRAME_X_WINDOW (parent_frame) : f->output_data.x->parent_desc); struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); long max_len = 400; @@ -273,7 +274,7 @@ x_real_pos_and_offsets (struct frame *f, should be the outer WM window. */ for (;;) { - Window wm_window, rootw; + Window wm_window UNINIT, rootw UNINIT; #ifdef USE_XCB xcb_query_tree_cookie_t query_tree_cookie; @@ -355,8 +356,8 @@ x_real_pos_and_offsets (struct frame *f, outer_geom_cookie = xcb_get_geometry (xcb_conn, FRAME_OUTER_WINDOW (f)); - if ((dpyinfo->root_window == f->output_data.x->parent_desc) - && !FRAME_PARENT_FRAME (f)) + if (!parent_frame + && dpyinfo->root_window == f->output_data.x->parent_desc) /* Try _NET_FRAME_EXTENTS if our parent is the root window. */ prop_cookie = xcb_get_property (xcb_conn, 0, win, dpyinfo->Xatom_net_frame_extents, @@ -470,8 +471,7 @@ x_real_pos_and_offsets (struct frame *f, #endif } - if ((dpyinfo->root_window == f->output_data.x->parent_desc) - && !FRAME_PARENT_FRAME (f)) + if (!parent_frame && dpyinfo->root_window == f->output_data.x->parent_desc) { /* Try _NET_FRAME_EXTENTS if our parent is the root window. */ #ifdef USE_XCB @@ -1233,7 +1233,7 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (!NILP (shape_var)) { CHECK_TYPE_RANGED_INTEGER (unsigned, shape_var); - cursor_data.cursor_num[i] = XINT (shape_var); + cursor_data.cursor_num[i] = XFIXNUM (shape_var); } else cursor_data.cursor_num[i] = mouse_cursor_types[i].default_shape; @@ -1456,7 +1456,7 @@ x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt)) return; } - else if (!STRINGP (oldval) && EQ (oldval, Qnil) == EQ (arg, Qnil)) + else if (!STRINGP (oldval) && NILP (oldval) == NILP (arg)) return; block_input (); @@ -1531,8 +1531,8 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) if (FRAME_MINIBUF_ONLY_P (f) || FRAME_PARENT_FRAME (f)) return; - if (TYPE_RANGED_INTEGERP (int, value)) - nlines = XINT (value); + if (TYPE_RANGED_FIXNUMP (int, value)) + nlines = XFIXNUM (value); else nlines = 0; @@ -1618,8 +1618,8 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) return; /* Use VALUE only if an int >= 0. */ - if (RANGED_INTEGERP (0, value, INT_MAX)) - nlines = XFASTINT (value); + if (RANGED_FIXNUMP (0, value, INT_MAX)) + nlines = XFIXNAT (value); else nlines = 0; @@ -1661,8 +1661,8 @@ x_change_tool_bar_height (struct frame *f, int height) FRAME_TOOL_BAR_HEIGHT (f) = height; FRAME_TOOL_BAR_LINES (f) = lines; /* Store the `tool-bar-lines' and `height' frame parameters. */ - store_frame_param (f, Qtool_bar_lines, make_number (lines)); - store_frame_param (f, Qheight, make_number (FRAME_LINES (f))); + store_frame_param (f, Qtool_bar_lines, make_fixnum (lines)); + store_frame_param (f, Qheight, make_fixnum (FRAME_LINES (f))); /* We also have to make sure that the internal border at the top of the frame, below the menu bar or tool bar, is redrawn when the @@ -1716,7 +1716,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldva int border; CHECK_TYPE_RANGED_INTEGER (int, arg); - border = max (XINT (arg), 0); + border = max (XFIXNUM (arg), 0); if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { @@ -3261,8 +3261,8 @@ x_icon_verify (struct frame *f, Lisp_Object parms) icon_y = x_frame_get_and_record_arg (f, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER); if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound)) { - CHECK_NUMBER (icon_x); - CHECK_NUMBER (icon_y); + CHECK_FIXNUM (icon_x); + CHECK_FIXNUM (icon_y); } else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound)) error ("Both left and top icon corners of icon must be specified"); @@ -3292,7 +3292,7 @@ x_icon (struct frame *f, Lisp_Object parms) block_input (); if (! EQ (icon_x, Qunbound)) - x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y)); + x_wm_set_icon_position (f, XFIXNUM (icon_x), XFIXNUM (icon_y)); #if false /* x_get_arg removes the visibility parameter as a side effect, but x_create_frame still needs it. */ @@ -3617,7 +3617,7 @@ This function is an internal primitive--use `make-frame' instead. */) if (EQ (parent, Qunbound)) parent = Qnil; if (! NILP (parent)) - CHECK_NUMBER (parent); + CHECK_FIXNUM (parent); frame = Qnil; tem = x_get_arg (dpyinfo, parms, Qminibuffer, "minibuffer", "Minibuffer", @@ -3725,7 +3725,7 @@ This function is an internal primitive--use `make-frame' instead. */) /* Specify the parent under which to make this X window. */ if (!NILP (parent)) { - f->output_data.x->parent_desc = (Window) XFASTINT (parent); + f->output_data.x->parent_desc = (Window) XFIXNAT (parent); f->output_data.x->explicit_parent = true; } else @@ -3782,7 +3782,7 @@ This function is an internal primitive--use `make-frame' instead. */) /* Frame contents get displaced if an embedded X window has a border. */ if (! FRAME_X_EMBEDDED_P (f)) - x_default_parameter (f, parms, Qborder_width, make_number (0), + x_default_parameter (f, parms, Qborder_width, make_fixnum (0), "borderWidth", "BorderWidth", RES_TYPE_NUMBER); /* This defaults to 1 in order to match xterm. We recognize either @@ -3800,15 +3800,15 @@ This function is an internal primitive--use `make-frame' instead. */) } x_default_parameter (f, parms, Qinternal_border_width, #ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */ - make_number (0), + make_fixnum (0), #else - make_number (1), + make_fixnum (1), #endif "internalBorderWidth", "internalBorderWidth", RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qright_divider_width, make_number (0), + x_default_parameter (f, parms, Qright_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qbottom_divider_width, make_number (0), + x_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); x_default_parameter (f, parms, Qvertical_scroll_bars, #if defined (USE_GTK) && defined (USE_TOOLKIT_SCROLL_BARS) @@ -3866,10 +3866,10 @@ This function is an internal primitive--use `make-frame' instead. */) Also process `min-width' and `min-height' parameters right here because `frame-windows-min-size' needs them. */ tem = x_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, RES_TYPE_NUMBER); - if (NUMBERP (tem)) + if (FIXNUMP (tem)) store_frame_param (f, Qmin_width, tem); tem = x_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, RES_TYPE_NUMBER); - if (NUMBERP (tem)) + if (FIXNUMP (tem)) store_frame_param (f, Qmin_height, tem); adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, true, @@ -3882,11 +3882,11 @@ This function is an internal primitive--use `make-frame' instead. */) x_default_parameter (f, parms, Qmenu_bar_lines, NILP (Vmenu_bar_mode) - ? make_number (0) : make_number (1), + ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); x_default_parameter (f, parms, Qtool_bar_lines, NILP (Vtool_bar_mode) - ? make_number (0) : make_number (1), + ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); x_default_parameter (f, parms, Qbuffer_predicate, Qnil, @@ -4125,7 +4125,7 @@ x_focus_frame (struct frame *f, bool noactivate) DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, - doc: /* Internal function called by `color-defined-p', which see. + doc: /* Internal function called by `color-defined-p'. \(Note that the Nextstep version of this function ignores FRAME.) */) (Lisp_Object color, Lisp_Object frame) { @@ -4141,7 +4141,8 @@ DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, } DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, - doc: /* Internal function called by `color-values', which see. */) + doc: /* Internal function called by `color-values'. +\(Note that the Nextstep version of this function ignores FRAME.) */) (Lisp_Object color, Lisp_Object frame) { XColor foo; @@ -4156,7 +4157,7 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, } DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, - doc: /* Internal function called by `display-color-p', which see. */) + doc: /* Internal function called by `display-color-p'. */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); @@ -4212,6 +4213,7 @@ DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). If omitted or nil, that stands for the selected frame's display. +\(On MS Windows, this function does not accept terminal objects.) On \"multi-monitor\" setups this refers to the pixel width for all physical monitors associated with TERMINAL. To get information for @@ -4220,7 +4222,7 @@ each physical monitor, use `display-monitor-attributes-list'. */) { struct x_display_info *dpyinfo = check_x_display_info (terminal); - return make_number (x_display_pixel_width (dpyinfo)); + return make_fixnum (x_display_pixel_width (dpyinfo)); } DEFUN ("x-display-pixel-height", Fx_display_pixel_height, @@ -4229,6 +4231,7 @@ DEFUN ("x-display-pixel-height", Fx_display_pixel_height, The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). If omitted or nil, that stands for the selected frame's display. +\(On MS Windows, this function does not accept terminal objects.) On \"multi-monitor\" setups this refers to the pixel height for all physical monitors associated with TERMINAL. To get information for @@ -4237,7 +4240,7 @@ each physical monitor, use `display-monitor-attributes-list'. */) { struct x_display_info *dpyinfo = check_x_display_info (terminal); - return make_number (x_display_pixel_height (dpyinfo)); + return make_fixnum (x_display_pixel_height (dpyinfo)); } DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, @@ -4245,12 +4248,13 @@ DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, doc: /* Return the number of bitplanes of the X display TERMINAL. The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. +\(On MS Windows, this function does not accept terminal objects.) */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); - return make_number (dpyinfo->n_planes); + return make_fixnum (dpyinfo->n_planes); } DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, @@ -4258,7 +4262,8 @@ DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, doc: /* Return the number of color cells of the X display TERMINAL. The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. +\(On MS Windows, this function does not accept terminal objects.) */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); @@ -4273,7 +4278,7 @@ If omitted or nil, that stands for the selected frame's display. */) it "should be enough for everyone". */ if (nr_planes > 24) nr_planes = 24; - return make_number (1 << nr_planes); + return make_fixnum (1 << nr_planes); } DEFUN ("x-server-max-request-size", Fx_server_max_request_size, @@ -4282,12 +4287,15 @@ DEFUN ("x-server-max-request-size", Fx_server_max_request_size, doc: /* Return the maximum request size of the X server of display TERMINAL. The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +On MS Windows, this function just returns 1. +On Nextstep, this function just returns nil. */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); - return make_number (MAXREQUEST (dpyinfo->display)); + return make_fixnum (MAXREQUEST (dpyinfo->display)); } DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0, @@ -4297,8 +4305,8 @@ DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0, that operating systems cannot be developed and distributed noncommercially.) The optional argument TERMINAL specifies which display to ask about. -For GNU and Unix systems, this queries the X server software; for -MS-Windows, this queries the OS. +For GNU and Unix systems, this queries the X server software. +For MS Windows and Nextstep the result is hard-coded. TERMINAL should be a terminal object, a frame or a display name (a string). If omitted or nil, that stands for the selected frame's display. */) @@ -4318,8 +4326,9 @@ software in use. For GNU and Unix system, the first 2 numbers are the version of the X Protocol used on TERMINAL and the 3rd number is the distributor-specific -release number. For MS-Windows, the 3 numbers report the version and -the build number of the OS. +release number. For MS Windows, the 3 numbers report the OS major and +minor version and build number. For Nextstep, the first 2 numbers are +hard-coded and the 3rd represents the OS version. See also the function `x-server-vendor'. @@ -4339,12 +4348,17 @@ DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, doc: /* Return the number of screens on the X server of display TERMINAL. The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +On MS Windows, this function just returns 1. +On Nextstep, "screen" is in X terminology, not that of Nextstep. +For the number of physical monitors, use `(length +\(display-monitor-attributes-list TERMINAL))' instead. */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); - return make_number (ScreenCount (dpyinfo->display)); + return make_fixnum (ScreenCount (dpyinfo->display)); } DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0, @@ -4352,6 +4366,7 @@ DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). If omitted or nil, that stands for the selected frame's display. +\(On MS Windows, this function does not accept terminal objects.) On \"multi-monitor\" setups this refers to the height in millimeters for all physical monitors associated with TERMINAL. To get information @@ -4360,7 +4375,7 @@ for each physical monitor, use `display-monitor-attributes-list'. */) { struct x_display_info *dpyinfo = check_x_display_info (terminal); - return make_number (HeightMMOfScreen (dpyinfo->screen)); + return make_fixnum (HeightMMOfScreen (dpyinfo->screen)); } DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, @@ -4368,6 +4383,7 @@ DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). If omitted or nil, that stands for the selected frame's display. +\(On MS Windows, this function does not accept terminal objects.) On \"multi-monitor\" setups this refers to the width in millimeters for all physical monitors associated with TERMINAL. To get information @@ -4376,16 +4392,19 @@ for each physical monitor, use `display-monitor-attributes-list'. */) { struct x_display_info *dpyinfo = check_x_display_info (terminal); - return make_number (WidthMMOfScreen (dpyinfo->screen)); + return make_fixnum (WidthMMOfScreen (dpyinfo->screen)); } DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_store, 0, 1, 0, doc: /* Return an indication of whether X display TERMINAL does backing store. -The value may be `always', `when-mapped', or `not-useful'. The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +The value may be `always', `when-mapped', or `not-useful'. +On Nextstep, the value may be `buffered', `retained', or `non-retained'. +On MS Windows, this returns nothing useful. */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); @@ -4417,10 +4436,12 @@ DEFUN ("x-display-visual-class", Fx_display_visual_class, doc: /* Return the visual class of the X display TERMINAL. The value is one of the symbols `static-gray', `gray-scale', `static-color', `pseudo-color', `true-color', or `direct-color'. +\(On MS Windows, the second and last result above are not possible.) The optional argument TERMINAL specifies which display to ask about. TERMINAL should a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. +\(On MS Windows, this function does not accept terminal objects.) */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); @@ -4458,7 +4479,9 @@ DEFUN ("x-display-save-under", Fx_display_save_under, doc: /* Return t if the X display TERMINAL supports the save-under feature. The optional argument TERMINAL specifies which display to ask about. TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. */) +If omitted or nil, that stands for the selected frame's display. + +On MS Windows, this just returns nil. */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); @@ -4605,15 +4628,16 @@ x_make_monitor_attribute_list (struct MonitorInfo *monitors, struct x_display_info *dpyinfo, const char *source) { - Lisp_Object monitor_frames = Fmake_vector (make_number (n_monitors), Qnil); + Lisp_Object monitor_frames = make_nil_vector (n_monitors); Lisp_Object frame, rest; FOR_EACH_FRAME (rest, frame) { struct frame *f = XFRAME (frame); - if (FRAME_X_P (f) && FRAME_DISPLAY_INFO (f) == dpyinfo - && !EQ (frame, tip_frame)) + if (FRAME_X_P (f) + && FRAME_DISPLAY_INFO (f) == dpyinfo + && !FRAME_TOOLTIP_P (f)) { int i = x_get_monitor_for_frame (f, monitors, n_monitors); ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i))); @@ -4907,19 +4931,16 @@ Internal use only, use `display-monitor-attributes-list' instead. */) #endif n_monitors = gdk_screen_get_n_monitors (gscreen); #endif - monitor_frames = Fmake_vector (make_number (n_monitors), Qnil); + monitor_frames = make_nil_vector (n_monitors); monitors = xzalloc (n_monitors * sizeof *monitors); FOR_EACH_FRAME (rest, frame) { struct frame *f = XFRAME (frame); - if (FRAME_X_P (f) && FRAME_DISPLAY_INFO (f) == dpyinfo - && !(EQ (frame, tip_frame) -#ifdef USE_GTK - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - )) + if (FRAME_X_P (f) + && FRAME_DISPLAY_INFO (f) == dpyinfo + && !FRAME_TOOLTIP_P (f)) { GdkWindow *gwin = gtk_widget_get_window (FRAME_GTK_WIDGET (f)); @@ -5078,8 +5099,8 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute) edges = Fx_frame_edges (parent, Qnative_edges); if (!NILP (edges)) { - x_native += XINT (Fnth (make_number (0), edges)); - y_native += XINT (Fnth (make_number (1), edges)); + x_native += XFIXNUM (Fnth (make_fixnum (0), edges)); + y_native += XFIXNUM (Fnth (make_fixnum (1), edges)); } outer_left = x_native; @@ -5164,43 +5185,43 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute) /* Construct list. */ if (EQ (attribute, Qouter_edges)) - return list4 (make_number (outer_left), make_number (outer_top), - make_number (outer_right), make_number (outer_bottom)); + return list4 (make_fixnum (outer_left), make_fixnum (outer_top), + make_fixnum (outer_right), make_fixnum (outer_bottom)); else if (EQ (attribute, Qnative_edges)) - return list4 (make_number (native_left), make_number (native_top), - make_number (native_right), make_number (native_bottom)); + return list4 (make_fixnum (native_left), make_fixnum (native_top), + make_fixnum (native_right), make_fixnum (native_bottom)); else if (EQ (attribute, Qinner_edges)) - return list4 (make_number (inner_left), make_number (inner_top), - make_number (inner_right), make_number (inner_bottom)); + return list4 (make_fixnum (inner_left), make_fixnum (inner_top), + make_fixnum (inner_right), make_fixnum (inner_bottom)); else return listn (CONSTYPE_HEAP, 11, Fcons (Qouter_position, - Fcons (make_number (outer_left), - make_number (outer_top))), + Fcons (make_fixnum (outer_left), + make_fixnum (outer_top))), Fcons (Qouter_size, - Fcons (make_number (outer_right - outer_left), - make_number (outer_bottom - outer_top))), + Fcons (make_fixnum (outer_right - outer_left), + make_fixnum (outer_bottom - outer_top))), /* Approximate. */ Fcons (Qexternal_border_size, - Fcons (make_number (right_off), - make_number (bottom_off))), - Fcons (Qouter_border_width, make_number (x_border_width)), + Fcons (make_fixnum (right_off), + make_fixnum (bottom_off))), + Fcons (Qouter_border_width, make_fixnum (x_border_width)), /* Approximate. */ Fcons (Qtitle_bar_size, - Fcons (make_number (0), - make_number (top_off - bottom_off))), + Fcons (make_fixnum (0), + make_fixnum (top_off - bottom_off))), Fcons (Qmenu_bar_external, menu_bar_external ? Qt : Qnil), Fcons (Qmenu_bar_size, - Fcons (make_number (menu_bar_width), - make_number (menu_bar_height))), + Fcons (make_fixnum (menu_bar_width), + make_fixnum (menu_bar_height))), Fcons (Qtool_bar_external, tool_bar_external ? Qt : Qnil), Fcons (Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)), Fcons (Qtool_bar_size, - Fcons (make_number (tool_bar_width), - make_number (tool_bar_height))), + Fcons (make_fixnum (tool_bar_width), + make_fixnum (tool_bar_height))), Fcons (Qinternal_border_width, - make_number (internal_border_width))); + make_fixnum (internal_border_width))); } DEFUN ("x-frame-geometry", Fx_frame_geometry, Sx_frame_geometry, 0, 1, 0, @@ -5400,16 +5421,10 @@ Some window managers may refuse to restack windows. */) struct frame *f1 = decode_live_frame (frame1); struct frame *f2 = decode_live_frame (frame2); - if (FRAME_OUTER_WINDOW (f1) && FRAME_OUTER_WINDOW (f2)) - { - x_frame_restack (f1, f2, !NILP (above)); - return Qt; - } - else - { - error ("Cannot restack frames"); - return Qnil; - } + if (! (FRAME_OUTER_WINDOW (f1) && FRAME_OUTER_WINDOW (f2))) + error ("Cannot restack frames"); + x_frame_restack (f1, f2, !NILP (above)); + return Qt; } @@ -5435,7 +5450,7 @@ selected frame's display. */) (unsigned int *) &dummy); unblock_input (); - return Fcons (make_number (x), make_number (y)); + return Fcons (make_fixnum (x), make_fixnum (y)); } DEFUN ("x-set-mouse-absolute-pixel-position", Fx_set_mouse_absolute_pixel_position, @@ -5455,7 +5470,7 @@ The coordinates X and Y are interpreted in pixels relative to a position block_input (); XWarpPointer (FRAME_X_DISPLAY (f), None, DefaultRootWindow (FRAME_X_DISPLAY (f)), - 0, 0, 0, 0, XINT (x), XINT (y)); + 0, 0, 0, 0, XFIXNUM (x), XFIXNUM (y)); unblock_input (); return Qnil; @@ -5658,8 +5673,8 @@ DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0, doc: /* Close the connection to TERMINAL's X server. For TERMINAL, specify a terminal object, a frame or a display name (a -string). If TERMINAL is nil, that stands for the selected frame's -terminal. */) +string). If TERMINAL is nil, that stands for the selected frame's terminal. +\(On MS Windows, this function does not accept terminal objects.) */) (Lisp_Object terminal) { struct x_display_info *dpyinfo = check_x_display_info (terminal); @@ -5701,7 +5716,7 @@ If TERMINAL is omitted or nil, that stands for the selected frame's display. */ { struct x_display_info *dpyinfo = check_x_display_info (terminal); - XSynchronize (dpyinfo->display, !EQ (on, Qnil)); + XSynchronize (dpyinfo->display, !NILP (on)); return Qnil; } @@ -5753,12 +5768,12 @@ FRAME. Default is to change on the edit X window. */) if (! NILP (format)) { - CHECK_NUMBER (format); + CHECK_FIXNUM (format); - if (XINT (format) != 8 && XINT (format) != 16 - && XINT (format) != 32) + if (XFIXNUM (format) != 8 && XFIXNUM (format) != 16 + && XFIXNUM (format) != 32) error ("FORMAT must be one of 8, 16 or 32"); - element_format = XINT (format); + element_format = XFIXNUM (format); } if (CONSP (value)) @@ -5932,8 +5947,6 @@ FRAME. The number 0 denotes the root window. If DELETE-P is non-nil, delete the property after retrieving it. If VECTOR-RET-P is non-nil, don't return a string but a vector of values. -On MS Windows, this function accepts but ignores those optional arguments. - Value is nil if FRAME hasn't a property with name PROP or if PROP has no value of TYPE (always string in the MS Windows case). */) (Lisp_Object prop, Lisp_Object frame, Lisp_Object type, @@ -6053,9 +6066,9 @@ Otherwise, the return value is a vector with the following fields: 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))); + ASET (prop_attr, 0, make_fixnum (actual_type)); + ASET (prop_attr, 1, make_fixnum (actual_format)); + ASET (prop_attr, 2, make_fixnum (bytes_remaining / (actual_format >> 3))); } unblock_input (); @@ -6067,22 +6080,27 @@ Otherwise, the return value is a vector with the following fields: ***********************************************************************/ static void compute_tip_xy (struct frame *, Lisp_Object, Lisp_Object, - Lisp_Object, int, int, int *, int *); + Lisp_Object, int, int, int *, int *); -/* The frame of a currently visible tooltip. */ +/* The frame of the currently visible tooltip. */ +static Lisp_Object tip_frame; -Lisp_Object tip_frame; +/* The window-system window corresponding to the frame of the + currently visible tooltip. */ +Window tip_window; -/* If non-nil, a timer started that hides the last tooltip when it +/* A timer that hides or deletes the currently visible tooltip when it fires. */ - static Lisp_Object tip_timer; -Window tip_window; -/* If non-nil, a vector of 3 elements containing the last args - with which x-show-tip was called. See there. */ +/* STRING argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_string; + +/* Normalized FRAME argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_frame; -static Lisp_Object last_show_tip_args; +/* PARMS argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_parms; static void @@ -6156,6 +6174,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) f->output_data.x->white_relief.pixel = -1; f->output_data.x->black_relief.pixel = -1; + f->tooltip = true; fset_icon_name (f, Qnil); FRAME_DISPLAY_INFO (f) = dpyinfo; f->output_data.x->parent_desc = FRAME_DISPLAY_INFO (f)->root_window; @@ -6232,7 +6251,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) needed to determine window geometry. */ x_default_font_parameter (f, parms); - x_default_parameter (f, parms, Qborder_width, make_number (0), + x_default_parameter (f, parms, Qborder_width, make_fixnum (0), "borderWidth", "BorderWidth", RES_TYPE_NUMBER); /* This defaults to 2 in order to match xterm. We recognize either @@ -6249,12 +6268,12 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) parms); } - x_default_parameter (f, parms, Qinternal_border_width, make_number (1), + x_default_parameter (f, parms, Qinternal_border_width, make_fixnum (1), "internalBorderWidth", "internalBorderWidth", RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qright_divider_width, make_number (0), + x_default_parameter (f, parms, Qright_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); - x_default_parameter (f, parms, Qbottom_divider_width, make_number (0), + x_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); /* Also do the stuff which must be set before the window exists. */ @@ -6420,7 +6439,9 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) the display in *ROOT_X, and *ROOT_Y. */ static void -compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, int width, int height, int *root_x, int *root_y) +compute_tip_xy (struct frame *f, + Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, + int width, int height, int *root_x, int *root_y) { Lisp_Object left, top, right, bottom; int win_x, win_y; @@ -6436,8 +6457,8 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object /* Move the tooltip window where the mouse pointer is. Resize and show it. */ - if ((!INTEGERP (left) && !INTEGERP (right)) - || (!INTEGERP (top) && !INTEGERP (bottom))) + if ((!FIXNUMP (left) && !FIXNUMP (right)) + || (!FIXNUMP (top) && !FIXNUMP (bottom))) { Lisp_Object frame, attributes, monitor, geometry; @@ -6457,10 +6478,10 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object geometry = Fassq (Qgeometry, monitor); if (CONSP (geometry)) { - min_x = XINT (Fnth (make_number (1), geometry)); - min_y = XINT (Fnth (make_number (2), geometry)); - max_x = min_x + XINT (Fnth (make_number (3), geometry)); - max_y = min_y + XINT (Fnth (make_number (4), geometry)); + min_x = XFIXNUM (Fnth (make_fixnum (1), geometry)); + min_y = XFIXNUM (Fnth (make_fixnum (2), geometry)); + max_x = min_x + XFIXNUM (Fnth (make_fixnum (3), geometry)); + max_y = min_y + XFIXNUM (Fnth (make_fixnum (4), geometry)); if (min_x <= *root_x && *root_x < max_x && min_y <= *root_y && *root_y < max_y) { @@ -6483,41 +6504,53 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object max_y = x_display_pixel_height (FRAME_DISPLAY_INFO (f)); } - if (INTEGERP (top)) - *root_y = XINT (top); - else if (INTEGERP (bottom)) - *root_y = XINT (bottom) - height; - else if (*root_y + XINT (dy) <= min_y) + if (FIXNUMP (top)) + *root_y = XFIXNUM (top); + else if (FIXNUMP (bottom)) + *root_y = XFIXNUM (bottom) - height; + else if (*root_y + XFIXNUM (dy) <= min_y) *root_y = min_y; /* Can happen for negative dy */ - else if (*root_y + XINT (dy) + height <= max_y) + else if (*root_y + XFIXNUM (dy) + height <= max_y) /* It fits below the pointer */ - *root_y += XINT (dy); - else if (height + XINT (dy) + min_y <= *root_y) + *root_y += XFIXNUM (dy); + else if (height + XFIXNUM (dy) + min_y <= *root_y) /* It fits above the pointer. */ - *root_y -= height + XINT (dy); + *root_y -= height + XFIXNUM (dy); else /* Put it on the top. */ *root_y = min_y; - if (INTEGERP (left)) - *root_x = XINT (left); - else if (INTEGERP (right)) - *root_x = XINT (right) - width; - else if (*root_x + XINT (dx) <= min_x) + if (FIXNUMP (left)) + *root_x = XFIXNUM (left); + else if (FIXNUMP (right)) + *root_x = XFIXNUM (right) - width; + else if (*root_x + XFIXNUM (dx) <= min_x) *root_x = 0; /* Can happen for negative dx */ - else if (*root_x + XINT (dx) + width <= max_x) + else if (*root_x + XFIXNUM (dx) + width <= max_x) /* It fits to the right of the pointer. */ - *root_x += XINT (dx); - else if (width + XINT (dx) + min_x <= *root_x) + *root_x += XFIXNUM (dx); + else if (width + XFIXNUM (dx) + min_x <= *root_x) /* It fits to the left of the pointer. */ - *root_x -= width + XINT (dx); + *root_x -= width + XFIXNUM (dx); else /* Put it left justified on the screen -- it ought to fit that way. */ *root_x = min_x; } -/* Hide tooltip. Delete its frame if DELETE is true. */ +/** + * x_hide_tip: + * + * Hide currently visible tooltip and cancel its timer. + * + * If GTK+ system tooltips are used, this will try to hide the tooltip + * referenced by the x_output structure of tooltip_last_frame. For + * Emacs tooltips this will try to make tooltip_frame invisible (if + * DELETE is false) or delete tooltip_frame (if DELETE is true). + * + * Return Qt if the tooltip was either deleted or made invisible, Qnil + * otherwise. + */ static Lisp_Object x_hide_tip (bool delete) { @@ -6527,10 +6560,21 @@ x_hide_tip (bool delete) tip_timer = Qnil; } - - if (NILP (tip_frame) - || (!delete && FRAMEP (tip_frame) +#ifdef USE_GTK + /* Any GTK+ system tooltip can be found via the x_output structure of + tip_last_frame, provided that frame is still live. Any Emacs + tooltip is found via the tip_frame variable. Note that the current + value of x_gtk_use_system_tooltips might not be the same as used + for the tooltip we have to hide, see Bug#30399. */ + if ((NILP (tip_last_frame) && NILP (tip_frame)) + || (!x_gtk_use_system_tooltips + && !delete + && FRAMEP (tip_frame) + && FRAME_LIVE_P (XFRAME (tip_frame)) && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) + /* Either there's no tooltip to hide or it's an already invisible + Emacs tooltip and we don't want to change its type. Return + quickly. */ return Qnil; else { @@ -6541,61 +6585,117 @@ x_hide_tip (bool delete) 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); + /* Try to hide the GTK+ system tip first. */ + if (FRAMEP (tip_last_frame)) + { + struct frame *f = XFRAME (tip_last_frame); - if (FRAME_LIVE_P (f) && xg_hide_tooltip (f)) - { - tip_frame = Qnil; - was_open = Qt; - } - } -#endif + if (FRAME_LIVE_P (f)) + { + if (xg_hide_tooltip (f)) + was_open = Qt; + } + } + + /* Reset tip_last_frame, it will be reassigned when showing the + next GTK+ system tooltip. */ + tip_last_frame = Qnil; + /* Now look whether there's an Emacs tip around. */ if (FRAMEP (tip_frame)) { - if (delete) + struct frame *f = XFRAME (tip_frame); + + if (FRAME_LIVE_P (f)) { - delete_frame (tip_frame, Qnil); - tip_frame = Qnil; + if (delete || x_gtk_use_system_tooltips) + { + /* Delete the Emacs tooltip frame when DELETE is true + or we change the tooltip type from an Emacs one to + a GTK+ system one. */ + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (f); + + was_open = Qt; } else - x_make_frame_invisible (XFRAME (tip_frame)); + tip_frame = Qnil; + } + else + tip_frame = Qnil; + + return unbind_to (count, was_open); + } +#else /* not USE_GTK */ + if (NILP (tip_frame) + || (!delete + && FRAMEP (tip_frame) + && FRAME_LIVE_P (XFRAME (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); - was_open = Qt; + if (FRAMEP (tip_frame)) + { + struct frame *f = XFRAME (tip_frame); + + if (FRAME_LIVE_P (f)) + { + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + x_make_frame_invisible (XFRAME (tip_frame)); #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)) + /* 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... */ { - w = f->output_data.x->menubar_widget; + Widget w; + struct frame *f = SELECTED_FRAME (); - if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen) - && w != NULL) + if (FRAME_X_P (f) && FRAME_LIVE_P (f)) { - block_input (); - xlwmenu_redisplay (w); - unblock_input (); + 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 */ + + was_open = Qt; + } + else + tip_frame = Qnil; } else tip_frame = Qnil; return unbind_to (count, was_open); } +#endif /* USE_GTK */ } + 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. @@ -6626,7 +6726,8 @@ with offset DY added (default is -10). 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) + (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, + Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) { struct frame *f, *tip_f; struct window *w; @@ -6637,8 +6738,7 @@ Text larger than the specified size is clipped. */) int old_windows_or_buffers_changed = windows_or_buffers_changed; ptrdiff_t count = SPECPDL_INDEX (); ptrdiff_t count_1; - Lisp_Object window, size; - Lisp_Object tip_buf; + Lisp_Object window, size, tip_buf; AUTO_STRING (tip, " *tip*"); specbind (Qinhibit_redisplay, Qt); @@ -6647,21 +6747,24 @@ Text larger than the specified size is clipped. */) if (SCHARS (string) == 0) string = make_unibyte_string (" ", 1); + if (NILP (frame)) + frame = selected_frame; f = decode_window_system_frame (frame); + if (NILP (timeout)) - timeout = make_number (5); + timeout = make_fixnum (5); else - CHECK_NATNUM (timeout); + CHECK_FIXNAT (timeout); if (NILP (dx)) - dx = make_number (5); + dx = make_fixnum (5); else - CHECK_NUMBER (dx); + CHECK_FIXNUM (dx); if (NILP (dy)) - dy = make_number (-10); + dy = make_fixnum (-10); else - CHECK_NUMBER (dy); + CHECK_FIXNUM (dy); #ifdef USE_GTK if (x_gtk_use_system_tooltips) @@ -6677,36 +6780,27 @@ Text larger than the specified size is clipped. */) { compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y); xg_show_tooltip (f, root_x, root_y); - /* This is used in Fx_hide_tip. */ - XSETFRAME (tip_frame, f); + tip_last_frame = frame; } + unblock_input (); if (ok) goto start_timer; } #endif /* USE_GTK */ - if (NILP (last_show_tip_args)) - last_show_tip_args = Fmake_vector (make_number (3), Qnil); - 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 (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && EQ (frame, last_frame) - && !NILP (Fequal_including_properties (last_string, string)) - && !NILP (Fequal (last_parms, parms))) + && EQ (frame, tip_last_frame) + && !NILP (Fequal_including_properties (tip_last_string, string)) + && !NILP (Fequal (tip_last_parms, parms))) { /* Only DX and DY have changed. */ tip_f = XFRAME (tip_frame); if (!NILP (tip_timer)) { - Lisp_Object timer = tip_timer; - + call1 (Qcancel_timer, tip_timer); tip_timer = Qnil; - call1 (Qcancel_timer, timer); } block_input (); @@ -6718,15 +6812,14 @@ Text larger than the specified size is clipped. */) goto start_timer; } - else if (tooltip_reuse_hidden_frame && EQ (frame, last_frame)) + else if (tooltip_reuse_hidden_frame && EQ (frame, tip_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. */ + tip_last_parms. This may destruct tip_last_parms which, + however, will be recreated below. */ for (tail = parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); @@ -6736,7 +6829,7 @@ Text larger than the specified size is clipped. */) if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) && !EQ (parm, Qbottom)) { - last = Fassq (parm, last_parms); + last = Fassq (parm, tip_last_parms); if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) { /* We lost, delete the old tooltip. */ @@ -6744,17 +6837,18 @@ Text larger than the specified size is clipped. */) break; } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } else - last_parms = call2 (Qassq_delete_all, parm, last_parms); + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); } - /* 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)) + /* Now check if every parameter in what is left of + tip_last_parms with a non-nil value has an association in + PARMS. */ + for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); parm = Fcar (elt); @@ -6775,9 +6869,9 @@ Text larger than the specified size is clipped. */) 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); + tip_last_frame = frame; + tip_last_string = string; + tip_last_parms = parms; if (!FRAMEP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame))) { @@ -6785,9 +6879,9 @@ Text larger than the specified size is clipped. */) 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); + parms = Fcons (Fcons (Qinternal_border_width, make_fixnum (3)), parms); if (NILP (Fassq (Qborder_width, parms))) - parms = Fcons (Fcons (Qborder_width, make_number (1)), parms); + parms = Fcons (Fcons (Qborder_width, make_fixnum (1)), parms); if (NILP (Fassq (Qborder_color, parms))) parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), parms); if (NILP (Fassq (Qbackground_color, parms))) @@ -6806,8 +6900,8 @@ Text larger than the specified size is clipped. */) tip_buf = Fget_buffer_create (tip); /* We will mark the tip window a "pseudo-window" below, and such windows cannot have display margins. */ - bset_left_margin_cols (XBUFFER (tip_buf), make_number (0)); - bset_right_margin_cols (XBUFFER (tip_buf), make_number (0)); + bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); + bset_right_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); set_window_buffer (window, tip_buf, false, false); w = XWINDOW (window); w->pseudo_window_p = true; @@ -6822,11 +6916,11 @@ Text larger than the specified size is clipped. */) w->pixel_top = 0; if (CONSP (Vx_max_tooltip_size) - && RANGED_INTEGERP (1, XCAR (Vx_max_tooltip_size), INT_MAX) - && RANGED_INTEGERP (1, XCDR (Vx_max_tooltip_size), INT_MAX)) + && RANGED_FIXNUMP (1, XCAR (Vx_max_tooltip_size), INT_MAX) + && RANGED_FIXNUMP (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)); + w->total_cols = XFIXNAT (XCAR (Vx_max_tooltip_size)); + w->total_lines = XFIXNAT (XCDR (Vx_max_tooltip_size)); } else { @@ -6856,10 +6950,10 @@ Text larger than the specified size is clipped. */) 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); + make_fixnum (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); + width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + height = XFIXNUM (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); @@ -6964,18 +7058,7 @@ clean_up_file_dialog (void *arg) DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0, - doc: /* Read file name, prompting with PROMPT in directory DIR. -Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file -selection box, if specified. If MUSTMATCH is non-nil, the returned file -or directory must exist. - -This function is only defined on NS, MS Windows, and X Windows with the -Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored. -Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories. -On Windows 7 and later, the file selection dialog "remembers" the last -directory where the user selected a file, and will open that directory -instead of DIR on subsequent invocations of this function with the same -value of DIR as in previous invocations; this is standard Windows behavior. */) + doc: /* SKIP: real doc in USE_GTK definition in xfns.c. */) (Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename, Lisp_Object mustmatch, Lisp_Object only_dir_p) { @@ -7144,10 +7227,10 @@ or directory must exist. This function is only defined on NS, MS Windows, and X Windows with the Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored. Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories. -On Windows 7 and later, the file selection dialog "remembers" the last +On MS Windows 7 and later, the file selection dialog "remembers" the last directory where the user selected a file, and will open that directory instead of DIR on subsequent invocations of this function with the same -value of DIR as in previous invocations; this is standard Windows behavior. */) +value of DIR as in previous invocations; this is standard MS Windows behavior. */) (Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename, Lisp_Object mustmatch, Lisp_Object only_dir_p) { struct frame *f = SELECTED_FRAME (); @@ -7708,7 +7791,7 @@ or when you set the mouse color. */); DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size, doc: /* Maximum size for tooltips. Value is a pair (COLUMNS . ROWS). Text larger than this is clipped. */); - Vx_max_tooltip_size = Fcons (make_number (80), make_number (40)); + Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40)); DEFVAR_LISP ("x-no-window-manager", Vx_no_window_manager, doc: /* Non-nil if no X window manager is in use. @@ -7722,9 +7805,9 @@ unless you set it to something else. */); Vx_pixel_size_width_font_regexp, doc: /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. -Since Emacs gets width of a font matching with this regexp from -PIXEL_SIZE field of the name, font finding mechanism gets faster for -such a font. This is especially effective for such large fonts as +Since Emacs gets the width of a font matching this regexp from the +PIXEL_SIZE field of the name, the font-finding mechanism gets faster for +such a font. This is especially effective for large fonts such as Chinese, Japanese, and Korean. */); Vx_pixel_size_width_font_regexp = Qnil; @@ -7838,7 +7921,6 @@ When using Gtk+ tooltips, the tooltip face is not used. */); defsubr (&Sx_display_list); defsubr (&Sx_synchronize); defsubr (&Sx_backspace_delete_keys_p); - defsubr (&Sx_show_tip); defsubr (&Sx_hide_tip); defsubr (&Sx_double_buffered_p); @@ -7846,9 +7928,12 @@ When using Gtk+ tooltips, the tooltip face is not used. */); staticpro (&tip_timer); tip_frame = Qnil; staticpro (&tip_frame); - - last_show_tip_args = Qnil; - staticpro (&last_show_tip_args); + tip_last_frame = Qnil; + staticpro (&tip_last_frame); + tip_last_string = Qnil; + staticpro (&tip_last_string); + tip_last_parms = Qnil; + staticpro (&tip_last_parms); defsubr (&Sx_uses_old_gtk_dialog); #if defined (USE_MOTIF) || defined (USE_GTK) diff --git a/src/xfont.c b/src/xfont.c index b61c374fdc3..b057aa0a277 100644 --- a/src/xfont.c +++ b/src/xfont.c @@ -190,7 +190,7 @@ xfont_chars_supported (Lisp_Object chars, XFontStruct *xfont, { for (; CONSP (chars); chars = XCDR (chars)) { - int c = XINT (XCAR (chars)); + int c = XFIXNUM (XCAR (chars)); unsigned code = ENCODE_CHAR (charset, c); XChar2b char2b; @@ -213,7 +213,7 @@ xfont_chars_supported (Lisp_Object chars, XFontStruct *xfont, for (i = ASIZE (chars) - 1; i >= 0; i--) { - int c = XINT (AREF (chars, i)); + int c = XFIXNUM (AREF (chars, i)); unsigned code = ENCODE_CHAR (charset, c); XChar2b char2b; @@ -376,18 +376,18 @@ xfont_list_pattern (Display *display, const char *pattern, continue; ASET (entity, FONT_TYPE_INDEX, Qx); /* Avoid auto-scaled fonts. */ - if (INTEGERP (AREF (entity, FONT_DPI_INDEX)) - && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX)) - && XINT (AREF (entity, FONT_DPI_INDEX)) != 0 - && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0) + if (FIXNUMP (AREF (entity, FONT_DPI_INDEX)) + && FIXNUMP (AREF (entity, FONT_AVGWIDTH_INDEX)) + && XFIXNUM (AREF (entity, FONT_DPI_INDEX)) != 0 + && XFIXNUM (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0) continue; /* Avoid not-allowed scalable fonts. */ if (NILP (Vscalable_fonts_allowed)) { int size = 0; - if (INTEGERP (AREF (entity, FONT_SIZE_INDEX))) - size = XINT (AREF (entity, FONT_SIZE_INDEX)); + if (FIXNUMP (AREF (entity, FONT_SIZE_INDEX))) + size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); else if (FLOATP (AREF (entity, FONT_SIZE_INDEX))) size = XFLOAT_DATA (AREF (entity, FONT_SIZE_INDEX)); if (size == 0 && i_pass == 0) @@ -672,8 +672,8 @@ xfont_open (struct frame *f, Lisp_Object entity, int pixel_size) return Qnil; } - if (XINT (AREF (entity, FONT_SIZE_INDEX)) != 0) - pixel_size = XINT (AREF (entity, FONT_SIZE_INDEX)); + if (XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) != 0) + pixel_size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); else if (pixel_size == 0) { if (FRAME_FONT (f)) @@ -811,8 +811,8 @@ xfont_open (struct frame *f, Lisp_Object entity, int pixel_size) font->space_width = 0; val = Ffont_get (font_object, QCavgwidth); - if (INTEGERP (val)) - font->average_width = XINT (val) / 10; + if (FIXNUMP (val)) + font->average_width = XFIXNUM (val) / 10; if (font->average_width < 0) font->average_width = - font->average_width; else @@ -1101,6 +1101,6 @@ syms_of_xfont (void) staticpro (&xfont_scripts_cache); xfont_scripts_cache = CALLN (Fmake_hash_table, QCtest, Qequal); staticpro (&xfont_scratch_props); - xfont_scratch_props = Fmake_vector (make_number (8), Qnil); + xfont_scratch_props = make_nil_vector (8); register_font_driver (&xfont_driver, NULL); } diff --git a/src/xftfont.c b/src/xftfont.c index 805ea0ede9c..b4f50a2cf8d 100644 --- a/src/xftfont.c +++ b/src/xftfont.c @@ -221,24 +221,24 @@ xftfont_add_rendering_parameters (FcPattern *pat, Lisp_Object entity) FcPatternAddBool (pat, FC_AUTOHINT, NILP (val) ? FcFalse : FcTrue); else if (EQ (key, QChintstyle)) { - if (INTEGERP (val)) - FcPatternAddInteger (pat, FC_HINT_STYLE, XINT (val)); + if (FIXNUMP (val)) + FcPatternAddInteger (pat, FC_HINT_STYLE, XFIXNUM (val)); else if (SYMBOLP (val) && FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival)) FcPatternAddInteger (pat, FC_HINT_STYLE, ival); } else if (EQ (key, QCrgba)) { - if (INTEGERP (val)) - FcPatternAddInteger (pat, FC_RGBA, XINT (val)); + if (FIXNUMP (val)) + FcPatternAddInteger (pat, FC_RGBA, XFIXNUM (val)); else if (SYMBOLP (val) && FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival)) FcPatternAddInteger (pat, FC_RGBA, ival); } else if (EQ (key, QClcdfilter)) { - if (INTEGERP (val)) - FcPatternAddInteger (pat, FC_LCD_FILTER, ival = XINT (val)); + if (FIXNUMP (val)) + FcPatternAddInteger (pat, FC_LCD_FILTER, ival = XFIXNUM (val)); else if (SYMBOLP (val) && FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival)) FcPatternAddInteger (pat, FC_LCD_FILTER, ival); @@ -273,7 +273,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) val = XCDR (val); filename = XCAR (val); idx = XCDR (val); - size = XINT (AREF (entity, FONT_SIZE_INDEX)); + size = XFIXNUM (AREF (entity, FONT_SIZE_INDEX)); if (size == 0) size = pixel_size; pat = FcPatternCreate (); @@ -291,16 +291,16 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) FcPatternAddString (pat, FC_FOUNDRY, (FcChar8 *) SDATA (SYMBOL_NAME (val))); val = AREF (entity, FONT_SPACING_INDEX); if (! NILP (val)) - FcPatternAddInteger (pat, FC_SPACING, XINT (val)); + FcPatternAddInteger (pat, FC_SPACING, XFIXNUM (val)); val = AREF (entity, FONT_DPI_INDEX); if (! NILP (val)) { - double dbl = XINT (val); + double dbl = XFIXNUM (val); FcPatternAddDouble (pat, FC_DPI, dbl); } val = AREF (entity, FONT_AVGWIDTH_INDEX); - if (INTEGERP (val) && XINT (val) == 0) + if (FIXNUMP (val) && XFIXNUM (val) == 0) FcPatternAddBool (pat, FC_SCALABLE, FcTrue); /* This is necessary to identify the exact font (e.g. 10x20.pcf.gz over 10x20-ISO8859-1.pcf.gz). */ @@ -309,7 +309,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) xftfont_add_rendering_parameters (pat, entity); FcPatternAddString (pat, FC_FILE, (FcChar8 *) SDATA (filename)); - FcPatternAddInteger (pat, FC_INDEX, XINT (idx)); + FcPatternAddInteger (pat, FC_INDEX, XFIXNUM (idx)); block_input (); @@ -354,8 +354,8 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) xftfont_info->matrix.xy = 0x10000L * matrix->xy; xftfont_info->matrix.yx = 0x10000L * matrix->yx; } - if (INTEGERP (AREF (entity, FONT_SPACING_INDEX))) - spacing = XINT (AREF (entity, FONT_SPACING_INDEX)); + if (FIXNUMP (AREF (entity, FONT_SPACING_INDEX))) + spacing = XFIXNUM (AREF (entity, FONT_SPACING_INDEX)); else spacing = FC_PROPORTIONAL; if (! ascii_printable[0]) @@ -414,7 +414,7 @@ xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size) } font->height = font->ascent + font->descent; - if (XINT (AREF (entity, FONT_SIZE_INDEX)) == 0) + if (XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) == 0) { int upEM = ft_face->units_per_EM; diff --git a/src/xmenu.c b/src/xmenu.c index 49cd5940eae..96c278d42d0 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -3,6 +3,10 @@ Copyright (C) 1986, 1988, 1993-1994, 1996, 1999-2019 Free Software Foundation, Inc. +Author: Jon Arnold + Roman Budzianowski + Robert Krawitz + This file is part of GNU Emacs. GNU Emacs is free software: you can redistribute it and/or modify @@ -20,9 +24,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* X pop-up deck-of-cards menu facility for GNU Emacs. * - * Written by Jon Arnold and Roman Budzianowski - * Mods and rewrite by Robert Krawitz - * */ /* Modified by Fred Pierresteguy on December 93 @@ -278,12 +279,7 @@ popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo, } DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_internal, 0, 1, "i", - doc: /* Start key navigation of the menu bar in FRAME. -This initially opens the first menu bar item and you can then navigate with the -arrow keys, select a menu entry with the return key or cancel with the -escape key. If FRAME has no menu bar this function does nothing. - -If FRAME is nil or not given, use the selected frame. */) + doc: /* SKIP: real doc in USE_GTK definition in xmenu.c. */) (Lisp_Object frame) { XEvent ev; @@ -1177,17 +1173,17 @@ menu_position_func (GtkMenu *menu, gint *x, gint *y, gboolean *push_in, gpointer items in x-display-monitor-attributes-list. */ workarea = call3 (Qframe_monitor_workarea, Qnil, - make_number (data->x), - make_number (data->y)); + make_fixnum (data->x), + make_fixnum (data->y)); if (CONSP (workarea)) { int min_x, min_y; - min_x = XINT (XCAR (workarea)); - min_y = XINT (Fnth (make_number (1), workarea)); - max_x = min_x + XINT (Fnth (make_number (2), workarea)); - max_y = min_y + XINT (Fnth (make_number (3), workarea)); + min_x = XFIXNUM (XCAR (workarea)); + min_y = XFIXNUM (Fnth (make_fixnum (1), workarea)); + max_x = min_x + XFIXNUM (Fnth (make_fixnum (2), workarea)); + max_y = min_y + XFIXNUM (Fnth (make_fixnum (3), workarea)); } if (max_x < 0 || max_y < 0) @@ -1491,7 +1487,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, i = 0; while (i < menu_items_used) { - if (EQ (AREF (menu_items, i), Qnil)) + if (NILP (AREF (menu_items, i))) { submenu_stack[submenu_depth++] = save_wv; save_wv = prev_wv; @@ -1660,7 +1656,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, i = 0; while (i < menu_items_used) { - if (EQ (AREF (menu_items, i), Qnil)) + if (NILP (AREF (menu_items, i))) { subprefix_stack[submenu_depth++] = prefix; prefix = entry; @@ -2047,16 +2043,23 @@ menu_help_callback (char const *help_string, int pane, int item) pane_name = first_item[MENU_ITEMS_ITEM_NAME]; /* (menu-item MENU-NAME PANE-NUMBER) */ - menu_object = list3 (Qmenu_item, pane_name, make_number (pane)); + menu_object = list3 (Qmenu_item, pane_name, make_fixnum (pane)); show_help_echo (help_string ? build_string (help_string) : Qnil, - Qnil, menu_object, make_number (item)); + Qnil, menu_object, make_fixnum (item)); } +struct pop_down_menu +{ + struct frame *frame; + XMenu *menu; +}; + static void -pop_down_menu (Lisp_Object arg) +pop_down_menu (void *arg) { - struct frame *f = XSAVE_POINTER (arg, 0); - XMenu *menu = XSAVE_POINTER (arg, 1); + struct pop_down_menu *data = arg; + struct frame *f = data->frame; + XMenu *menu = data->menu; block_input (); #ifndef MSDOS @@ -2302,7 +2305,8 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, XMenuActivateSetWaitFunction (x_menu_wait_for_event, FRAME_X_DISPLAY (f)); #endif - record_unwind_protect (pop_down_menu, make_save_ptr_ptr (f, menu)); + record_unwind_protect_ptr (pop_down_menu, + &(struct pop_down_menu) {f, menu}); /* Help display under X won't work because XMenuActivate contains a loop that doesn't give Emacs a chance to process it. */ @@ -2371,8 +2375,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, return_entry: unblock_input (); - SAFE_FREE (); - return unbind_to (specpdl_count, entry); + return SAFE_FREE_UNBIND_TO (specpdl_count, entry); } #endif /* not USE_X_TOOLKIT */ @@ -2391,7 +2394,8 @@ popup_activated (void) /* The following is used by delayed window autoselection. */ DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0, - doc: /* Return t if a menu or popup dialog is active. */) + doc: /* Return t if a menu or popup dialog is active. +\(On MS Windows, this refers to the selected frame.) */) (void) { return (popup_activated ()) ? Qt : Qnil; @@ -2416,6 +2420,6 @@ syms_of_xmenu (void) #if defined (USE_GTK) || defined (USE_X_TOOLKIT) defsubr (&Sx_menu_bar_open_internal); Ffset (intern_c_string ("accelerate-menu"), - intern_c_string (Sx_menu_bar_open_internal.symbol_name)); + intern_c_string (Sx_menu_bar_open_internal.s.symbol_name)); #endif } diff --git a/src/xml.c b/src/xml.c index 787e883ea55..60bd958952a 100644 --- a/src/xml.c +++ b/src/xml.c @@ -18,19 +18,20 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> +#include "lisp.h" +#include "buffer.h" + #ifdef HAVE_LIBXML2 #include <libxml/tree.h> #include <libxml/parser.h> #include <libxml/HTMLparser.h> -#include "lisp.h" -#include "buffer.h" - #ifdef WINDOWSNT # include <windows.h> +# include "w32common.h" # include "w32.h" DEF_DLL_FN (htmlDocPtr, htmlReadMemory, @@ -187,8 +188,8 @@ parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, validate_region (&start, &end); - istart = XINT (start); - iend = XINT (end); + istart = XFIXNUM (start); + iend = XFIXNUM (end); istart_byte = CHAR_TO_BYTE (istart); iend_byte = CHAR_TO_BYTE (iend); @@ -271,7 +272,9 @@ DEFUN ("libxml-parse-html-region", Flibxml_parse_html_region, 2, 4, 0, doc: /* Parse the region as an HTML document and return the parse tree. If BASE-URL is non-nil, it is used to expand relative URLs. -If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */) + +If you want comments to be stripped, use the `xml-remove-comments' +function to strip comments before calling this function. */) (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments) { if (init_libxml2_functions ()) @@ -284,23 +287,52 @@ DEFUN ("libxml-parse-xml-region", Flibxml_parse_xml_region, 2, 4, 0, doc: /* Parse the region as an XML document and return the parse tree. If BASE-URL is non-nil, it is used to expand relative URLs. -If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */) + +If you want comments to be stripped, use the `xml-remove-comments' +function to strip comments before calling this function. */) (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments) { if (init_libxml2_functions ()) return parse_region (start, end, base_url, discard_comments, false); return Qnil; } +#endif /* HAVE_LIBXML2 */ + +DEFUN ("libxml-available-p", Flibxml_available_p, Slibxml_available_p, 0, 0, 0, + doc: /* Return t if libxml2 support is available in this instance of Emacs.*/) + (void) +{ +#ifdef HAVE_LIBXML2 +# ifdef WINDOWSNT + Lisp_Object found = Fassq (Qlibxml2, Vlibrary_cache); + if (CONSP (found)) + return XCDR (found); + else + { + Lisp_Object status; + status = init_libxml2_functions () ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qlibxml2, status), Vlibrary_cache); + return status; + } +# else + return Qt; +# endif /* WINDOWSNT */ +#else + return Qnil; +#endif /* HAVE_LIBXML2 */ +} + /*********************************************************************** Initialization ***********************************************************************/ void syms_of_xml (void) { +#ifdef HAVE_LIBXML2 defsubr (&Slibxml_parse_html_region); defsubr (&Slibxml_parse_xml_region); +#endif + defsubr (&Slibxml_available_p); } - -#endif /* HAVE_LIBXML2 */ diff --git a/src/xrdb.c b/src/xrdb.c index 41b1dd8c033..35de446cb7a 100644 --- a/src/xrdb.c +++ b/src/xrdb.c @@ -202,35 +202,6 @@ magic_db (const char *string, ptrdiff_t string_len, const char *class, } -static char * -gethomedir (void) -{ - struct passwd *pw; - char *ptr; - char *copy; - - if ((ptr = getenv ("HOME")) == NULL) - { - if ((ptr = getenv ("LOGNAME")) != NULL - || (ptr = getenv ("USER")) != NULL) - pw = getpwnam (ptr); - else - pw = getpwuid (getuid ()); - - if (pw) - ptr = pw->pw_dir; - } - - if (ptr == NULL) - return xstrdup ("/"); - - ptrdiff_t len = strlen (ptr); - copy = xmalloc (len + 2); - strcpy (copy + len, "/"); - return memcpy (copy, ptr, len); -} - - /* Find the first element of SEARCH_PATH which exists and is readable, after expanding the %-escapes. Return 0 if we didn't find any, and the path name of the one we found otherwise. */ @@ -316,12 +287,11 @@ get_user_app (const char *class) if (! db) { /* Check in the home directory. This is a bit of a hack; let's - hope one's home directory doesn't contain any %-escapes. */ - char *home = gethomedir (); + hope one's home directory doesn't contain ':' or '%'. */ + char const *home = get_homedir (); db = search_magic_path (home, class, "%L/%N"); if (! db) db = search_magic_path (home, class, "%N"); - xfree (home); } return db; @@ -346,10 +316,9 @@ get_user_db (Display *display) else { /* Use ~/.Xdefaults. */ - char *home = gethomedir (); - ptrdiff_t homelen = strlen (home); - char *filename = xrealloc (home, homelen + sizeof xdefaults); - strcpy (filename + homelen, xdefaults); + char const *home = get_homedir (); + char *filename = xmalloc (strlen (home) + 1 + sizeof xdefaults); + splice_dir_file (filename, home, xdefaults); db = XrmGetFileDatabase (filename); xfree (filename); } @@ -380,13 +349,12 @@ get_environ_db (void) if (STRINGP (system_name)) { /* Use ~/.Xdefaults-HOSTNAME. */ - char *home = gethomedir (); - ptrdiff_t homelen = strlen (home); - ptrdiff_t filenamesize = (homelen + sizeof xdefaults - + 1 + SBYTES (system_name)); - p = filename = xrealloc (home, filenamesize); - lispstpcpy (stpcpy (stpcpy (filename + homelen, xdefaults), "-"), - system_name); + char const *home = get_homedir (); + p = filename = xmalloc (strlen (home) + 1 + sizeof xdefaults + + 1 + SBYTES (system_name)); + char *e = splice_dir_file (p, home, xdefaults); + *e++ = '/'; + lispstpcpy (e, system_name); } } @@ -474,13 +442,13 @@ x_load_resources (Display *display, const char *xrm_string, /* Set double click time of list boxes in the file selection dialog from `double-click-time'. */ - if (INTEGERP (Vdouble_click_time) && XINT (Vdouble_click_time) > 0) + if (FIXNUMP (Vdouble_click_time) && XFIXNUM (Vdouble_click_time) > 0) { sprintf (line, "%s*fsb*DirList.doubleClickInterval: %"pI"d", - myclass, XFASTINT (Vdouble_click_time)); + myclass, XFIXNAT (Vdouble_click_time)); XrmPutLineResource (&rdb, line); sprintf (line, "%s*fsb*ItemsList.doubleClickInterval: %"pI"d", - myclass, XFASTINT (Vdouble_click_time)); + myclass, XFIXNAT (Vdouble_click_time)); XrmPutLineResource (&rdb, line); } diff --git a/src/xselect.c b/src/xselect.c index 9c6a3498589..4621263c62e 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -321,7 +321,7 @@ x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value, Lisp_Object prev_value; selection_data = list4 (selection_name, selection_value, - INTEGER_TO_CONS (timestamp), frame); + INT_TO_INTEGER (timestamp), frame); prev_value = LOCAL_SELECTION (selection_name, dpyinfo); tset_selection_alist @@ -387,7 +387,7 @@ x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type, XCAR (XCDR (local_value))); else value = Qnil; - unbind_to (count, Qnil); + value = unbind_to (count, value); } /* Make sure this value is of a type that we could transmit @@ -1536,17 +1536,10 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo, ATOM 32 > 1 Vector of Symbols * 16 1 Integer * 16 > 1 Vector of Integers - * 32 1 if <=16 bits: Integer - if > 16 bits: Cons of top16, bot16 + * 32 1 if small enough: fixnum + otherwise: bignum * 32 > 1 Vector of the above - When converting a Lisp number to C, it is assumed to be of format 16 if - it is an integer, and of format 32 if it is a cons of two integers. - - When converting a vector of numbers from Lisp to C, it is assumed to be - of format 16 if every element in the vector is an integer, and is assumed - to be of format 32 if any element is a cons of two integers. - When converting an object to C, it may be of the form (SYMBOL . <data>) where SYMBOL is what we should claim that the type is. Format and representation are as above. @@ -1581,7 +1574,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, lispy_type = QUTF8_STRING; else lispy_type = QSTRING; - Fput_text_property (make_number (0), make_number (size), + Fput_text_property (make_fixnum (0), make_fixnum (size), Qforeign_selection, lispy_type, str); return str; } @@ -1611,8 +1604,8 @@ 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. + If the number is 32 bits and won't fit in a Lisp_Int, convert it + to a bignum. INTEGER is a signed type, CARDINAL is unsigned. Assume any other types are unsigned as well. @@ -1620,16 +1613,16 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, else if (format == 32 && size == sizeof (int)) { if (type == XA_INTEGER) - return INTEGER_TO_CONS (((int *) data) [0]); + return INT_TO_INTEGER (((int *) data) [0]); else - return INTEGER_TO_CONS (((unsigned int *) data) [0]); + return INT_TO_INTEGER (((unsigned int *) data) [0]); } else if (format == 16 && size == sizeof (short)) { if (type == XA_INTEGER) - return make_number (((short *) data) [0]); + return make_fixnum (((short *) data) [0]); else - return make_number (((unsigned short *) data) [0]); + return make_fixnum (((unsigned short *) data) [0]); } /* Convert any other kind of data to a vector of numbers, represented @@ -1645,7 +1638,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, for (i = 0; i < size / 2; i++) { short j = ((short *) data) [i]; - ASET (v, i, make_number (j)); + ASET (v, i, make_fixnum (j)); } } else @@ -1653,7 +1646,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, for (i = 0; i < size / 2; i++) { unsigned short j = ((unsigned short *) data) [i]; - ASET (v, i, make_number (j)); + ASET (v, i, make_fixnum (j)); } } return v; @@ -1668,7 +1661,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, for (i = 0; i < size / X_LONG_SIZE; i++) { int j = ((int *) data) [i]; - ASET (v, i, INTEGER_TO_CONS (j)); + ASET (v, i, INT_TO_INTEGER (j)); } } else @@ -1676,7 +1669,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, for (i = 0; i < size / X_LONG_SIZE; i++) { unsigned int j = ((unsigned int *) data) [i]; - ASET (v, i, INTEGER_TO_CONS (j)); + ASET (v, i, INT_TO_INTEGER (j)); } } return v; @@ -1693,7 +1686,7 @@ static unsigned long cons_to_x_long (Lisp_Object obj) { if (X_ULONG_MAX <= INTMAX_MAX - || XINT (INTEGERP (obj) ? obj : XCAR (obj)) < 0) + || NILP (Fnatnump (CONSP (obj) ? XCAR (obj) : obj))) return cons_to_signed (obj, X_LONG_MIN, min (X_ULONG_MAX, INTMAX_MAX)); else return cons_to_unsigned (obj, X_ULONG_MAX); @@ -1748,7 +1741,7 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo, *x_atom_ptr = symbol_to_x_atom (dpyinfo, obj); if (NILP (type)) type = QATOM; } - else if (RANGED_INTEGERP (X_SHRT_MIN, obj, X_SHRT_MAX)) + else if (RANGED_FIXNUMP (X_SHRT_MIN, obj, X_SHRT_MAX)) { void *data = xmalloc (sizeof (short) + 1); short *short_ptr = data; @@ -1756,14 +1749,14 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo, cs->format = 16; cs->size = 1; cs->data[sizeof (short)] = 0; - *short_ptr = XINT (obj); + *short_ptr = XFIXNUM (obj); if (NILP (type)) type = QINTEGER; } else if (INTEGERP (obj) || (CONSP (obj) && INTEGERP (XCAR (obj)) - && (INTEGERP (XCDR (obj)) + && (FIXNUMP (XCDR (obj)) || (CONSP (XCDR (obj)) - && INTEGERP (XCAR (XCDR (obj))))))) + && FIXNUMP (XCAR (XCDR (obj))))))) { void *data = xmalloc (sizeof (unsigned long) + 1); unsigned long *x_long_ptr = data; @@ -1811,7 +1804,7 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo, if (NILP (type)) type = QINTEGER; for (i = 0; i < size; i++) { - if (! RANGED_INTEGERP (X_SHRT_MIN, AREF (obj, i), + if (! RANGED_FIXNUMP (X_SHRT_MIN, AREF (obj, i), X_SHRT_MAX)) { /* Use sizeof (long) even if it is more than 32 bits. @@ -1832,7 +1825,7 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo, if (format == 32) x_atoms[i] = cons_to_x_long (AREF (obj, i)); else - shorts[i] = XINT (AREF (obj, i)); + shorts[i] = XFIXNUM (AREF (obj, i)); } } } @@ -1848,18 +1841,18 @@ clean_local_selection_data (Lisp_Object obj) if (CONSP (obj) && INTEGERP (XCAR (obj)) && CONSP (XCDR (obj)) - && INTEGERP (XCAR (XCDR (obj))) + && FIXNUMP (XCAR (XCDR (obj))) && NILP (XCDR (XCDR (obj)))) obj = Fcons (XCAR (obj), XCDR (obj)); if (CONSP (obj) && INTEGERP (XCAR (obj)) - && INTEGERP (XCDR (obj))) + && FIXNUMP (XCDR (obj))) { - if (XINT (XCAR (obj)) == 0) + if (EQ (XCAR (obj), make_fixnum (0))) return XCDR (obj); - if (XINT (XCAR (obj)) == -1) - return make_number (- XINT (XCDR (obj))); + if (EQ (XCAR (obj), make_fixnum (-1))) + return make_fixnum (- XFIXNUM (XCDR (obj))); } if (VECTORP (obj)) { @@ -2094,7 +2087,7 @@ On Nextstep, TERMINAL is unused. */) struct frame *f = frame_for_x_selection (terminal); CHECK_SYMBOL (selection); - if (EQ (selection, Qnil)) selection = QPRIMARY; + if (NILP (selection)) selection = QPRIMARY; if (EQ (selection, Qt)) selection = QSECONDARY; if (f && !NILP (LOCAL_SELECTION (selection, FRAME_DISPLAY_INFO (f)))) @@ -2124,7 +2117,7 @@ On Nextstep, TERMINAL is unused. */) struct x_display_info *dpyinfo; CHECK_SYMBOL (selection); - if (EQ (selection, Qnil)) selection = QPRIMARY; + if (NILP (selection)) selection = QPRIMARY; if (EQ (selection, Qt)) selection = QSECONDARY; if (!f) @@ -2306,15 +2299,15 @@ x_fill_property_data (Display *dpy, Lisp_Object data, void *ret, int format) if (NUMBERP (o) || CONSP (o)) { if (CONSP (o) - && RANGED_INTEGERP (X_LONG_MIN >> 16, XCAR (o), X_LONG_MAX >> 16) - && RANGED_INTEGERP (- (1 << 15), XCDR (o), -1)) + && RANGED_FIXNUMP (X_LONG_MIN >> 16, XCAR (o), X_LONG_MAX >> 16) + && RANGED_FIXNUMP (- (1 << 15), XCDR (o), -1)) { /* cons_to_x_long does not handle negative values for v2. For XDnd, v2 might be y of a window, and can be negative. The XDnd spec. is not explicit about negative values, but let's assume negative v2 is sent modulo 2**16. */ - unsigned long v1 = XINT (XCAR (o)) & 0xffff; - unsigned long v2 = XINT (XCDR (o)) & 0xffff; + unsigned long v1 = XFIXNUM (XCAR (o)) & 0xffff; + unsigned long v2 = XFIXNUM (XCDR (o)) & 0xffff; val = (v1 << 16) | v2; } else @@ -2481,11 +2474,11 @@ x_handle_dnd_message (struct frame *f, const XClientMessageEvent *event, data = (unsigned char *) idata; } - vec = Fmake_vector (make_number (4), Qnil); + vec = make_nil_vector (4); ASET (vec, 0, SYMBOL_NAME (x_atom_to_symbol (FRAME_DISPLAY_INFO (f), event->message_type))); ASET (vec, 1, frame); - ASET (vec, 2, make_number (event->format)); + ASET (vec, 2, make_fixnum (event->format)); ASET (vec, 3, x_property_data_to_lisp (f, data, event->message_type, @@ -2496,8 +2489,8 @@ x_handle_dnd_message (struct frame *f, const XClientMessageEvent *event, bufp->kind = DRAG_N_DROP_EVENT; bufp->frame_or_window = frame; bufp->timestamp = CurrentTime; - bufp->x = make_number (x); - bufp->y = make_number (y); + bufp->x = make_fixnum (x); + bufp->y = make_fixnum (y); bufp->arg = vec; bufp->modifiers = 0; @@ -2554,17 +2547,17 @@ x_send_client_event (Lisp_Object display, Lisp_Object dest, Lisp_Object from, struct frame *f = decode_window_system_frame (from); bool to_root; - CHECK_NUMBER (format); + CHECK_FIXNUM (format); CHECK_CONS (values); if (x_check_property_data (values) == -1) error ("Bad data in VALUES, must be number, cons or string"); - if (XINT (format) != 8 && XINT (format) != 16 && XINT (format) != 32) + if (XFIXNUM (format) != 8 && XFIXNUM (format) != 16 && XFIXNUM (format) != 32) error ("FORMAT must be one of 8, 16 or 32"); event.xclient.type = ClientMessage; - event.xclient.format = XINT (format); + event.xclient.format = XFIXNUM (format); if (FRAMEP (dest) || NILP (dest)) { diff --git a/src/xsettings.c b/src/xsettings.c index 6a0240242a0..60b86f43a87 100644 --- a/src/xsettings.c +++ b/src/xsettings.c @@ -393,7 +393,7 @@ parse_settings (unsigned char *prop, struct xsettings *settings) { Lisp_Object byteorder = Fbyteorder (); - int my_bo = XFASTINT (byteorder) == 'B' ? MSBFirst : LSBFirst; + int my_bo = XFIXNAT (byteorder) == 'B' ? MSBFirst : LSBFirst; int that_bo = prop[0]; CARD32 n_settings; int bytes_parsed = 0; diff --git a/src/xterm.c b/src/xterm.c index 3cadf693804..e9cebcebba4 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -549,10 +549,8 @@ x_cr_accumulate_data (void *closure, const unsigned char *data, } static void -x_cr_destroy (Lisp_Object arg) +x_cr_destroy (void *cr) { - cairo_t *cr = (cairo_t *) XSAVE_POINTER (arg, 0); - block_input (); cairo_destroy (cr); unblock_input (); @@ -611,7 +609,7 @@ x_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type) cr = cairo_create (surface); cairo_surface_destroy (surface); - record_unwind_protect (x_cr_destroy, make_save_ptr (cr)); + record_unwind_protect_ptr (x_cr_destroy, cr); while (1) { @@ -924,8 +922,8 @@ x_set_frame_alpha (struct frame *f) if (FLOATP (Vframe_alpha_lower_limit)) alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit); - else if (INTEGERP (Vframe_alpha_lower_limit)) - alpha_min = (XINT (Vframe_alpha_lower_limit)) / 100.0; + else if (FIXNUMP (Vframe_alpha_lower_limit)) + alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0; if (alpha < 0.0) return; @@ -996,12 +994,7 @@ static void x_update_begin (struct frame *f) { #ifdef USE_CAIRO - if (! NILP (tip_frame) && XFRAME (tip_frame) == f - && ! FRAME_VISIBLE_P (f) -#ifdef USE_GTK - && !NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) + if (FRAME_TOOLTIP_P (f) && !FRAME_VISIBLE_P (f)) return; if (! FRAME_CR_SURFACE (f)) @@ -1984,7 +1977,13 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) for (i = 0; i < s->nchars; i++, glyph++) { - char buf[7], *str = NULL; +#ifdef GCC_LINT + enum { PACIFY_GCC_BUG_81401 = 1 }; +#else + enum { PACIFY_GCC_BUG_81401 = 0 }; +#endif + char buf[7 + PACIFY_GCC_BUG_81401]; + char *str = NULL; int len = glyph->u.glyphless.len; if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM) @@ -3113,14 +3112,14 @@ x_draw_image_relief (struct glyph_string *s) if (s->face->id == TOOL_BAR_FACE_ID) { if (CONSP (Vtool_bar_button_margin) - && INTEGERP (XCAR (Vtool_bar_button_margin)) - && INTEGERP (XCDR (Vtool_bar_button_margin))) + && FIXNUMP (XCAR (Vtool_bar_button_margin)) + && FIXNUMP (XCDR (Vtool_bar_button_margin))) { - extra_x = XINT (XCAR (Vtool_bar_button_margin)); - extra_y = XINT (XCDR (Vtool_bar_button_margin)); + extra_x = XFIXNUM (XCAR (Vtool_bar_button_margin)); + extra_y = XFIXNUM (XCDR (Vtool_bar_button_margin)); } - else if (INTEGERP (Vtool_bar_button_margin)) - extra_x = extra_y = XINT (Vtool_bar_button_margin); + else if (FIXNUMP (Vtool_bar_button_margin)) + extra_x = extra_y = XFIXNUM (Vtool_bar_button_margin); } top_p = bot_p = left_p = right_p = false; @@ -3705,33 +3704,53 @@ x_draw_glyph_string (struct glyph_string *s) else { struct font *font = font_for_underline_metrics (s); + unsigned long minimum_offset; + bool underline_at_descent_line; + bool use_underline_position_properties; + Lisp_Object val + = buffer_local_value (Qunderline_minimum_offset, + s->w->contents); + if (FIXNUMP (val)) + minimum_offset = XFIXNAT (val); + else + minimum_offset = 1; + val = buffer_local_value (Qx_underline_at_descent_line, + s->w->contents); + underline_at_descent_line + = !(NILP (val) || EQ (val, Qunbound)); + val + = buffer_local_value (Qx_use_underline_position_properties, + s->w->contents); + use_underline_position_properties + = !(NILP (val) || EQ (val, Qunbound)); /* Get the underline thickness. Default is 1 pixel. */ if (font && font->underline_thickness > 0) thickness = font->underline_thickness; else thickness = 1; - if (x_underline_at_descent_line) + if (underline_at_descent_line) position = (s->height - thickness) - (s->ybase - s->y); else { - /* Get the underline position. This is the recommended - vertical offset in pixels from the baseline to the top of - the underline. This is a signed value according to the + /* Get the underline position. This is the + recommended vertical offset in pixels from + the baseline to the top of the underline. + This is a signed value according to the specs, and its default is ROUND ((maximum descent) / 2), with ROUND(x) = floor (x + 0.5) */ - if (x_use_underline_position_properties + if (use_underline_position_properties && font && font->underline_position >= 0) position = font->underline_position; else if (font) position = (font->descent + 1) / 2; else - position = underline_minimum_offset; + position = minimum_offset; } - position = max (position, underline_minimum_offset); + position = max (position, minimum_offset); } /* Check the sanity of thickness and position. We should avoid drawing underline out of the current line area. */ @@ -4372,16 +4391,6 @@ x_focus_changed (int type, int state, struct x_display_info *dpyinfo, struct fra { x_new_focus_frame (dpyinfo, frame); dpyinfo->x_focus_event_frame = frame; - - /* Don't stop displaying the initial startup message - for a switch-frame event we don't need. */ - /* When run as a daemon, Vterminal_frame is always NIL. */ - bufp->arg = (((NILP (Vterminal_frame) - || ! FRAME_X_P (XFRAME (Vterminal_frame)) - || EQ (Fdaemonp (), Qt)) - && CONSP (Vframe_list) - && !NILP (XCDR (Vframe_list))) - ? Qt : Qnil); bufp->kind = FOCUS_IN_EVENT; XSETFRAME (bufp->frame_or_window, frame); } @@ -4821,15 +4830,15 @@ x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state) Lisp_Object tem; tem = Fget (Vx_ctrl_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_ctrl = XINT (tem) & INT_MAX; + if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem) & INT_MAX; tem = Fget (Vx_alt_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_alt = XINT (tem) & INT_MAX; + if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem) & INT_MAX; tem = Fget (Vx_meta_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_meta = XINT (tem) & INT_MAX; + if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem) & INT_MAX; tem = Fget (Vx_hyper_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_hyper = XINT (tem) & INT_MAX; + if (FIXNUMP (tem)) mod_hyper = XFIXNUM (tem) & INT_MAX; tem = Fget (Vx_super_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_super = XINT (tem) & INT_MAX; + if (FIXNUMP (tem)) mod_super = XFIXNUM (tem) & INT_MAX; return ( ((state & (ShiftMask | dpyinfo->shift_lock_mask)) ? shift_modifier : 0) | ((state & ControlMask) ? mod_ctrl : 0) @@ -4851,15 +4860,15 @@ 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); + if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem); tem = Fget (Vx_alt_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_alt = XINT (tem); + if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem); tem = Fget (Vx_meta_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_meta = XINT (tem); + if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem); tem = Fget (Vx_hyper_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_hyper = XINT (tem); + if (FIXNUMP (tem)) mod_hyper = XFIXNUM (tem); tem = Fget (Vx_super_keysym, Qmodifier_value); - if (INTEGERP (tem)) mod_super = XINT (tem); + if (FIXNUMP (tem)) mod_super = XFIXNUM (tem); return ( ((state & mod_alt) ? dpyinfo->alt_mod_mask : 0) @@ -5508,8 +5517,8 @@ x_scroll_bar_to_input_event (const XEvent *event, #endif ievent->code = 0; ievent->part = ev->data.l[2]; - ievent->x = make_number (ev->data.l[3]); - ievent->y = make_number (ev->data.l[4]); + ievent->x = make_fixnum (ev->data.l[3]); + ievent->y = make_fixnum (ev->data.l[4]); ievent->modifiers = 0; } @@ -5543,8 +5552,8 @@ x_horizontal_scroll_bar_to_input_event (const XEvent *event, #endif ievent->code = 0; ievent->part = ev->data.l[2]; - ievent->x = make_number (ev->data.l[3]); - ievent->y = make_number (ev->data.l[4]); + ievent->x = make_fixnum (ev->data.l[3]); + ievent->y = make_fixnum (ev->data.l[4]); ievent->modifiers = 0; } @@ -8106,7 +8115,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* Redo the mouse-highlight after the tooltip has gone. */ if (event->xunmap.window == tip_window) { - tip_window = 0; + tip_window = None; x_redo_mouse_highlight (dpyinfo); } @@ -8198,7 +8207,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* If mouse-highlight is an integer, input clears out mouse highlighting. */ - if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight) + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) #if ! defined (USE_GTK) && (f == 0 || !EQ (f->tool_bar_window, hlinfo->mouse_face_window)) @@ -8355,15 +8364,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* Now non-ASCII. */ if (HASH_TABLE_P (Vx_keysym_table) - && (c = Fgethash (make_number (keysym), + && (c = Fgethash (make_fixnum (keysym), Vx_keysym_table, Qnil), - NATNUMP (c))) + FIXNATP (c))) { - inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFASTINT (c)) + inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c)) ? ASCII_KEYSTROKE_EVENT : MULTIBYTE_CHAR_KEYSTROKE_EVENT); - inev.ie.code = XFASTINT (c); + inev.ie.code = XFIXNAT (c); goto done_keysym; } @@ -8748,7 +8757,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef USE_X_TOOLKIT /* Tip frames are pure X window, set size for them. */ - if (! NILP (tip_frame) && XFRAME (tip_frame) == f) + if (FRAME_TOOLTIP_P (f)) { if (FRAME_PIXEL_HEIGHT (f) != configureEvent.xconfigure.height || FRAME_PIXEL_WIDTH (f) != configureEvent.xconfigure.width) @@ -9819,7 +9828,7 @@ x_connection_closed (Display *dpy, const char *error_message, bool ioerror) current Xt versions, this isn't needed either. */ #ifdef USE_GTK /* A long-standing GTK bug prevents proper disconnect handling - (https://gitlab.gnome.org/GNOME/gtk/issues/221). Once, + <https://gitlab.gnome.org/GNOME/gtk/issues/221>. Once, the resulting Glib error message loop filled a user's disk. To avoid this, kill Emacs unconditionally on disconnect. */ shut_down_emacs (0, Qnil); @@ -9850,7 +9859,7 @@ For details, see etc/PROBLEMS.\n", if (terminal_list == 0) { fprintf (stderr, "%s\n", error_msg); - Fkill_emacs (make_number (70)); + Fkill_emacs (make_fixnum (70)); /* NOTREACHED */ } @@ -9932,7 +9941,6 @@ x_io_error_quitter (Display *display) snprintf (buf, sizeof buf, "Connection lost to X server '%s'", DisplayString (display)); x_connection_closed (display, buf, true); - assume (false); } /* Changing the font of the frame. */ @@ -9986,11 +9994,7 @@ x_new_font (struct frame *f, Lisp_Object font_object, int fontset) /* Don't change the size of a tip frame; there's no point in doing it because it's done in Fx_show_tip, and it leads to problems because the tip frame has no widget. */ - if (NILP (tip_frame) || XFRAME (tip_frame) != f -#ifdef USE_GTK - || NILP (Fframe_parameter (tip_frame, Qtooltip)) -#endif - ) + if (!FRAME_TOOLTIP_P (f)) { adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3, @@ -10255,8 +10259,8 @@ x_calc_absolute_position (struct frame *f) XSETFRAME (frame, f); edges = Fx_frame_edges (frame, Qouter_edges); if (!NILP (edges)) - width = (XINT (Fnth (make_number (2), edges)) - - XINT (Fnth (make_number (0), edges))); + width = (XFIXNUM (Fnth (make_fixnum (2), edges)) + - XFIXNUM (Fnth (make_fixnum (0), edges))); } if (p) @@ -10297,8 +10301,8 @@ x_calc_absolute_position (struct frame *f) if (NILP (edges)) edges = Fx_frame_edges (frame, Qouter_edges); if (!NILP (edges)) - height = (XINT (Fnth (make_number (3), edges)) - - XINT (Fnth (make_number (1), edges))); + height = (XFIXNUM (Fnth (make_fixnum (3), edges)) + - XFIXNUM (Fnth (make_fixnum (1), edges))); } if (p) @@ -10502,16 +10506,16 @@ set_wm_state (Lisp_Object frame, bool add, Atom atom, Atom value) { struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (XFRAME (frame)); - x_send_client_event (frame, make_number (0), frame, + x_send_client_event (frame, make_fixnum (0), frame, dpyinfo->Xatom_net_wm_state, - make_number (32), + make_fixnum (32), /* 1 = add, 0 = remove */ Fcons - (make_number (add), + (make_fixnum (add), Fcons - (make_fixnum_or_float (atom), + (INT_TO_INTEGER (atom), (value != 0 - ? list1 (make_fixnum_or_float (value)) + ? list1 (INT_TO_INTEGER (value)) : Qnil)))); } @@ -10639,14 +10643,14 @@ get_current_wm_state (struct frame *f, #ifdef USE_XCB xcb_get_property_cookie_t prop_cookie; xcb_get_property_reply_t *prop; - xcb_atom_t *reply_data; + xcb_atom_t *reply_data UNINIT; #else Display *dpy = FRAME_X_DISPLAY (f); unsigned long bytes_remaining; int rc, actual_format; Atom actual_type; unsigned char *tmp_data = NULL; - Atom *reply_data; + Atom *reply_data UNINIT; #endif *sticky = false; @@ -11140,8 +11144,8 @@ x_set_window_size_1 (struct frame *f, bool change_gravity, { frame_size_history_add (f, Qx_set_window_size_1, width, height, - list2 (make_number (old_height), - make_number (pixelheight + FRAME_MENUBAR_HEIGHT (f)))); + list2 (make_fixnum (old_height), + make_fixnum (pixelheight + FRAME_MENUBAR_HEIGHT (f)))); XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), old_width, pixelheight + FRAME_MENUBAR_HEIGHT (f)); @@ -11150,7 +11154,7 @@ x_set_window_size_1 (struct frame *f, bool change_gravity, { frame_size_history_add (f, Qx_set_window_size_2, width, height, - list2 (make_number (old_width), make_number (pixelwidth))); + list2 (make_fixnum (old_width), make_fixnum (pixelwidth))); XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), pixelwidth, old_height); @@ -11160,10 +11164,10 @@ x_set_window_size_1 (struct frame *f, bool change_gravity, { frame_size_history_add (f, Qx_set_window_size_3, width, height, - list3 (make_number (pixelwidth + FRAME_TOOLBAR_WIDTH (f)), - make_number (pixelheight + FRAME_TOOLBAR_HEIGHT (f) + list3 (make_fixnum (pixelwidth + FRAME_TOOLBAR_WIDTH (f)), + make_fixnum (pixelheight + FRAME_TOOLBAR_HEIGHT (f) + FRAME_MENUBAR_HEIGHT (f)), - make_number (FRAME_MENUBAR_HEIGHT (f)))); + make_fixnum (FRAME_MENUBAR_HEIGHT (f)))); XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), pixelwidth, pixelheight + FRAME_MENUBAR_HEIGHT (f)); @@ -11228,7 +11232,7 @@ x_set_window_size (struct frame *f, bool change_gravity, /* The following breaks our calculations. If it's really needed, think of something else. */ #if false - if (NILP (tip_frame) || XFRAME (tip_frame) != f) + if (!FRAME_TOOLTIP_P (f)) { int text_width, text_height; @@ -11347,9 +11351,9 @@ x_ewmh_activate_frame (struct frame *f) { Lisp_Object frame; XSETFRAME (frame, f); - x_send_client_event (frame, make_number (0), frame, + x_send_client_event (frame, make_fixnum (0), frame, dpyinfo->Xatom_net_active_window, - make_number (32), + make_fixnum (32), list2i (1, dpyinfo->last_user_time)); } } @@ -13275,11 +13279,12 @@ syms_of_xterm (void) x_use_underline_position_properties, doc: /* Non-nil means make use of UNDERLINE_POSITION font properties. A value of nil means ignore them. If you encounter fonts with bogus -UNDERLINE_POSITION font properties, for example 7x13 on XFree prior -to 4.1, set this to nil. You can also use `underline-minimum-offset' -to override the font's UNDERLINE_POSITION for small font display -sizes. */); +UNDERLINE_POSITION font properties, set this to nil. You can also use +`underline-minimum-offset' to override the font's UNDERLINE_POSITION for +small font display sizes. */); x_use_underline_position_properties = true; + DEFSYM (Qx_use_underline_position_properties, + "x-use-underline-position-properties"); DEFVAR_BOOL ("x-underline-at-descent-line", x_underline_at_descent_line, @@ -13290,6 +13295,7 @@ A value of nil means to draw the underline according to the value of the variable `x-use-underline-position-properties', which is usually at the baseline level. The default value is nil. */); x_underline_at_descent_line = false; + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); DEFVAR_BOOL ("x-mouse-click-focus-ignore-position", x_mouse_click_focus_ignore_position, @@ -13323,15 +13329,15 @@ With MS Windows or Nextstep, the value is t. */); DEFSYM (Qmodifier_value, "modifier-value"); DEFSYM (Qctrl, "ctrl"); - Fput (Qctrl, Qmodifier_value, make_number (ctrl_modifier)); + Fput (Qctrl, Qmodifier_value, make_fixnum (ctrl_modifier)); DEFSYM (Qalt, "alt"); - Fput (Qalt, Qmodifier_value, make_number (alt_modifier)); + Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier)); DEFSYM (Qhyper, "hyper"); - Fput (Qhyper, Qmodifier_value, make_number (hyper_modifier)); + Fput (Qhyper, Qmodifier_value, make_fixnum (hyper_modifier)); DEFSYM (Qmeta, "meta"); - Fput (Qmeta, Qmodifier_value, make_number (meta_modifier)); + Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier)); DEFSYM (Qsuper, "super"); - Fput (Qsuper, Qmodifier_value, make_number (super_modifier)); + Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier)); DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, doc: /* Which keys Emacs uses for the ctrl modifier. diff --git a/src/xterm.h b/src/xterm.h index 411a5567cc0..972a10f4d41 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -503,6 +503,8 @@ extern bool x_display_ok (const char *); extern void select_visual (struct x_display_info *); +extern Window tip_window; + /* Each X frame object points to its own struct x_output object in the output_data.x field. The x_output structure contains the information that is specific to X windows. */ @@ -935,7 +937,7 @@ struct scroll_bar /* True if the scroll bar is horizontal. */ bool horizontal; -}; +} GCALIGNED_STRUCT; /* Turning a lisp vector value into a pointer to a struct scroll_bar. */ #define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec)) diff --git a/src/xwidget.c b/src/xwidget.c index fcd2a0e4b96..dcbccdf27c7 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -30,6 +30,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <webkit2/webkit2.h> #include <JavaScriptCore/JavaScript.h> +/* Suppress GCC deprecation warnings starting in WebKitGTK+ 2.21.1 for + webkit_javascript_result_get_global_context and + webkit_javascript_result_get_value (Bug#33679). + FIXME: Use the JavaScriptCore GLib API instead, and remove this hack. */ +#if WEBKIT_CHECK_VERSION (2, 21, 1) && GNUC_PREREQ (4, 2, 0) +# pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + static struct xwidget * allocate_xwidget (void) { @@ -81,16 +89,16 @@ Returns the newly constructed xwidget, or nil if construction fails. */) if (!xg_gtk_initialized) error ("make-xwidget: GTK has not been initialized"); CHECK_SYMBOL (type); - CHECK_NATNUM (width); - CHECK_NATNUM (height); + CHECK_FIXNAT (width); + CHECK_FIXNAT (height); struct xwidget *xw = allocate_xwidget (); Lisp_Object val; xw->type = type; xw->title = title; xw->buffer = NILP (buffer) ? Fcurrent_buffer () : Fget_buffer_create (buffer); - xw->height = XFASTINT (height); - xw->width = XFASTINT (width); + xw->height = XFIXNAT (height); + xw->width = XFIXNAT (width); xw->kill_without_query = false; XSETXWIDGET (val, xw); Vxwidget_list = Fcons (val, Vxwidget_list); @@ -296,17 +304,21 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value) case kJSTypeBoolean: return (JSValueToBoolean (context, value)) ? Qt : Qnil; case kJSTypeNumber: - return make_number (JSValueToNumber (context, value, NULL)); + return make_fixnum (JSValueToNumber (context, value, NULL)); case kJSTypeObject: { if (JSValueIsArray (context, value)) { JSStringRef pname = JSStringCreateWithUTF8CString("length"); - JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value, pname, NULL); - EMACS_INT n = JSValueToNumber (context, len, NULL); + JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value, + pname, NULL); + double dlen = JSValueToNumber (context, len, NULL); JSStringRelease(pname); Lisp_Object obj; + if (! (0 <= dlen && dlen < PTRDIFF_MAX + 1.0)) + memory_full (SIZE_MAX); + ptrdiff_t n = dlen; struct Lisp_Vector *p = allocate_vector (n); for (ptrdiff_t i = 0; i < n; ++i) @@ -325,10 +337,12 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value) JSPropertyNameArrayRef properties = JSObjectCopyPropertyNames (context, (JSObjectRef) value); - ptrdiff_t n = JSPropertyNameArrayGetCount (properties); + size_t n = JSPropertyNameArrayGetCount (properties); Lisp_Object obj; /* TODO: can we use a regular list here? */ + if (PTRDIFF_MAX < n) + memory_full (n); struct Lisp_Vector *p = allocate_vector (n); for (ptrdiff_t i = 0; i < n; ++i) @@ -364,7 +378,7 @@ webkit_js_to_lisp (JSContextRef context, JSValueRef value) static void webkit_javascript_finished_cb (GObject *webview, GAsyncResult *result, - gpointer lisp_callback) + gpointer arg) { WebKitJavascriptResult *js_result; JSValueRef value; @@ -372,6 +386,11 @@ webkit_javascript_finished_cb (GObject *webview, GError *error = NULL; struct xwidget *xw = g_object_get_data (G_OBJECT (webview), XG_XWIDGET); + ptrdiff_t script_idx = (intptr_t) arg; + Lisp_Object script_callback = AREF (xw->script_callbacks, script_idx); + ASET (xw->script_callbacks, script_idx, Qnil); + if (!NILP (script_callback)) + xfree (xmint_pointer (XCAR (script_callback))); js_result = webkit_web_view_run_javascript_finish (WEBKIT_WEB_VIEW (webview), result, &error); @@ -383,19 +402,19 @@ webkit_javascript_finished_cb (GObject *webview, 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); + if (!NILP (script_callback) && !NILP (XCDR (script_callback))) + { + 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); + + /* 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, XCDR (script_callback), lisp_value); + } - /* Register an xwidget event here, which then runs the callback. - This ensures that the callback runs in sync with the Emacs - event loop. */ - /* FIXME: This might lead to disaster if LISP_CALLBACK's object - was garbage collected before now. See the FIXME in - Fxwidget_webkit_execute_script. */ - store_xwidget_js_callback_event (xw, XIL ((intptr_t) lisp_callback), - lisp_value); + webkit_javascript_result_unref (js_result); } @@ -591,22 +610,20 @@ 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; + struct xwidget_view *xv = xwidget_view_lookup (xww, s->w); 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); /* Do initialization here in the display loop because there is no - other time to know things like window placement etc. */ - xv = xwidget_init_view (xww, s, x, y); + other time to know things like window placement etc. Do not + create a new view if we have found one that is usable. */ + if (!xv) + xv = xwidget_init_view (xww, s, x, y); int text_area_x, text_area_y, text_area_width, text_area_height; @@ -686,6 +703,7 @@ DEFUN ("xwidget-webkit-goto-uri", { WEBKIT_FN_INIT (); CHECK_STRING (uri); + uri = ENCODE_FILE (uri); webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), SSDATA (uri)); return Qnil; } @@ -693,8 +711,7 @@ DEFUN ("xwidget-webkit-goto-uri", DEFUN ("xwidget-webkit-zoom", Fxwidget_webkit_zoom, Sxwidget_webkit_zoom, 2, 2, 0, - doc: /* Change the zoom factor of the xwidget webkit instance -referenced by XWIDGET. */) + doc: /* Change the zoom factor of the xwidget webkit instance referenced by XWIDGET. */) (Lisp_Object xwidget, Lisp_Object factor) { WEBKIT_FN_INIT (); @@ -709,12 +726,33 @@ referenced by XWIDGET. */) return Qnil; } +/* Save script and fun in the script/callback save vector and return + its index. */ +static ptrdiff_t +save_script_callback (struct xwidget *xw, Lisp_Object script, Lisp_Object fun) +{ + Lisp_Object cbs = xw->script_callbacks; + if (NILP (cbs)) + xw->script_callbacks = cbs = make_nil_vector (32); + + /* Find first free index. */ + ptrdiff_t idx; + for (idx = 0; !NILP (AREF (cbs, idx)); idx++) + if (idx + 1 == ASIZE (cbs)) + { + xw->script_callbacks = cbs = larger_vector (cbs, 1, -1); + break; + } + + ASET (cbs, idx, Fcons (make_mint_ptr (xlispstrdup (script)), fun)); + return idx; +} 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 + 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) { @@ -723,36 +761,34 @@ argument procedure FUN.*/) if (!NILP (fun) && !FUNCTIONP (fun)) wrong_type_argument (Qinvalid_function, fun); - GAsyncReadyCallback callback - = FUNCTIONP (fun) ? webkit_javascript_finished_cb : NULL; + script = ENCODE_SYSTEM (script); - /* FIXME: The following hack assumes USE_LSB_TAG. */ - verify (USE_LSB_TAG); - /* FIXME: This hack might lead to disaster if FUN is garbage - collected before store_xwidget_js_callback_event makes it visible - to Lisp again. See the FIXME in webkit_javascript_finished_cb. */ - gpointer callback_arg = (gpointer) (intptr_t) XLI (fun); + /* Protect script and fun during GC. */ + intptr_t idx = save_script_callback (xw, script, fun); /* JavaScript execution happens asynchronously. If an elisp callback function is provided we pass it to the C callback procedure that retrieves the return value. */ + gchar *script_string + = xmint_pointer (XCAR (AREF (xw->script_callbacks, idx))); webkit_web_view_run_javascript (WEBKIT_WEB_VIEW (xw->widget_osr), - SSDATA (script), + script_string, NULL, /* cancelable */ - callback, callback_arg); + webkit_javascript_finished_cb, + (gpointer) idx); return Qnil; } DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, - doc: /* Resize XWIDGET. NEW_WIDTH, NEW_HEIGHT define the new size. */ ) + doc: /* Resize XWIDGET to NEW_WIDTH, NEW_HEIGHT. */ ) (Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height) { CHECK_XWIDGET (xwidget); CHECK_RANGED_INTEGER (new_width, 0, INT_MAX); CHECK_RANGED_INTEGER (new_height, 0, INT_MAX); struct xwidget *xw = XXWIDGET (xwidget); - int w = XFASTINT (new_width); - int h = XFASTINT (new_height); + int w = XFIXNAT (new_width); + int h = XFIXNAT (new_height); xw->width = w; xw->height = h; @@ -795,8 +831,8 @@ Emacs allocated area accordingly. */) CHECK_XWIDGET (xwidget); GtkRequisition requisition; gtk_widget_size_request (XXWIDGET (xwidget)->widget_osr, &requisition); - return list2 (make_number (requisition.width), - make_number (requisition.height)); + return list2 (make_fixnum (requisition.width), + make_fixnum (requisition.height)); } DEFUN ("xwidgetp", @@ -827,7 +863,7 @@ Currently [TYPE TITLE WIDTH HEIGHT]. */) CHECK_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); return CALLN (Fvector, xw->type, xw->title, - make_natnum (xw->width), make_natnum (xw->height)); + make_fixed_natnum (xw->width), make_fixed_natnum (xw->height)); } DEFUN ("xwidget-view-info", @@ -839,9 +875,9 @@ Currently [X Y CLIP_RIGHT CLIP_BOTTOM CLIP_TOP CLIP_LEFT]. */) { CHECK_XWIDGET_VIEW (xwidget_view); struct xwidget_view *xv = XXWIDGET_VIEW (xwidget_view); - return CALLN (Fvector, make_number (xv->x), make_number (xv->y), - make_number (xv->clip_right), make_number (xv->clip_bottom), - make_number (xv->clip_top), make_number (xv->clip_left)); + return CALLN (Fvector, make_fixnum (xv->x), make_fixnum (xv->y), + make_fixnum (xv->clip_right), make_fixnum (xv->clip_bottom), + make_fixnum (xv->clip_top), make_fixnum (xv->clip_left)); } DEFUN ("xwidget-view-model", @@ -1081,7 +1117,7 @@ xwidget_view_lookup (struct xwidget *xw, struct window *w) ret = Fxwidget_view_lookup (xwidget, window); - return EQ (ret, Qnil) ? NULL : XXWIDGET_VIEW (ret); + return NILP (ret) ? NULL : XXWIDGET_VIEW (ret); } struct xwidget * @@ -1204,6 +1240,14 @@ kill_buffer_xwidgets (Lisp_Object buffer) gtk_widget_destroy (xw->widget_osr); gtk_widget_destroy (xw->widgetwindow_osr); } + if (!NILP (xw->script_callbacks)) + for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++) + { + Lisp_Object cb = AREF (xw->script_callbacks, idx); + if (!NILP (cb)) + xfree (xmint_pointer (XCAR (cb))); + ASET (xw->script_callbacks, idx, Qnil); + } } } } diff --git a/src/xwidget.h b/src/xwidget.h index 1a742318271..8c598efb2e2 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -47,6 +47,9 @@ struct xwidget /* A title used for button labels, for instance. */ Lisp_Object title; + /* Vector of currently executing scripts with callbacks. */ + Lisp_Object script_callbacks; + /* Here ends the Lisp part. "height" is the marker field. */ int height; @@ -58,7 +61,7 @@ struct xwidget /* Kill silently if Emacs is exited. */ bool_bf kill_without_query : 1; -}; +} GCALIGNED_STRUCT; struct xwidget_view { @@ -85,13 +88,13 @@ struct xwidget_view int clip_left; long handler_id; -}; +} GCALIGNED_STRUCT; #endif /* Test for xwidget pseudovector. */ #define XWIDGETP(x) PSEUDOVECTORP (x, PVEC_XWIDGET) #define XXWIDGET(a) (eassert (XWIDGETP (a)), \ - (struct xwidget *) XUNTAG (a, Lisp_Vectorlike)) + XUNTAG (a, Lisp_Vectorlike, struct xwidget)) #define CHECK_XWIDGET(x) \ CHECK_TYPE (XWIDGETP (x), Qxwidgetp, x) @@ -99,7 +102,7 @@ struct xwidget_view /* Test for xwidget_view pseudovector. */ #define XWIDGET_VIEW_P(x) PSEUDOVECTORP (x, PVEC_XWIDGET_VIEW) #define XXWIDGET_VIEW(a) (eassert (XWIDGET_VIEW_P (a)), \ - (struct xwidget_view *) XUNTAG (a, Lisp_Vectorlike)) + XUNTAG (a, Lisp_Vectorlike, struct xwidget_view)) #define CHECK_XWIDGET_VIEW(x) \ CHECK_TYPE (XWIDGET_VIEW_P (x), Qxwidget_view_p, x) |